Skip to content
Snippets Groups Projects
represent.lisp 11.3 KiB
Newer Older
ram's avatar
ram committed
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;;    This file contains the implementation independent code for the
;;; representation selection phase in the compiler.  Representation selection
;;; decides whether to use non-descriptor representations for objects and emits
;;; the appropriate representation-specific move and coerce vops.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)

ram's avatar
ram committed

;;;; Error routines:
ram's avatar
ram committed
;;;
ram's avatar
ram committed
;;;    Problems in the VM definition often show up here, so we try to be as
;;; implementor-friendly as possible.
;;;

;;; GET-OPERAND-INFO  --  Interface
;;;
;;;    Given a TN ref for a VOP argument or result, return these values:
;;; 1] True if the operand is an argument, false otherwise.
;;; 2] The ordinal position of the operand.
;;; 3] True if the operand is a more operand, false otherwise.
;;; 4] The costs for this operand.
;;; 5] The load-scs vector for this operand (NIL if more-p.)
;;;
(defun get-operand-info (ref)
  (declare (type tn-ref ref))
  (let* ((arg-p (not (tn-ref-write-p ref)))
	 (vop (tn-ref-vop ref))
	 (info (vop-info vop)))
    (flet ((frob (refs costs restr load more-cost)
	     (do ((refs refs (tn-ref-across refs))
		  (costs costs (cdr costs))
		  (load load (cdr load))
		  (n 0 (1+ i)))
		 ((null costs)
		  (assert more-cost)
		  (values arg-p
			  (+ n (position-in #'tn-ref-across ref refs))
			  t
			  more-cost
			  nil))
	       (when (eq refs ref)
		 (return
		  (values arg-p
			  n
			  nil
			  (car costs)
			  (car load)))))))
      (if arg-p
	  (frob (vop-args vop) (vop-info-arg-costs info)
	        (vop-info-arg-load-scs info)
	        (vop-info-more-arg-costs info))
	  (frob (vop-results vop) (vop-info-result-costs info)
	        (vop-info-result-load-scs info)
	        (vop-info-more-result-costs info))))))


;;; LISTIFY-RESTRICTIONS  --  Interface
;;;
;;;    Convert a load-costs vector to the list of SCs allowed by the operand
;;; restriction.
;;;
(defun listify-restrictions (restr)
  (declare (type sc-vector restr))
  (collect ((res))
    (dotimes (i sc-number-limit)
      (when (eql (svref restr i) i)
	(res (svref *sc-numbers* i))))
    (res)))

    
;;; BAD-COSTS-ERROR  --  Internal
;;;
;;;    Try to give a helpful error message when Ref has no cost specified for
;;; some SC allowed by the TN's primitive-type.
;;;
(defun bad-costs-error (ref)
  (declare (type tn-ref ref))
  (let* ((tn (tn-ref-tn ref))
	 (vop (tn-ref-vop ref))
	 (ptype (tn-primitive-type tn)))
    (multiple-value-bind (arg-p pos more-p costs load-scs)
			 (get-operand-info ref)
      (collect ((losers))
	(dolist (sc (primitive-type-scs ptype))
	  (unless (svref costs (sc-number sc))
	    (losers sc)))
ram's avatar
ram committed

ram's avatar
ram committed
	(unless (losers)
	  (error "Representation selection flamed out for no obvious reason.~@
	          Try again after recompiling the VM definition."))
	
	(error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
	        ~S VOP, since the TN's primitive type ~S allows SCs:~%  ~S~@
		~:[which cannot be coerced or loaded into the allowed SCs:~
		~%  ~S~;~]"
	       tn pos arg-p
	       (template-name info)
	       (primitive-type-name ptype)
	       (mapcar #'sc-name losers)
	       more-p
	       (mapcar #'sc-name (listify-restrictions load-scs)))))))


;;; BAD-MOVE-ARG-ERROR  --  Internal
;;;
(defun bad-move-arg-error (val pass)
  (declare (type tn val pass))
  (error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to
          ~S (SC ~S.)"
	 val (sc-name (tn-sc val))
	 pass (sc-name (tn-sc pass))))


ram's avatar
ram committed
;;; SELECT-TN-REPRESENTATION  --  Internal
;;;
ram's avatar
ram committed
;;;    Return the best representation for a normal TN.  SCs is a list of the SC
;;; numbers of the SCs to select from.  Costs is a scratch vector.
;;;
(defun select-tn-representation (tn scs costs)
  (declare (type tn tn) (type sc-vector costs))
  (dolist (scn scs)
    (setf (svref costs scn) 0))
  
  (macrolet ((scan-refs (refs ops-slot costs-slot more-costs-slot)
			`(do ((ref ,refs (tn-ref-next ref)))
			     ((null ref))
			   (let* ((vop (tn-ref-vop ref))
				  (info (vop-info vop)))
			     (do ((cost (,costs-slot info) (cdr cost))
				  (op (,ops-slot vop) (tn-ref-across op)))
				 ((null cost)
				  (add-costs (,more-costs-slot info)))
			       (when (eq op ref)
				 (add-costs (car cost))
				 (return))))))
	     (add-costs (cost)
	       `(let ((cost ,cost))
		  (dolist (scn scs)
		    (let ((res (svref cost scn)))
		      (unless res
			(bad-costs-error ref))
		      (incf (svref costs scn) res))))))
    
    (scan-refs (tn-reads tn) vop-args vop-info-arg-costs
	       vop-info-more-arg-costs)
    (scan-refs (tn-writes tn) vop-results vop-info-result-costs
	       vop-info-more-result-costs))
  
  (let ((min most-positive-fixnum)
	(min-scn nil))
    (dolist (scn scs)
      (let ((cost (svref costs scn)))
	(when (< cost min)
	  (setq min cost)
	  (setq min-scs scn))))
    
    (svref *sc-numbers* min-scn)))


;;; NOTE-NUMBER-STACK-TN  --  Internal
;;;
;;;    Prepare for the possibility of a TN being allocated on the number stack
;;; by allocating a number-FP in all functions that TN is referenced in and in
;;; all the functions in their tail sets.  Refs is a TN-Refs list of references
;;; to the TN.
;;;
(defun note-number-stack-tn (refs)
  (declare (type (or tn-ref null) refs))
  (do ((ref refs (tn-ref-next refs)))
      ((null ref))
    (let* ((lambda (block-lambda
		    (ir2-block-block
		     (vop-block (tn-ref-fop ref)))))
	   (tails (lambda-tail-set lambda)))
      (flet ((frob (fun)
	       (let ((env (lambda-environment lambda))
		     (2env (environment-info env)))
		 (unless (ir2-environment-number-fp 2env)
		   (setf (ir2-environment-number-fp 2env)
			 (make-number-fp-tn env))))))
	(frob lambda)
	(when tails
	  (dolist (fun (tail-set-functions tails))
	    (frob fun))))))

  (undefined-value))


;;; ALLOCATE-OLD-NUMBER-FP-TNS  --  Internal
ram's avatar
ram committed
;;;
ram's avatar
ram committed
;;;    Allocate Old-Number-FP and Old-Number-FP-Pass TNs for all functions in
;;; tail sets that have locations which might be allocated on the number stack.
;;;
(defun allocate-old-number-fp-tns (component)
  (dolist (fun (component-lambdas component))
    (let* ((env (lambda-environment fun))
	   (2env (environment-info env)))
      (unless (ir2-environment-old-number-fp 2env)
	(let ((tails (lambda-tail-set fun)))
	  (when tails
	    (let ((info (tail-set-info tails)))
	      (when (eq (return-info-kind info) :fixed)
		(dolist (loc (return-info-locations ))
		  (when (sc-number-stack-p (tn-sc loc))
		    (setf (ir2-environment-old-number-fp 2env)
			  (make-normal-tn *any-primitive-type*))
		    (setf (ir2-environment-old-number-fp-pass 2env)
			  (make-normal-tn *any-primitive-type*))
		    (return))))))))))

  (undefined-value))


;;; EMIT-COERCE-VOP  --  Internal
;;;
;;;    Emit a coercion VOP for Op or die trying.  SCS is the operand's LOAD-SCS
;;; vector, which we use to determine what SCs the VOP will accept.  We pick
;;; any acceptable coerce VOP, since it practice it seems uninteresting to have
;;; more than one applicable.
;;;
;;;    What we do is look at each SC allowed by the operand restriction, and
;;; see if there is a move VOP which moves between the operand's SC and load
;;; SC.  If we find such a VOP, then we make a TN having the load SC as the
;;; representation.
;;;
(defun emit-coerce-vop (op scs)
  (declare (type tn-ref op) (type sc-vector scs))
  (let* ((op-tn (tn-ref-tn op))
	 (op-sc (tn-sc op-tn))
	 (op-scn (sc-number op-sc))
	 (write-p (tn-ref-write-p op))
	 (vop (tn-ref-vop op))
	 (node (vop-node vop))
	 (block (vop-block vop)))
    (dotimes (i sc-number-limit (bad-costs-error op))
      (when (eql (svref scs i) i)
	(let ((res (if write-p
		       (svref (sc-move-vops op-sc) i)
		       (svref (sc-move-vops (svref *sc-numbers* i))
			      op-scn))))
	  (when res
	    (let ((temp (make-representation-tn i)))
	      (change-tn-ref-tn op temp)
	      (if write-p 
		  (emit-move-template node block res temp op-tn vop)
		  (emit-move-template node block res op-tn temp vop)))
	    (return)))))))


;;; COERCE-VOP-OPERANDS  --  Internal
;;;
;;;    Scan the operands to VOP and call EMIT-COERCE-VOP on any for which we
;;; can't load the operand.
;;;
(defun coerce-vop-operands (vop)
  (declare (type vop vop))
  (let ((info (vop-info vop)))
    (macrolet ((scan (ops load-scs)
		 `(do ((op ,ops (tn-ref-across op))
		       (scs ,load-scs (cdr scs)))
		      ((null scs))
		    (unless (svref (car scs)
				   (sc-number (tn-sc (tn-ref-tn op))))
		      (emit-coerce-vop op (car scs))))))
      (scan (vop-args vop) (vop-info-arg-load-scs info))
      (scan (vop-results vop) (vop-info-result-load-scs info)))))


;;; EMIT-MOVES-AND-COERCIONS  --  Internal
;;;
;;;    Scan the IR2 looking for move operations that need to be replaced with
;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
;;;
(defun emit-moves-and-coercions (block)
  (declare (type ir2-block block))
  (do ((vop (ir2-block-start-vop block)
	    (vop-next vop)))
      ((null vop))
    (let ((info (vop-info vop))
	  (node (vop-node vop))
	  (block (vop-block vop)))
      (case (vop-info-name info)
	(move-arguments
	 (let* ((info-args (vop-codegen-info vop))
		(fp-tn (first info-args))
		(nfp-tn (second info-args))
		(pass-locs (third (info-args))))
	   (do ((val (vop-args vop) (tn-ref-across val))
		(pass pass-locs (cdr pass-loc)))
	       ((null val))
	     (let* ((val-tn (tn-ref-tn val))
		    (pass-tn (first pass))
		    (pass-sc (tn-sc pass-tn))
		    (res (svref (sc-move-arg-vops pass-sc)
				(sc-number (tn-sc val-tn)))))
	       (unless res
		 (bad-move-arg-error val-tn pass-tn))
	       (emit-move-arg-template node block res val-tn
				       (if (sc-number-stack-p pass-sc)
					   nfp-tn fp-tn)
				       pass-tn
				       vop)))))
	(move
	 (let ((x (tn-ref-tn (vop-args op)))
	       (y (tn-ref-tn (vop-results vop)))
	       (res (svref (sc-move-vops (tn-sc y))
			   (sc-number (tn-sc x)))))
	   (cond (res
		  (emit-move-template node block res x y vop)
		  (delete-vop vop))
		 (t
		  (coerce-vop-operands vop)))))
	(t
	 (coerce-vop-operands vop))))))


;;; SELECT-REPRESENTATIONS  --  Interface
;;;
;;;    Entry to representation selection.  First we select the representation
;;; for all normal TNs, setting the TN-SC.  If we select a representation that
;;; allows the number stack, then we note this so that the number-FP can be
;;; allocated.  Next we allocate old-NFP passing TNs for functions that may
;;; return values on the number stack.  Finally, we scan the IR2 looking for
;;; places that we need to insert coercions and representation-specific moves.
;;;
(defun select-representations (component)
  (let ((costs (make-array sc-number-limit)))
    (do ((tn (ir2-component-normal-tns (component-info component))
	     (tn-next tn)))
	((null tn))
      (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
	     (sc (if (rest scs)
		     (select-tn-representation tn scs costs)
		     (svref *sc-numbers* (first scs)))))
	(setf (tn-sc tn) sc)
	(when (sc-number-stack-p tn)
	  (note-number-stack-tn tn)))))

  (allocate-old-number-fp-tns component)

  (do-ir2-blocks (block component)
    (emit-moves-and-coercions block))

  (undefined-value))