diff --git a/compiler/represent.lisp b/compiler/represent.lisp index 1c47ae43be6b889aec876bb800383e36045df266..1c44f2c9cda0629dbfa76bb33ec9076cddb877e9 100644 --- a/compiler/represent.lisp +++ b/compiler/represent.lisp @@ -31,31 +31,46 @@ ;;; 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.) +;;; 6] True if the costs or SCs in the VOP-INFO are inconsistent with the +;;; currently record ones. ;;; (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) + (flet ((frob (refs costs load more-cost) (do ((refs refs (tn-ref-across refs)) (costs costs (cdr costs)) (load load (cdr load)) - (n 0 (1+ i))) + (n 0 (1+ n))) ((null costs) (assert more-cost) (values arg-p - (+ n (position-in #'tn-ref-across ref refs)) + (+ n (position-in #'tn-ref-across ref refs) 1) t more-cost + nil nil)) (when (eq refs ref) - (return - (values arg-p - n - nil - (car costs) - (car load))))))) + (let ((parse (vop-parse-or-lose (vop-info-name info)))) + (multiple-value-bind + (ccosts cscs) + (compute-loading-costs + (elt (if arg-p + (vop-parse-args parse) + (vop-parse-results parse)) + n) + arg-p) + + (return + (values arg-p + (1+ n) + nil + (car costs) + (car load) + (not (and (equalp ccosts (car costs)) + (equalp cscs (car load)))))))))))) (if arg-p (frob (vop-args vop) (vop-info-arg-costs info) (vop-info-arg-load-scs info) @@ -87,14 +102,13 @@ (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) + (multiple-value-bind (arg-p pos more-p costs load-scs incon) (get-operand-info ref) (collect ((losers)) - (dolist (sc (primitive-type-scs ptype)) - (unless (svref costs (sc-number sc)) - (losers sc))) + (dolist (scn (primitive-type-scs ptype)) + (unless (svref costs scn) + (losers (svref *sc-numbers* scn)))) (unless (losers) (error "Representation selection flamed out for no obvious reason.~@ @@ -103,47 +117,88 @@ (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~;~]" + ~% ~S~;~]~:[~;~@ + Current cost info inconsistent with that in effect at compile ~ + time. Recompile.~%Compilation order may be incorrect.~]" tn pos arg-p - (template-name info) + (template-name (vop-info (tn-ref-vop ref))) (primitive-type-name ptype) - (mapcar #'sc-name losers) + (mapcar #'sc-name (losers)) more-p - (mapcar #'sc-name (listify-restrictions load-scs))))))) + (mapcar #'sc-name (listify-restrictions load-scs)) + incon))))) ;;; 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 + (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)))) + +;;;; VM Consistency Checking: +;;; +;;; We do some checking of the consistency of the VM definition at load +;;; time. + +;;; CHECK-MOVE-FUNCTION-CONSISTENCY -- Interface +;;; +(defun check-move-function-consistency () + (dotimes (i sc-number-limit) + (let ((sc (svref *sc-numbers* i))) + (when sc + (let ((moves (sc-load-functions sc))) + (dolist (const (sc-constant-scs sc)) + (unless (svref moves (sc-number const)) + (error "No move function defined to load SC ~S from constant ~ + SC ~S." + (sc-name sc) (sc-name const)))) + + (dolist (alt (sc-alternate-scs sc)) + (unless (svref moves (sc-number alt)) + (error "No move function defined to load SC ~S from alternate ~ + SC ~S." + (sc-name sc) (sc-name alt))) + (unless (svref (sc-load-functions alt) i) + (error "No move function defined to save SC ~S to alternate ~ + SC ~S." + (sc-name sc) (sc-name alt))))))))) +;;; +(check-move-function-consistency) + ;;; SELECT-TN-REPRESENTATION -- Internal ;;; ;;; 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. ;;; +;;; What we do is sum the costs for each reference to TN in each of the +;;; SCs, and then return the SC having the lowest cost. We ignore references +;;; by the MOVE VOP, since counting them would spuriously encourage descriptor +;;; representations. We won't actually need to coerce to descriptor and back, +;;; since we will replace the MOVE with a specialized move VOP. +;;; (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)))))) + `(do ((ref ,refs (tn-ref-next ref))) + ((null ref)) + (let* ((vop (tn-ref-vop ref)) + (info (vop-info vop))) + (unless (eq (vop-info-name info) 'move) + (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) @@ -163,7 +218,7 @@ (let ((cost (svref costs scn))) (when (< cost min) (setq min cost) - (setq min-scs scn)))) + (setq min-scn scn)))) (svref *sc-numbers* min-scn))) @@ -171,24 +226,24 @@ ;;; 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 +;;; by setting NUMBER-STACK-P 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))))) + (vop-block (tn-ref-vop 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)))))) + (setf (ir2-environment-number-stack-p + (environment-info + (lambda-environment fun))) + t))) (frob lambda) (when tails (dolist (fun (tail-set-functions tails)) @@ -197,31 +252,6 @@ (undefined-value)) -;;; ALLOCATE-OLD-NUMBER-FP-TNS -- Internal -;;; -;;; 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 @@ -234,6 +264,9 @@ ;;; SC. If we find such a VOP, then we make a TN having the load SC as the ;;; representation. ;;; +;;; If the TN is an unused result TN, then we don't actually emit the move; +;;; we just change to the right kind of TN. +;;; (defun emit-coerce-vop (op scs) (declare (type tn-ref op) (type sc-vector scs)) (let* ((op-tn (tn-ref-tn op)) @@ -252,9 +285,12 @@ (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))) + (cond + ((not write-p) + (emit-move-template node block res op-tn temp vop)) + ((null (tn-reads op-tn))) + (t + (emit-move-template node block res temp op-tn (vop-next vop))))) (return))))))) @@ -277,6 +313,50 @@ (scan (vop-results vop) (vop-info-result-load-scs info))))) +;;; EMIT-ARG-MOVES -- Internal +;;; +(defun emit-arg-moves (vop) + (let* ((info (vop-info vop)) + (node (vop-node vop)) + (block (vop-block vop)) + (how (vop-info-move-args info)) + (args (vop-args vop)) + (fp-tn (tn-ref-tn args)) + (nfp-tn (if (eq how :local-call) + (tn-ref-tn (tn-ref-across args)) + nil)) + (pass-locs (first (vop-codegen-info vop)))) + (do ((val (do ((arg args (tn-ref-across arg)) + (req (template-arg-types info) (cdr req))) + ((null req) arg)) + (tn-ref-across val)) + (pass pass-locs (cdr pass))) + ((null val) + (assert (null pass))) + (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)) + + (let ((this-fp + (cond ((not (sc-number-stack-p pass-sc)) fp-tn) + (nfp-tn) + (t + (assert (eq how :known-return)) + (setq nfp-tn + (make-representation-tn + (first (primitive-type-scs + *any-primitive-type*)))) + (emit-context-template node block nfp-tn vop) + nfp-tn)))) + (emit-move-arg-template node block res val-tn this-fp pass-tn vop))))) + + (undefined-value)) + + ;;; EMIT-MOVES-AND-COERCIONS -- Internal ;;; ;;; Scan the IR2 looking for move operations that need to be replaced with @@ -290,39 +370,21 @@ (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))) + (cond + ((eq (vop-info-name info) 'move) + (let* ((x (tn-ref-tn (vop-args vop))) (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)))))) + (cond (res + (emit-move-template node block res x y vop) + (delete-vop vop)) + (t + (coerce-vop-operands vop))))) + ((vop-info-move-args info) + (emit-arg-moves vop)) + (t + (coerce-vop-operands vop)))))) ;;; SELECT-REPRESENTATIONS -- Interface @@ -334,20 +396,25 @@ ;;; return values on the number stack. Finally, we scan the IR2 looking for ;;; places that we need to insert coercions and representation-specific moves. ;;; +;;; We ignore TNs that already have a SC (representation is predetermined.) +;;; (defun select-representations (component) - (let ((costs (make-array sc-number-limit))) - (do ((tn (ir2-component-normal-tns (component-info component)) - (tn-next tn))) + (let ((costs (make-array sc-number-limit)) + (2comp (component-info component))) + (do ((tn (ir2-component-normal-tns 2comp) (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) + (unless (tn-sc 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))))) + (assert sc) + (setf (tn-sc tn) sc) + (when (sc-number-stack-p sc) + (unless (ir2-component-nfp 2comp) + (setf (ir2-component-nfp 2comp) (make-nfp-tn))) + (note-number-stack-tn (tn-reads tn)) + (note-number-stack-tn (tn-writes tn))))))) (do-ir2-blocks (block component) (emit-moves-and-coercions block))