X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir2tran.lisp;h=8157cd81595c9618ce875125bbdd0c059b60549c;hb=883b33b092472473b0dd559d64351b9436916af3;hp=bb3a23ff8c9e3bf2493302e0be95f5e173909d3d;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index bb3a23f..8157cd8 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,23 +222,79 @@ 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)) -;;; Convert a SET node. If the NODE's CONT is annotated, then we also -;;; deliver the value to that continuation. If the var is a lexical -;;; variable with no refs, then we don't actually set anything, since -;;; the variable has been deleted. +(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) + #!+stack-grows-upward-not-downward + (let ((tn (make-normal-tn *backend-t-primitive-type*))) + (setf (ir2-lvar-locs info) (list tn))) + #!+stack-grows-downward-not-upward + (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)) + #!+stack-grows-upward-not-downward + (first-closure nil)) + (collect ((delayed)) + #!+stack-grows-downward-not-upward + (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) + #!+stack-grows-upward-not-downward + (when (and (not first-closure) leaf-dx-p) + (setq first-closure 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))))))) + #!+stack-grows-upward-not-downward + (when dx-p + (emit-move call 2block first-closure + (first (ir2-lvar-locs (lvar-info leaves))))) + (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 +;;; deliver the value to that lvar. If the var is a lexical variable +;;; with no refs, then we don't actually set anything, since the +;;; variable has been deleted. (defun ir2-convert-set (node block) (declare (type cset node) (type ir2-block block)) (let* ((lvar (node-lvar node)) @@ -265,17 +323,17 @@ ;;;; utilities for receiving fixed values -;;; Return a TN that can be referenced to get the value of CONT. CONT +;;; Return a TN that can be referenced to get the value of LVAR. LVAR ;;; must be LTN-ANNOTATED either as a delayed leaf ref or as a fixed, -;;; single-value continuation. If a type check is called for, do it. +;;; single-value lvar. ;;; ;;; The primitive-type of the result will always be the same as the -;;; IR2-CONTINUATION-PRIMITIVE-TYPE, ensuring that VOPs are always -;;; called with TNs that satisfy the operand primitive-type -;;; restriction. We may have to make a temporary of the desired type -;;; and move the actual continuation TN into it. This happens when we -;;; delete a type check in unsafe code or when we locally know -;;; something about the type of an argument variable. +;;; IR2-LVAR-PRIMITIVE-TYPE, ensuring that VOPs are always called with +;;; TNs that satisfy the operand primitive-type restriction. We may +;;; have to make a temporary of the desired type and move the actual +;;; lvar TN into it. This happens when we delete a type check in +;;; unsafe code or when we locally know something about the type of an +;;; argument variable. (defun lvar-tn (node block lvar) (declare (type node node) (type ir2-block block) (type lvar lvar)) (let* ((2lvar (lvar-info lvar)) @@ -295,13 +353,13 @@ (emit-move node block lvar-tn temp) temp))))) -;;; This is similar to CONTINUATION-TN, but hacks multiple values. We -;;; return continuations holding the values of CONT with PTYPES as -;;; their primitive types. CONT must be annotated for the same number -;;; of fixed values are there are PTYPES. +;;; This is similar to LVAR-TN, but hacks multiple values. We return +;;; TNs holding the values of LVAR with PTYPES as their primitive +;;; types. LVAR must be annotated for the same number of fixed values +;;; are there are PTYPES. ;;; -;;; If the continuation has a type check, check the values into temps -;;; and return the temps. When we have more values than assertions, we +;;; If the lvar has a type check, check the values into temps and +;;; return the temps. When we have more values than assertions, we ;;; move the extra values with no check. (defun lvar-tns (node block lvar ptypes) (declare (type node node) (type ir2-block block) @@ -319,24 +377,23 @@ locs ptypes))) -;;;; utilities for delivering values to continuations +;;;; utilities for delivering values to lvars ;;; Return a list of TNs with the specifier TYPES that can be used as -;;; result TNs to evaluate an expression into the continuation CONT. -;;; This is used together with MOVE-CONTINUATION-RESULT to deliver -;;; fixed values to a continuation. +;;; result TNs to evaluate an expression into LVAR. This is used +;;; together with MOVE-LVAR-RESULT to deliver fixed values to +;;; an lvar. ;;; -;;; If the continuation isn't annotated (meaning the values are -;;; discarded) or is unknown-values, the then we make temporaries for -;;; each supplied value, providing a place to compute the result in -;;; until we decide what to do with it (if anything.) +;;; If the lvar isn't annotated (meaning the values are discarded) or +;;; is unknown-values, the then we make temporaries for each supplied +;;; value, providing a place to compute the result in until we decide +;;; what to do with it (if anything.) ;;; -;;; If the continuation is fixed-values, and wants the same number of -;;; values as the user wants to deliver, then we just return the -;;; IR2-CONTINUATION-LOCS. Otherwise we make a new list padded as -;;; necessary by discarded TNs. We always return a TN of the specified -;;; type, using the continuation locs only when they are of the -;;; correct type. +;;; If the lvar is fixed-values, and wants the same number of values +;;; as the user wants to deliver, then we just return the +;;; IR2-LVAR-LOCS. Otherwise we make a new list padded as necessary by +;;; discarded TNs. We always return a TN of the specified type, using +;;; the lvar locs only when they are of the correct type. (defun lvar-result-tns (lvar types) (declare (type (or lvar null) lvar) (type list types)) (if (not lvar) @@ -378,13 +435,13 @@ ;;; Return a list of TNs wired to the standard value passing ;;; conventions that can be used to receive values according to the ;;; unknown-values convention. This is used with together -;;; MOVE-CONTINUATION-RESULT for delivering unknown values to a fixed -;;; values continuation. +;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values +;;; lvar. ;;; -;;; If the continuation isn't annotated, then we treat as 0-values, -;;; returning an empty list of temporaries. +;;; If the lvar isn't annotated, then we treat as 0-values, returning +;;; an empty list of temporaries. ;;; -;;; If the continuation is annotated, then it must be :FIXED. +;;; If the lvar is annotated, then it must be :FIXED. (defun standard-result-tns (lvar) (declare (type (or lvar null) lvar)) (if lvar @@ -433,15 +490,15 @@ (values)) ;;; If necessary, emit coercion code needed to deliver the RESULTS to -;;; the specified continuation. NODE and BLOCK provide context for -;;; emitting code. Although usually obtained from STANDARD-RESULT-TNs -;;; or CONTINUATION-RESULT-TNs, RESULTS my be a list of any type or +;;; the specified lvar. NODE and BLOCK provide context for emitting +;;; code. Although usually obtained from STANDARD-RESULT-TNs or +;;; LVAR-RESULT-TNs, RESULTS my be a list of any type or ;;; number of TNs. ;;; -;;; If the continuation is fixed values, then move the results into -;;; the continuation locations. If the continuation is unknown values, -;;; then do the moves into the standard value locations, and use -;;; PUSH-VALUES to put the values on the stack. +;;; If the lvar is fixed values, then move the results into the lvar +;;; locations. If the lvar is unknown values, then do the moves into +;;; the standard value locations, and use PUSH-VALUES to put the +;;; values on the stack. (defun move-lvar-result (node block results lvar) (declare (type node node) (type ir2-block block) (list results) (type (or lvar null) lvar)) @@ -495,10 +552,10 @@ ;;;; template conversion ;;; Build a TN-REFS list that represents access to the values of the -;;; specified list of continuations ARGS for TEMPLATE. Any :CONSTANT -;;; arguments are returned in the second value as a list rather than -;;; being accessed as a normal argument. NODE and BLOCK provide the -;;; context for emitting any necessary type-checking code. +;;; specified list of lvars ARGS for TEMPLATE. Any :CONSTANT arguments +;;; are returned in the second value as a list rather than being +;;; accessed as a normal argument. NODE and BLOCK provide the context +;;; for emitting any necessary type-checking code. (defun reference-args (node block args template) (declare (type node node) (type ir2-block block) (list args) (type template template)) @@ -552,7 +609,7 @@ test-ref () node t))) ;;; Return a list of primitive-types that we can pass to -;;; CONTINUATION-RESULT-TNS describing the result types we want for a +;;; LVAR-RESULT-TNS describing the result types we want for a ;;; template call. We duplicate here the determination of output type ;;; that was done in initially selecting the template, so we know that ;;; the types we find are allowed by the template output type @@ -560,6 +617,7 @@ (defun find-template-result-types (call template rtypes) (declare (type combination call) (type template template) (list rtypes)) + (declare (ignore template)) (let* ((dtype (node-derived-type call)) (type dtype) (types (mapcar #'primitive-type @@ -579,10 +637,10 @@ types))))) ;;; Return a list of TNs usable in a CALL to TEMPLATE delivering -;;; values to CONT. As an efficiency hack, we pick off the common case -;;; where the continuation is fixed values and has locations that -;;; satisfy the result restrictions. This can fail when there is a -;;; type check or a values count mismatch. +;;; values to LVAR. As an efficiency hack, we pick off the common case +;;; where the LVAR is fixed values and has locations that satisfy the +;;; result restrictions. This can fail when there is a type check or a +;;; values count mismatch. (defun make-template-result-tns (call lvar template rtypes) (declare (type combination call) (type (or lvar null) lvar) (type template template) (list rtypes)) @@ -623,6 +681,10 @@ (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)))) (if info-args (emit-template call block template args r-refs info-args) (emit-template call block template args r-refs)) @@ -774,7 +836,7 @@ (values fp nfp temps (mapcar #'make-alias-tn locs))))) ;;; Handle a non-TR known-values local call. We emit the call, then -;;; move the results to the continuation's destination. +;;; move the results to the lvar's destination. (defun ir2-convert-local-known-call (node block fun returns lvar start) (declare (type node node) (type ir2-block block) (type clambda fun) (type return-info returns) (type (or lvar null) lvar) @@ -790,15 +852,15 @@ (values)) ;;; Handle a non-TR unknown-values local call. We do different things -;;; depending on what kind of values the continuation wants. +;;; depending on what kind of values the lvar wants. ;;; -;;; If CONT is :UNKNOWN, then we use the "multiple-" variant, directly -;;; specifying the continuation's LOCS as the VOP results so that we -;;; don't have to do anything after the call. +;;; If LVAR is :UNKNOWN, then we use the "multiple-" variant, directly +;;; specifying the lvar's LOCS as the VOP results so that we don't +;;; have to do anything after the call. ;;; ;;; Otherwise, we use STANDARD-RESULT-TNS to get wired result TNs, and -;;; then call MOVE-CONTINUATION-RESULT to do any necessary type checks -;;; or coercions. +;;; then call MOVE-LVAR-RESULT to do any necessary type checks or +;;; coercions. (defun ir2-convert-local-unknown-call (node block fun lvar start) (declare (type node node) (type ir2-block block) (type clambda fun) (type (or lvar null) lvar) (type label start)) @@ -849,15 +911,16 @@ ;;;; full call -;;; Given a function continuation FUN, return (VALUES TN-TO-CALL -;;; NAMED-P), where TN-TO-CALL is a TN holding the thing that we call -;;; NAMED-P is true if the thing is named (false if it is a function). +;;; Given a function lvar FUN, return (VALUES TN-TO-CALL NAMED-P), +;;; where TN-TO-CALL is a TN holding the thing that we call NAMED-P is +;;; true if the thing is named (false if it is a function). ;;; ;;; There are two interesting non-named cases: ;;; -- We know it's a function. No check needed: return the -;;; continuation LOC. +;;; lvar LOC. ;;; -- We don't know what it is. (defun fun-lvar-tn (node block lvar) + (declare (ignore node block)) (declare (type lvar lvar)) (let ((2lvar (lvar-info lvar))) (if (eq (ir2-lvar-kind 2lvar) :delayed) @@ -936,9 +999,8 @@ (values fp first (locs) nargs))))) ;;; Do full call when a fixed number of values are desired. We make -;;; STANDARD-RESULT-TNS for our continuation, then deliver the result -;;; using MOVE-CONTINUATION-RESULT. We do named or normal call, as -;;; appropriate. +;;; STANDARD-RESULT-TNS for our lvar, then deliver the result using +;;; MOVE-LVAR-RESULT. We do named or normal call, as appropriate. (defun ir2-convert-fixed-full-call (node block) (declare (type combination node) (type ir2-block block)) (multiple-value-bind (fp args arg-locs nargs) @@ -1210,16 +1272,16 @@ (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-lvar-result node block - (list (ir2-physenv-old-fp ir2-physenv) - (ir2-physenv-return-pc ir2-physenv)) - (node-lvar node)))) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) + (node-lvar node)))) ;;;; multiple values ;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates -;;; the lvarinuation for the correct number of values (with the -;;; continuation user responsible for defaulting), we can just pick -;;; them up from the continuation. +;;; the lvar for the correct number of values (with the lvar user +;;; responsible for defaulting), we can just pick them up from the +;;; lvar. (defun ir2-convert-mv-bind (node block) (declare (type mv-combination node) (type ir2-block block)) (let* ((lvar (first (basic-combination-args node))) @@ -1241,7 +1303,7 @@ ;;; Emit the appropriate fixed value, unknown value or tail variant of ;;; CALL-VARIABLE. Note that we only need to pass the values start for -;;; the first argument: all the other argument continuation TNs are +;;; the first argument: all the other argument lvar TNs are ;;; ignored. This is because we require all of the values globs to be ;;; contiguous and on stack top. (defun ir2-convert-mv-call (node block) @@ -1274,15 +1336,71 @@ (move-lvar-result node block locs lvar))))))) ;;; Reset the stack pointer to the start of the specified -;;; unknown-values continuation (discarding it and all values globs on -;;; top of it.) -(defoptimizer (%pop-values ir2-convert) ((lvar) node block) - (let ((2lvar (lvar-info (lvar-value lvar)))) - (aver (eq (ir2-lvar-kind 2lvar) :unknown)) - (vop reset-stack-pointer node block - (first (ir2-lvar-locs 2lvar))))) - -;;; Deliver the values TNs to CONT using MOVE-CONTINUATION-RESULT. +;;; unknown-values lvar (discarding it and all values globs on top of +;;; it.) +(defoptimizer (%pop-values ir2-convert) ((%lvar) node block) + (let* ((lvar (lvar-value %lvar)) + (2lvar (lvar-info lvar))) + (cond ((eq (ir2-lvar-kind 2lvar) :unknown) + (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)))) + (t (bug "Trying to pop a not stack-allocated LVAR ~S." + lvar))))) + +(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved + &rest moved) + node block) + (let* ( ;; pointer immediately after the nipped block + (after (lvar-value last-nipped)) + (2after (lvar-info after)) + ;; pointer to the first nipped word + (first (lvar-value last-preserved)) + (2first (lvar-info first)) + + (moved-tns (loop for lvar-ref in moved + for lvar = (lvar-value lvar-ref) + for 2lvar = (lvar-info lvar) + ;when 2lvar + collect (first (ir2-lvar-locs 2lvar))))) + (aver (or (eq (ir2-lvar-kind 2after) :unknown) + (lvar-dynamic-extent after))) + (aver (eq (ir2-lvar-kind 2first) :unknown)) + (when *check-consistency* + ;; we cannot move stack-allocated DX objects + (dolist (moved-lvar moved) + (aver (eq (ir2-lvar-kind (lvar-info (lvar-value moved-lvar))) + :unknown)))) + (flet ((nip-aligned (nipped) + (vop* %%nip-values node block + (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))) + (t + (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) (let ((tns (mapcar (lambda (x) (lvar-tn node block x)) @@ -1343,25 +1461,25 @@ start next result (with-unique-names (bind unbind) (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (labels ((,unbind (vars) - (declare (optimize (speed 2) (debug 0))) - (dolist (var vars) - (%primitive bind nil var) - (makunbound var))) - (,bind (vars vals) - (declare (optimize (speed 2) (debug 0))) - (cond ((null vars)) - ((null vals) (,unbind vars)) - (t (%primitive bind - (car vals) - (car vars)) - (,bind (cdr vars) (cdr vals)))))) - (,bind ,vars ,vals)) - nil - ,@body) - (%primitive unbind-to-here ,n-save-bs)))))) + `(unwind-protect + (progn + (labels ((,unbind (vars) + (declare (optimize (speed 2) (debug 0))) + (dolist (var vars) + (%primitive bind nil var) + (makunbound var))) + (,bind (vars vals) + (declare (optimize (speed 2) (debug 0))) + (cond ((null vars)) + ((null vals) (,unbind vars)) + (t (%primitive bind + (car vals) + (car vars)) + (,bind (cdr vars) (cdr vals)))))) + (,bind ,vars ,vals)) + nil + ,@body) + (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit @@ -1371,7 +1489,7 @@ ;;; 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) + (let ((loc (find-in-physenv (exit-nlx-info node) (node-physenv node))) (temp (make-stack-pointer-tn)) (value (exit-value node))) @@ -1396,8 +1514,8 @@ (find-in-physenv (lvar-value info) (node-physenv node)) (emit-constant 0))) -;;; We have to do a spurious move of no values to the result -;;; continuation so that lifetime analysis won't get confused. +;;; We have to do a spurious move of no values to the result lvar so +;;; that lifetime analysis won't get confused. (defun ir2-convert-throw (node block) (declare (type mv-combination node) (type ir2-block block)) (let ((args (basic-combination-args node))) @@ -1412,9 +1530,9 @@ (values)) ;;; Emit code to set up a non-local exit. INFO is the NLX-INFO for the -;;; exit, and TAG is the continuation for the catch tag (if any.) We -;;; get at the target PC by passing in the label to the vop. The vop -;;; is responsible for building a return-PC object. +;;; exit, and TAG is the lvar for the catch tag (if any.) We get at +;;; the target PC by passing in the label to the vop. The vop is +;;; responsible for building a return-PC object. (defun emit-nlx-start (node block info tag) (declare (type node node) (type ir2-block block) (type nlx-info info) (type (or lvar null) tag)) @@ -1452,12 +1570,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. @@ -1470,18 +1591,17 @@ ;;; Emit the entry code for a non-local exit. We receive values and ;;; restore dynamic state. ;;; -;;; In the case of a lexical exit or CATCH, we look at the exit -;;; continuation's kind to determine which flavor of entry VOP to -;;; emit. If unknown values, emit the xxx-MULTIPLE variant to the -;;; continuation locs. If fixed values, make the appropriate number of -;;; temps in the standard values locations and use the other variant, -;;; delivering the temps to the continuation using -;;; MOVE-CONTINUATION-RESULT. +;;; In the case of a lexical exit or CATCH, we look at the exit lvar's +;;; kind to determine which flavor of entry VOP to emit. If unknown +;;; values, emit the xxx-MULTIPLE variant to the lvar locs. If fixed +;;; values, make the appropriate number of temps in the standard +;;; values locations and use the other variant, delivering the temps +;;; to the lvar using MOVE-LVAR-RESULT. ;;; ;;; In the UNWIND-PROTECT case, we deliver the first register -;;; argument, the argument count and the argument pointer to our -;;; continuation as multiple values. These values are the block exited -;;; to and the values start and count. +;;; argument, the argument count and the argument pointer to our lvar +;;; as multiple values. These values are the block exited to and the +;;; values start and count. ;;; ;;; After receiving values, we restore dynamic state. Except in the ;;; UNWIND-PROTECT case, the values receiving restores the stack @@ -1489,7 +1609,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)) @@ -1539,11 +1659,16 @@ (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)))) (vop* ,name node block (refs) ((first res) nil) (length args)) (move-lvar-result node block res lvar))))) (def list) (def list*)) + ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) @@ -1639,13 +1764,14 @@ (ir2-convert-ref node 2block))))) (combination (let ((kind (basic-combination-kind node))) - (case kind + (ecase kind (:local (ir2-convert-local-call node 2block)) (:full (ir2-convert-full-call node 2block)) - (t - (let ((fun (fun-info-ir2-convert kind))) + (:known + (let* ((info (basic-combination-fun-info node)) + (fun (fun-info-ir2-convert info))) (cond (fun (funcall fun node 2block)) ((eq (basic-combination-info node) :full)