X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=d796e127457a788ac0ae7321f2d77ecc97a705b0;hb=16a6592367eec7c5e9da668ec42fd260e7705b0c;hp=afa0fb692fdef8b0a768ee703ac50d4c52014e56;hpb=8902b8b6bd2e9285749dd39d313b33b6c69c5213;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index afa0fb6..d796e12 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -59,7 +59,7 @@ ;;;; leaf reference ;;; Return the TN that holds the value of THING in the environment ENV. -(declaim (ftype (function ((or nlx-info lambda-var) physenv) tn) +(declaim (ftype (function ((or nlx-info lambda-var clambda) physenv) tn) find-in-physenv)) (defun find-in-physenv (thing physenv) (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) @@ -81,7 +81,10 @@ (leaf-info thing)) (nlx-info (aver (eq physenv (block-physenv (nlx-info-target thing)))) - (ir2-nlx-info-home (nlx-info-info thing)))) + (ir2-nlx-info-home (nlx-info-info thing))) + (clambda + (aver (xep-p thing)) + (entry-info-closure-tn (lambda-info thing)))) (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing physenv))) ;;; If LEAF already has a constant TN, return that, otherwise make a @@ -210,8 +213,7 @@ (unless (leaf-info functional) (setf (leaf-info functional) (make-entry-info :name (functional-debug-name functional)))) - (let ((entry (make-load-time-constant-tn :entry functional)) - (closure (etypecase functional + (let ((closure (etypecase functional (clambda (assertions-on-ir2-converted-clambda functional) (physenv-closure (get-lambda-physenv functional))) @@ -220,17 +222,59 @@ nil)))) (cond (closure - (let ((this-env (node-physenv ref))) - (vop make-closure ref ir2-block entry (length closure) res) - (loop for what in closure and n from 0 do - (unless (and (lambda-var-p what) - (null (leaf-refs what))) - (vop closure-init ref ir2-block - res - (find-in-physenv what this-env) - n))))) + (let* ((physenv (node-physenv ref)) + (tn (find-in-physenv functional physenv))) + (emit-move ref ir2-block tn res))) (t - (emit-move ref ir2-block entry res)))) + (let ((entry (make-load-time-constant-tn :entry functional))) + (emit-move ref ir2-block entry res))))) + (values)) + +(defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy) + ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) + (when (lvar-dynamic-extent leaves) + (let ((info (make-ir2-lvar *backend-t-primitive-type*))) + (setf (ir2-lvar-kind info) :delayed) + (setf (lvar-info leaves) info) + (setf (ir2-lvar-stack-pointer info) + (make-stack-pointer-tn))))) + +(defoptimizer (%allocate-closures ir2-convert) ((leaves) call 2block) + (let ((dx-p (lvar-dynamic-extent leaves))) + (collect ((delayed)) + (when dx-p + (vop current-stack-pointer call 2block + (ir2-lvar-stack-pointer (lvar-info leaves)))) + (dolist (leaf (lvar-value leaves)) + (binding* ((xep (functional-entry-fun leaf) :exit-if-null) + (nil (aver (xep-p xep))) + (entry-info (lambda-info xep) :exit-if-null) + (tn (entry-info-closure-tn entry-info) :exit-if-null) + (closure (physenv-closure (get-lambda-physenv xep))) + (entry (make-load-time-constant-tn :entry xep))) + (let ((this-env (node-physenv call)) + (leaf-dx-p (and dx-p (leaf-dynamic-extent leaf)))) + (vop make-closure call 2block entry (length closure) + leaf-dx-p tn) + (loop for what in closure and n from 0 do + (unless (and (lambda-var-p what) + (null (leaf-refs what))) + ;; In LABELS a closure may refer to another closure + ;; in the same group, so we must be sure that we + ;; store a closure only after its creation. + ;; + ;; TODO: Here is a simple solution: we postpone + ;; putting of all closures after all creations + ;; (though it may require more registers). + (if (lambda-p what) + (delayed (list tn (find-in-physenv what this-env) n)) + (vop closure-init call 2block + tn + (find-in-physenv what this-env) + n))))))) + (loop for (tn what n) in (delayed) + do (vop closure-init call 2block + tn what n)))) (values)) ;;; Convert a SET node. If the NODE's LVAR is annotated, then we also @@ -623,7 +667,6 @@ (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) - #!+stack-grows-downward-not-upward (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer call block (ir2-lvar-stack-pointer (lvar-info lvar)))) @@ -1287,16 +1330,11 @@ (vop reset-stack-pointer node block (first (ir2-lvar-locs 2lvar)))) ((lvar-dynamic-extent lvar) - #!+stack-grows-downward-not-upward (vop reset-stack-pointer node block - (ir2-lvar-stack-pointer 2lvar)) - #!-stack-grows-downward-not-upward - (vop %%pop-dx node block - (first (ir2-lvar-locs 2lvar)))) + (ir2-lvar-stack-pointer 2lvar))) (t (bug "Trying to pop a not stack-allocated LVAR ~S." lvar))))) -(locally (declare (optimize (debug 3))) (defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved &rest moved) node block) @@ -1325,23 +1363,13 @@ (nipped (first (ir2-lvar-locs 2first)) (reference-tn-list moved-tns nil)) - ((reference-tn-list moved-tns t)))) - #!-stack-grows-downward-not-upward - (nip-unaligned (nipped) - (vop* %%nip-dx node block - (nipped - (first (ir2-lvar-locs 2first)) - (reference-tn-list moved-tns nil)) ((reference-tn-list moved-tns t))))) (cond ((eq (ir2-lvar-kind 2after) :unknown) (nip-aligned (first (ir2-lvar-locs 2after)))) ((lvar-dynamic-extent after) - #!+stack-grows-downward-not-upward - (nip-aligned (ir2-lvar-stack-pointer 2after)) - #!-stack-grows-downward-not-upward - (nip-unaligned (ir2-lvar-stack-pointer 2after))) + (nip-aligned (ir2-lvar-stack-pointer 2after))) (t - (bug "Trying to nip a not stack-allocated LVAR ~S." after))))))) + (bug "Trying to nip a not stack-allocated LVAR ~S." after)))))) ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) @@ -1432,11 +1460,13 @@ ;;; IR2 converted. (defun ir2-convert-exit (node block) (declare (type exit node) (type ir2-block block)) - (let ((loc (find-in-physenv (find-nlx-info node) - (node-physenv node))) - (temp (make-stack-pointer-tn)) - (value (exit-value node))) - (vop value-cell-ref node block loc temp) + (let* ((nlx (exit-nlx-info node)) + (loc (find-in-physenv nlx (node-physenv node))) + (temp (make-stack-pointer-tn)) + (value (exit-value node))) + (if (nlx-info-safe-p nlx) + (vop value-cell-ref node block loc temp) + (emit-move node block loc temp)) (if value (let ((locs (ir2-lvar-locs (lvar-info value)))) (vop unwind node block temp (first locs) (second locs))) @@ -1453,9 +1483,11 @@ ;;; dynamic extent. This is done by storing 0 into the indirect value ;;; cell that holds the closed unwind block. (defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block) - (vop value-cell-set node block - (find-in-physenv (lvar-value info) (node-physenv node)) - (emit-constant 0))) + (let ((nlx (lvar-value info))) + (when (nlx-info-safe-p nlx) + (vop value-cell-set node block + (find-in-physenv nlx (node-physenv node)) + (emit-constant 0))))) ;;; We have to do a spurious move of no values to the result lvar so ;;; that lifetime analysis won't get confused. @@ -1503,7 +1535,9 @@ (ecase kind ((:block :tagbody) - (do-make-value-cell node block res (ir2-nlx-info-home 2info))) + (if (nlx-info-safe-p info) + (do-make-value-cell node block res (ir2-nlx-info-home 2info)) + (emit-move node block res (ir2-nlx-info-home 2info)))) (:unwind-protect (vop set-unwind-protect node block block-tn)) (:catch))) @@ -1513,12 +1547,15 @@ ;;; Scan each of ENTRY's exits, setting up the exit for each lexical exit. (defun ir2-convert-entry (node block) (declare (type entry node) (type ir2-block block)) - (dolist (exit (entry-exits node)) - (let ((info (find-nlx-info exit))) - (when (and info - (member (cleanup-kind (nlx-info-cleanup info)) - '(:block :tagbody))) - (emit-nlx-start node block info nil)))) + (let ((nlxes '())) + (dolist (exit (entry-exits node)) + (let ((info (exit-nlx-info exit))) + (when (and info + (not (memq info nlxes)) + (member (cleanup-kind (nlx-info-cleanup info)) + '(:block :tagbody))) + (push info nlxes) + (emit-nlx-start node block info nil))))) (values)) ;;; Set up the unwind block for these guys. @@ -1549,7 +1586,7 @@ ;;; pointer alone, since the thrown values are still out there. (defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block) (let* ((info (lvar-value info-lvar)) - (lvar (nlx-info-lvar info)) + (lvar (node-lvar node)) (2info (nlx-info-info info)) (top-loc (ir2-nlx-info-save-sp 2info)) (start-loc (make-nlx-entry-arg-start-location)) @@ -1599,7 +1636,6 @@ (res (lvar-result-tns lvar (list (primitive-type (specifier-type 'list)))))) - #!+stack-grows-downward-not-upward (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer node block (ir2-lvar-stack-pointer (lvar-info lvar))))