diff --git a/compiler/represent.lisp b/compiler/represent.lisp index 12f1d8f55fd9e6a04d139a33499a8a88fc50789c..1c47ae43be6b889aec876bb800383e36045df266 100644 --- a/compiler/represent.lisp +++ b/compiler/represent.lisp @@ -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))