Skip to content
Snippets Groups Projects
Commit 2a9d132a authored by ram's avatar ram
Browse files

Initial version.

parent 8c836e2c
No related branches found
No related tags found
No related merge requests found
......@@ -16,14 +16,340 @@
;;;
(in-package 'c)
;;; REPRESENTATION-SELECT-1-BLOCK -- Internal
;;;; Error routines:
;;;
(defun representation-select-1-block (block)
(declare (type ir2-block block))
)
;;; 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)))
(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))))
;;; SELECT-TN-REPRESENTATION -- Internal
;;;
;;; Select the best representation for a normal TN.
;;; 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
;;;
(defun select-tn-representation (tn)
;;; 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))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment