X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Frepresent.lisp;h=7c24005bbc0fa39d2d595b04ea60b6d2c1bd9978;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=a6a7480f8590ffb988f8d488364f1ab717208cff;hpb=20748f2dd7965dcd1446a1cb27e5a5af18a0e5bb;p=sbcl.git diff --git a/src/compiler/represent.lisp b/src/compiler/represent.lisp index a6a7480..7c24005 100644 --- a/src/compiler/represent.lisp +++ b/src/compiler/represent.lisp @@ -31,49 +31,49 @@ (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))) + (vop (tn-ref-vop ref)) + (info (vop-info vop))) (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+ n))) - ((null costs) - (aver more-cost) - (values arg-p - (+ n - (or (position-in #'tn-ref-across ref refs) - (error "couldn't find REF?")) - 1) - t - more-cost - nil - nil)) - (when (eq refs ref) - (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)))))))))))) + (do ((refs refs (tn-ref-across refs)) + (costs costs (cdr costs)) + (load load (cdr load)) + (n 0 (1+ n))) + ((null costs) + (aver more-cost) + (values arg-p + (+ n + (or (position-in #'tn-ref-across ref refs) + (error "couldn't find REF?")) + 1) + t + more-cost + nil + nil)) + (when (eq refs ref) + (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) - (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)))))) + (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)))))) ;;; Convert a load-costs vector to the list of SCs allowed by the ;;; operand restriction. @@ -82,7 +82,7 @@ (collect ((res)) (dotimes (i sc-number-limit) (when (eq (svref restr i) t) - (res (svref *backend-sc-numbers* i)))) + (res (svref *backend-sc-numbers* i)))) (res))) ;;; Try to give a helpful error message when REF has no cost specified @@ -90,95 +90,95 @@ (defun bad-costs-error (ref) (declare (type tn-ref ref)) (let* ((tn (tn-ref-tn ref)) - (ptype (tn-primitive-type tn))) + (ptype (tn-primitive-type tn))) (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info ref) + (get-operand-info ref) (collect ((losers)) - (dolist (scn (primitive-type-scs ptype)) - (unless (svref costs scn) - (losers (svref *backend-sc-numbers* scn)))) - - (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~;~*~]~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - tn pos arg-p - (template-name (vop-info (tn-ref-vop ref))) - (primitive-type-name ptype) - (mapcar #'sc-name (losers)) - more-p - (unless more-p - (mapcar #'sc-name (listify-restrictions load-scs))) - incon))))) + (dolist (scn (primitive-type-scs ptype)) + (unless (svref costs scn) + (losers (svref *backend-sc-numbers* scn)))) + + (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~;~*~]~:[~;~@ + Current cost info inconsistent with that in effect at compile ~ + time. Recompile.~%Compilation order may be incorrect.~]" + tn pos arg-p + (template-name (vop-info (tn-ref-vop ref))) + (primitive-type-name ptype) + (mapcar #'sc-name (losers)) + more-p + (unless more-p + (mapcar #'sc-name (listify-restrictions load-scs))) + incon))))) ;;; Try to give a helpful error message when we fail to do a coercion ;;; for some reason. (defun bad-coerce-error (op) (declare (type tn-ref op)) (let* ((op-tn (tn-ref-tn op)) - (op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (ptype (tn-primitive-type op-tn)) - (write-p (tn-ref-write-p op))) + (op-sc (tn-sc op-tn)) + (op-scn (sc-number op-sc)) + (ptype (tn-primitive-type op-tn)) + (write-p (tn-ref-write-p op))) (multiple-value-bind (arg-p pos more-p costs load-scs incon) - (get-operand-info op) + (get-operand-info op) (declare (ignore costs more-p)) (collect ((load-lose) - (no-move-scs) - (move-lose)) - (dotimes (i sc-number-limit) - (let ((i-sc (svref *backend-sc-numbers* i))) - (when (eq (svref load-scs i) t) - (cond ((not (sc-allowed-by-primitive-type i-sc ptype)) - (load-lose i-sc)) - ((not (find-move-vop op-tn write-p i-sc ptype - #'sc-move-vops)) - (let ((vops (if write-p - (svref (sc-move-vops op-sc) i) - (svref (sc-move-vops i-sc) op-scn)))) - (if vops - (dolist (vop vops) (move-lose (template-name vop))) - (no-move-scs i-sc)))) - (t - (error "Representation selection flamed out for no ~ - obvious reason.")))))) - - (unless (or (load-lose) (no-move-scs) (move-lose)) - (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 VOP:~ - ~% ~S~%Primitive type: ~S~@ - SC restrictions:~% ~S~@ - ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~ - ~@[No move VOPs are defined to coerce to these allowed SCs:~ - ~% ~S~%~]~ - ~@[These move VOPs couldn't be used due to operand type ~ - restrictions:~% ~S~%~]~ - ~:[~;~@ - Current cost info inconsistent with that in effect at compile ~ - time. Recompile.~%Compilation order may be incorrect.~]" - op-tn pos arg-p - (template-name (vop-info (tn-ref-vop op))) - (primitive-type-name ptype) - (mapcar #'sc-name (listify-restrictions load-scs)) - (mapcar #'sc-name (load-lose)) - (mapcar #'sc-name (no-move-scs)) - (move-lose) - incon))))) + (no-move-scs) + (move-lose)) + (dotimes (i sc-number-limit) + (let ((i-sc (svref *backend-sc-numbers* i))) + (when (eq (svref load-scs i) t) + (cond ((not (sc-allowed-by-primitive-type i-sc ptype)) + (load-lose i-sc)) + ((not (find-move-vop op-tn write-p i-sc ptype + #'sc-move-vops)) + (let ((vops (if write-p + (svref (sc-move-vops op-sc) i) + (svref (sc-move-vops i-sc) op-scn)))) + (if vops + (dolist (vop vops) (move-lose (template-name vop))) + (no-move-scs i-sc)))) + (t + (error "Representation selection flamed out for no ~ + obvious reason.")))))) + + (unless (or (load-lose) (no-move-scs) (move-lose)) + (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 VOP:~ + ~% ~S~%Primitive type: ~S~@ + SC restrictions:~% ~S~@ + ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~ + ~@[No move VOPs are defined to coerce to these allowed SCs:~ + ~% ~S~%~]~ + ~@[These move VOPs couldn't be used due to operand type ~ + restrictions:~% ~S~%~]~ + ~:[~;~@ + Current cost info inconsistent with that in effect at compile ~ + time. Recompile.~%Compilation order may be incorrect.~]" + op-tn pos arg-p + (template-name (vop-info (tn-ref-vop op))) + (primitive-type-name ptype) + (mapcar #'sc-name (listify-restrictions load-scs)) + (mapcar #'sc-name (load-lose)) + (mapcar #'sc-name (no-move-scs)) + (move-lose) + incon))))) (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)))) + (error "no :MOVE-ARG 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 ;;;; @@ -186,26 +186,26 @@ ;;;; load time. ;;; FIXME: should probably be conditional on #!+SB-SHOW -(defun check-move-function-consistency () +(defun check-move-fun-consistency () (dotimes (i sc-number-limit) (let ((sc (svref *backend-sc-numbers* i))) (when sc - (let ((moves (sc-move-functions sc))) - (dolist (const (sc-constant-scs sc)) - (unless (svref moves (sc-number const)) - (warn "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)) - (warn "no move function defined to load SC ~S from alternate ~ - SC ~S" - (sc-name sc) (sc-name alt))) - (unless (svref (sc-move-functions alt) i) - (warn "no move function defined to save SC ~S to alternate ~ - SC ~S" - (sc-name sc) (sc-name alt))))))))) + (let ((moves (sc-move-funs sc))) + (dolist (const (sc-constant-scs sc)) + (unless (svref moves (sc-number const)) + (warn "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)) + (warn "no move function defined to load SC ~S from alternate ~ + SC ~S" + (sc-name sc) (sc-name alt))) + (unless (svref (sc-move-funs alt) i) + (warn "no move function defined to save SC ~S to alternate ~ + SC ~S" + (sc-name sc) (sc-name alt))))))))) ;;;; representation selection @@ -225,46 +225,47 @@ ;;; chosen (e.g. if it is wired), then we use the appropriate move ;;; costs, otherwise we just ignore the references. (defun add-representation-costs (refs scs costs - ops-slot costs-slot more-costs-slot - write-p) + ops-slot costs-slot more-costs-slot + write-p) + (declare (type function ops-slot costs-slot more-costs-slot)) (do ((ref refs (tn-ref-next ref))) ((null ref)) (flet ((add-costs (cost) - (dolist (scn scs) - (let ((res (svref cost scn))) - (unless res - (bad-costs-error ref)) - (incf (svref costs scn) res))))) + (dolist (scn scs) + (let ((res (svref cost scn))) + (unless res + (bad-costs-error ref)) + (incf (svref costs scn) res))))) (let* ((vop (tn-ref-vop ref)) - (info (vop-info vop))) - (unless (find (vop-info-name info) *ignore-cost-vops*) - (case (vop-info-name info) - (move - (let ((rep (tn-sc - (tn-ref-tn - (if write-p - (vop-args vop) - (vop-results vop)))))) - (when rep - (if write-p - (dolist (scn scs) - (let ((res (svref (sc-move-costs - (svref *backend-sc-numbers* scn)) - (sc-number rep)))) - (when res - (incf (svref costs scn) res)))) - (dolist (scn scs) - (let ((res (svref (sc-move-costs rep) scn))) - (when res - (incf (svref costs scn) res)))))))) - (t - (do ((cost (funcall costs-slot info) (cdr cost)) - (op (funcall ops-slot vop) (tn-ref-across op))) - ((null cost) - (add-costs (funcall more-costs-slot info))) - (when (eq op ref) - (add-costs (car cost)) - (return))))))))) + (info (vop-info vop))) + (unless (find (vop-info-name info) *ignore-cost-vops*) + (case (vop-info-name info) + (move + (let ((rep (tn-sc + (tn-ref-tn + (if write-p + (vop-args vop) + (vop-results vop)))))) + (when rep + (if write-p + (dolist (scn scs) + (let ((res (svref (sc-move-costs + (svref *backend-sc-numbers* scn)) + (sc-number rep)))) + (when res + (incf (svref costs scn) res)))) + (dolist (scn scs) + (let ((res (svref (sc-move-costs rep) scn))) + (when res + (incf (svref costs scn) res)))))))) + (t + (do ((cost (funcall costs-slot info) (cdr cost)) + (op (funcall ops-slot vop) (tn-ref-across op))) + ((null cost) + (add-costs (funcall more-costs-slot info))) + (when (eq op ref) + (add-costs (car cost)) + (return))))))))) (values)) ;;; Return the best representation for a normal TN. SCs is a list @@ -277,30 +278,30 @@ ;;; is often not the case for the MOVE VOP. (defun select-tn-representation (tn scs costs) (declare (type tn tn) (type sc-vector costs) - (inline add-representation-costs)) + (inline add-representation-costs)) (dolist (scn scs) (setf (svref costs scn) 0)) (add-representation-costs (tn-reads tn) scs costs - #'vop-args #'vop-info-arg-costs - #'vop-info-more-arg-costs - nil) + #'vop-args #'vop-info-arg-costs + #'vop-info-more-arg-costs + nil) (add-representation-costs (tn-writes tn) scs costs - #'vop-results #'vop-info-result-costs - #'vop-info-more-result-costs - t) + #'vop-results #'vop-info-result-costs + #'vop-info-more-result-costs + t) (let ((min most-positive-fixnum) - (min-scn nil) - (unique nil)) + (min-scn nil) + (unique nil)) (dolist (scn scs) (let ((cost (svref costs scn))) - (cond ((= cost min) - (setf unique nil)) - ((< cost min) - (setq min cost) - (setq min-scn scn) - (setq unique t))))) + (cond ((= cost min) + (setf unique nil)) + ((< cost min) + (setq min cost) + (setq min-scn scn) + (setq unique t))))) (values (svref *backend-sc-numbers* min-scn) unique))) ;;; Prepare for the possibility of a TN being allocated on the number @@ -313,18 +314,18 @@ (do ((ref refs (tn-ref-next ref))) ((null ref)) (let* ((lambda (block-home-lambda - (ir2-block-block - (vop-block (tn-ref-vop ref))))) - (tails (lambda-tail-set lambda))) + (ir2-block-block + (vop-block (tn-ref-vop ref))))) + (tails (lambda-tail-set lambda))) (flet ((frob (fun) - (setf (ir2-physenv-number-stack-p - (physenv-info - (lambda-physenv fun))) - t))) - (frob lambda) - (when tails - (dolist (fun (tail-set-funs tails)) - (frob fun)))))) + (setf (ir2-physenv-number-stack-p + (physenv-info + (lambda-physenv fun))) + t))) + (frob lambda) + (when tails + (dolist (fun (tail-set-funs tails)) + (frob fun)))))) (values)) @@ -334,55 +335,55 @@ (defun get-operand-name (tn arg-p) (declare (type tn tn)) (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn)) - (reads (tn-reads tn)) - (leaf (tn-leaf actual))) + (reads (tn-reads tn)) + (leaf (tn-leaf actual))) (cond ((lambda-var-p leaf) (leaf-source-name leaf)) - ((and (not arg-p) reads - (return-p (vop-node (tn-ref-vop reads)))) - "") - (t - nil)))) + ((and (not arg-p) reads + (return-p (vop-node (tn-ref-vop reads)))) + "") + (t + nil)))) ;;; If policy indicates, give an efficiency note for doing the ;;; coercion VOP, where OP is the operand we are coercing for and ;;; DEST-TN is the distinct destination in a move. -(defun do-coerce-efficiency-note (vop op dest-tn) +(defun maybe-emit-coerce-efficiency-note (vop op dest-tn) (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn)) (let* ((note (or (template-note vop) (template-name vop))) - (cost (template-cost vop)) - (op-vop (tn-ref-vop op)) - (op-node (vop-node op-vop)) - (op-tn (tn-ref-tn op)) - (*compiler-error-context* op-node)) + (cost (template-cost vop)) + (op-vop (tn-ref-vop op)) + (op-node (vop-node op-vop)) + (op-tn (tn-ref-tn op)) + (*compiler-error-context* op-node)) (cond ((eq (tn-kind op-tn) :constant)) - ((policy op-node (and (<= speed inhibit-warnings) - (<= space inhibit-warnings)))) - ((member (template-name (vop-info op-vop)) *suppress-note-vops*)) - ((null dest-tn) - (let* ((op-info (vop-info op-vop)) - (op-note (or (template-note op-info) - (template-name op-info))) - (arg-p (not (tn-ref-write-p op))) - (name (get-operand-name op-tn arg-p)) - (pos (1+ (or (position-in #'tn-ref-across op - (if arg-p - (vop-args op-vop) - (vop-results op-vop))) - (error "couldn't find op? bug!"))))) - (compiler-note - "doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~ - the ~:R ~:[result~;argument~] of ~A" - note cost name arg-p name - pos arg-p op-note))) - (t - (compiler-note "doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]" - note cost (get-operand-name op-tn t) - (get-operand-name dest-tn nil))))) + ((policy op-node (and (<= speed inhibit-warnings) + (<= space inhibit-warnings)))) + ((member (template-name (vop-info op-vop)) *suppress-note-vops*)) + ((null dest-tn) + (let* ((op-info (vop-info op-vop)) + (op-note (or (template-note op-info) + (template-name op-info))) + (arg-p (not (tn-ref-write-p op))) + (name (get-operand-name op-tn arg-p)) + (pos (1+ (or (position-in #'tn-ref-across op + (if arg-p + (vop-args op-vop) + (vop-results op-vop))) + (error "couldn't find op? bug!"))))) + (compiler-notify + "doing ~A (cost ~W)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~ + the ~:R ~:[result~;argument~] of ~A" + note cost name arg-p name + pos arg-p op-note))) + (t + (compiler-notify "doing ~A (cost ~W)~@[ from ~S~]~@[ to ~S~]" + note cost (get-operand-name op-tn t) + (get-operand-name dest-tn nil))))) (values)) ;;; Find a move VOP to move from the operand OP-TN to some other ;;; representation corresponding to OTHER-SC and OTHER-PTYPE. SLOT is -;;; the SC slot that we grab from (move or move-argument). WRITE-P +;;; the SC slot that we grab from (move or move-arg). WRITE-P ;;; indicates that OP is a VOP result, so OP is the move result and ;;; other is the arg, otherwise OP is the arg and other is the result. ;;; @@ -393,30 +394,30 @@ ;;; operand has the type info. (defun find-move-vop (op-tn write-p other-sc other-ptype slot) (declare (type tn op-tn) (type sc other-sc) - (type primitive-type other-ptype) - (type function slot)) + (type primitive-type other-ptype) + (type function slot)) (let* ((op-sc (tn-sc op-tn)) - (op-scn (sc-number op-sc)) - (other-scn (sc-number other-sc)) - (any-ptype *backend-t-primitive-type*) - (op-ptype (tn-primitive-type op-tn))) + (op-scn (sc-number op-sc)) + (other-scn (sc-number other-sc)) + (any-ptype *backend-t-primitive-type*) + (op-ptype (tn-primitive-type op-tn))) (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype)) - (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype))) + (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype))) (dolist (info (if write-p - (svref (funcall slot op-sc) other-scn) - (svref (funcall slot other-sc) op-scn)) - nil) - (when (and (operand-restriction-ok - (first (template-arg-types info)) - (if write-p other-ptype op-ptype) - :tn op-tn :t-ok nil) - (operand-restriction-ok - (first (template-result-types info)) - (if write-p op-ptype other-ptype) - :t-ok nil)) - (return info)))))) - -;;; Emit a coercion VOP for OP BEFORE the specifed VOP or die trying. + (svref (funcall slot op-sc) other-scn) + (svref (funcall slot other-sc) op-scn)) + nil) + (when (and (operand-restriction-ok + (first (template-arg-types info)) + (if write-p other-ptype op-ptype) + :tn op-tn :t-ok nil) + (operand-restriction-ok + (first (template-result-types info)) + (if write-p op-ptype other-ptype) + :t-ok nil)) + (return info)))))) + +;;; Emit a coercion VOP for OP BEFORE the specified VOP 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 @@ -439,46 +440,46 @@ ;;; move; we just change to the right kind of TN. (defun emit-coerce-vop (op dest-tn scs before) (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before) - (type (or tn null) dest-tn)) + (type (or tn null) dest-tn)) (let* ((op-tn (tn-ref-tn op)) - (ptype (tn-primitive-type op-tn)) - (write-p (tn-ref-write-p op)) - (vop (tn-ref-vop op)) - (node (vop-node vop)) - (block (vop-block vop))) + (ptype (tn-primitive-type op-tn)) + (write-p (tn-ref-write-p op)) + (vop (tn-ref-vop op)) + (node (vop-node vop)) + (block (vop-block vop))) (flet ((check-sc (scn sc) - (when (sc-allowed-by-primitive-type sc ptype) - (let ((res (find-move-vop op-tn write-p sc ptype - #'sc-move-vops))) - (when res - (when (>= (vop-info-cost res) - *efficiency-note-cost-threshold*) - (do-coerce-efficiency-note res op dest-tn)) - (let ((temp (make-representation-tn ptype scn))) - (change-tn-ref-tn op temp) - (cond - ((not write-p) - (emit-move-template node block res op-tn temp before)) - ((and (null (tn-reads op-tn)) - (eq (tn-kind op-tn) :normal))) - (t - (emit-move-template node block res temp op-tn - before)))) - t))))) + (when (sc-allowed-by-primitive-type sc ptype) + (let ((res (find-move-vop op-tn write-p sc ptype + #'sc-move-vops))) + (when res + (when (>= (vop-info-cost res) + *efficiency-note-cost-threshold*) + (maybe-emit-coerce-efficiency-note res op dest-tn)) + (let ((temp (make-representation-tn ptype scn))) + (change-tn-ref-tn op temp) + (cond + ((not write-p) + (emit-move-template node block res op-tn temp before)) + ((and (null (tn-reads op-tn)) + (eq (tn-kind op-tn) :normal))) + (t + (emit-move-template node block res temp op-tn + before)))) + t))))) ;; Search the non-stack load SCs first. (dotimes (scn sc-number-limit) - (let ((sc (svref *backend-sc-numbers* scn))) - (when (and (eq (svref scs scn) t) - (not (eq (sb-kind (sc-sb sc)) :unbounded)) - (check-sc scn sc)) - (return-from emit-coerce-vop)))) + (let ((sc (svref *backend-sc-numbers* scn))) + (when (and (eq (svref scs scn) t) + (not (eq (sb-kind (sc-sb sc)) :unbounded)) + (check-sc scn sc)) + (return-from emit-coerce-vop)))) ;; Search the stack SCs if the above failed. (dotimes (scn sc-number-limit (bad-coerce-error op)) - (let ((sc (svref *backend-sc-numbers* scn))) - (when (and (eq (svref scs scn) t) - (eq (sb-kind (sc-sb sc)) :unbounded) - (check-sc scn sc)) - (return))))))) + (let ((sc (svref *backend-sc-numbers* scn))) + (when (and (eq (svref scs scn) t) + (eq (sb-kind (sc-sb sc)) :unbounded) + (check-sc scn sc)) + (return))))))) ;;; Scan some operands and call EMIT-COERCE-VOP on any for which we ;;; can't load the operand. The coerce VOP is inserted Before the @@ -488,12 +489,12 @@ #!-sb-fluid (declaim (inline coerce-some-operands)) (defun coerce-some-operands (ops dest-tn load-scs before) (declare (type (or tn-ref null) ops) (list load-scs) - (type (or tn null) dest-tn) (type (or vop null) before)) + (type (or tn null) dest-tn) (type (or vop null) before)) (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)))) + (sc-number (tn-sc (tn-ref-tn op)))) (emit-coerce-vop op dest-tn (car scs) before))) (values)) @@ -503,7 +504,7 @@ (let ((info (vop-info vop))) (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop) (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info) - (vop-next vop))) + (vop-next vop))) (values)) ;;; Iterate over the more operands to a call VOP, emitting move-arg @@ -514,62 +515,62 @@ ;;; passing locations are written between A-F and call.) (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))) - (prev (vop-prev 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))) + (prev (vop-prev 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) - (aver (null pass))) + (req (template-arg-types info) (cdr req))) + ((null req) arg)) + (tn-ref-across val)) + (pass pass-locs (cdr pass))) + ((null val) + (aver (null pass))) (let* ((val-tn (tn-ref-tn val)) - (pass-tn (first pass)) - (pass-sc (tn-sc pass-tn)) - (res (find-move-vop val-tn nil pass-sc - (tn-primitive-type pass-tn) - #'sc-move-arg-vops))) - (unless res - (bad-move-arg-error val-tn pass-tn)) - - (change-tn-ref-tn val pass-tn) - (let* ((this-fp - (cond ((not (sc-number-stack-p pass-sc)) fp-tn) - (nfp-tn) - (t - (aver (eq how :known-return)) - (setq nfp-tn (make-number-stack-pointer-tn)) - (setf (tn-sc nfp-tn) - (svref *backend-sc-numbers* - (first (primitive-type-scs - (tn-primitive-type nfp-tn))))) - (emit-context-template - node block - (template-or-lose 'compute-old-nfp) - nfp-tn vop) - (aver (not (sc-number-stack-p (tn-sc nfp-tn)))) - nfp-tn))) - (new (emit-move-arg-template node block res val-tn this-fp - pass-tn vop)) - (after - (cond ((eq how :local-call) - (aver (eq (vop-info-name (vop-info prev)) - 'allocate-frame)) - prev) - (prev (vop-next prev)) - (t - (ir2-block-start-vop block))))) - (coerce-some-operands (vop-args new) pass-tn - (vop-info-arg-load-scs res) - after))))) + (pass-tn (first pass)) + (pass-sc (tn-sc pass-tn)) + (res (find-move-vop val-tn nil pass-sc + (tn-primitive-type pass-tn) + #'sc-move-arg-vops))) + (unless res + (bad-move-arg-error val-tn pass-tn)) + + (change-tn-ref-tn val pass-tn) + (let* ((this-fp + (cond ((not (sc-number-stack-p pass-sc)) fp-tn) + (nfp-tn) + (t + (aver (eq how :known-return)) + (setq nfp-tn (make-number-stack-pointer-tn)) + (setf (tn-sc nfp-tn) + (svref *backend-sc-numbers* + (first (primitive-type-scs + (tn-primitive-type nfp-tn))))) + (emit-context-template + node block + (template-or-lose 'compute-old-nfp) + nfp-tn vop) + (aver (not (sc-number-stack-p (tn-sc nfp-tn)))) + nfp-tn))) + (new (emit-move-arg-template node block res val-tn this-fp + pass-tn vop)) + (after + (cond ((eq how :local-call) + (aver (eq (vop-info-name (vop-info prev)) + 'allocate-frame)) + prev) + (prev (vop-next prev)) + (t + (ir2-block-start-vop block))))) + (coerce-some-operands (vop-args new) pass-tn + (vop-info-arg-load-scs res) + after))))) (values)) ;;; Scan the IR2 looking for move operations that need to be replaced @@ -580,34 +581,34 @@ (defun emit-moves-and-coercions (block) (declare (type ir2-block block)) (do ((vop (ir2-block-start-vop block) - (vop-next vop))) + (vop-next vop))) ((null vop)) (let ((info (vop-info vop)) - (node (vop-node vop)) - (block (vop-block vop))) + (node (vop-node vop)) + (block (vop-block vop))) (cond ((eq (vop-info-name info) 'move) - (let* ((args (vop-args vop)) - (x (tn-ref-tn args)) - (y (tn-ref-tn (vop-results vop))) - (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y) - #'sc-move-vops))) - (cond ((and (null (tn-reads y)) - (eq (tn-kind y) :normal)) - (delete-vop vop)) - ((eq res info)) - (res - (when (>= (vop-info-cost res) - *efficiency-note-cost-threshold*) - (do-coerce-efficiency-note res args y)) - (emit-move-template node block res x y vop) - (delete-vop vop)) - (t - (coerce-vop-operands vop))))) + (let* ((args (vop-args vop)) + (x (tn-ref-tn args)) + (y (tn-ref-tn (vop-results vop))) + (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y) + #'sc-move-vops))) + (cond ((and (null (tn-reads y)) + (eq (tn-kind y) :normal)) + (delete-vop vop)) + ((eq res info)) + (res + (when (>= (vop-info-cost res) + *efficiency-note-cost-threshold*) + (maybe-emit-coerce-efficiency-note res args y)) + (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)) + (emit-arg-moves vop)) (t - (coerce-vop-operands vop)))))) + (coerce-vop-operands vop)))))) ;;; If TN is in a number stack SC, make all the right annotations. ;;; Note that this should be called after TN has been referenced, @@ -616,8 +617,8 @@ (defun note-if-number-stack (tn 2comp restricted) (declare (type tn tn) (type ir2-component 2comp)) (when (if restricted - (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack) - (sc-number-stack-p (tn-sc tn))) + (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack) + (sc-number-stack-p (tn-sc tn))) (unless (ir2-component-nfp 2comp) (setf (ir2-component-nfp 2comp) (make-nfp-tn))) (note-number-stack-tn (tn-reads tn)) @@ -635,48 +636,48 @@ ;;; environments may be introduced by MOVE-ARG insertion. (defun select-representations (component) (let ((costs (make-array sc-number-limit)) - (2comp (component-info component))) + (2comp (component-info component))) ;; First pass; only allocate SCs where there is a distinct choice. (do ((tn (ir2-component-normal-tns 2comp) - (tn-next tn))) - ((null tn)) + (tn-next tn))) + ((null tn)) (aver (tn-primitive-type tn)) (unless (tn-sc tn) - (let* ((scs (primitive-type-scs (tn-primitive-type tn)))) - (cond ((rest scs) - (multiple-value-bind (sc unique) - (select-tn-representation tn scs costs) - (when unique - (setf (tn-sc tn) sc)))) - (t - (setf (tn-sc tn) - (svref *backend-sc-numbers* (first scs)))))))) + (let* ((scs (primitive-type-scs (tn-primitive-type tn)))) + (cond ((rest scs) + (multiple-value-bind (sc unique) + (select-tn-representation tn scs costs) + (when unique + (setf (tn-sc tn) sc)))) + (t + (setf (tn-sc tn) + (svref *backend-sc-numbers* (first scs)))))))) (do ((tn (ir2-component-normal-tns 2comp) - (tn-next tn))) - ((null tn)) + (tn-next tn))) + ((null tn)) (aver (tn-primitive-type tn)) (unless (tn-sc tn) - (let* ((scs (primitive-type-scs (tn-primitive-type tn))) - (sc (if (rest scs) - (select-tn-representation tn scs costs) - (svref *backend-sc-numbers* (first scs))))) - (aver sc) - (setf (tn-sc tn) sc)))) + (let* ((scs (primitive-type-scs (tn-primitive-type tn))) + (sc (if (rest scs) + (select-tn-representation tn scs costs) + (svref *backend-sc-numbers* (first scs))))) + (aver sc) + (setf (tn-sc tn) sc)))) (do ((alias (ir2-component-alias-tns 2comp) - (tn-next alias))) - ((null alias)) + (tn-next alias))) + ((null alias)) (setf (tn-sc alias) (tn-sc (tn-save-tn alias)))) (do-ir2-blocks (block component) (emit-moves-and-coercions block)) (macrolet ((frob (slot restricted) - `(do ((tn (,slot 2comp) (tn-next tn))) - ((null tn)) - (note-if-number-stack tn 2comp ,restricted)))) + `(do ((tn (,slot 2comp) (tn-next tn))) + ((null tn)) + (note-if-number-stack tn 2comp ,restricted)))) (frob ir2-component-normal-tns nil) (frob ir2-component-wired-tns t) (frob ir2-component-restricted-tns t)))