X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=ad400313462df723e8197873def6e7c024d2dc64;hb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;hp=32ab726356dad76aa1a1e0ca63510fc9ef3976bb;hpb=0bca0cb1bf5ce5572ab5cd7ba59f87fed1f2edb0;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 32ab726..ad40031 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -81,7 +81,8 @@ (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)))) + (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing physenv))) ;;; If LEAF already has a constant TN, return that, otherwise make a ;;; TN for it. @@ -112,10 +113,10 @@ ;;; Convert a REF node. The reference must not be delayed. (defun ir2-convert-ref (node block) (declare (type ref node) (type ir2-block block)) - (let* ((cont (node-cont node)) + (let* ((lvar (node-lvar node)) (leaf (ref-leaf node)) - (locs (continuation-result-tns - cont (list (primitive-type (leaf-type leaf))))) + (locs (lvar-result-tns + lvar (list (primitive-type (leaf-type leaf))))) (res (first locs))) (etypecase leaf (lambda-var @@ -148,72 +149,74 @@ (if unsafe (vop fdefn-fun node block fdefn-tn res) (vop safe-fdefn-fun node block fdefn-tn res)))))))) - (move-continuation-result node block locs cont)) + (move-lvar-result node block locs lvar)) (values)) -;;; Emit code to load a function object implementing FUN into +;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE +(defun assertions-on-ir2-converted-clambda (clambda) + ;; This assertion was sort of an experiment. It would be nice and + ;; sane and easier to understand things if it were *always* true, + ;; but experimentally I observe that it's only *almost* always + ;; true. -- WHN 2001-01-02 + #+nil + (aver (eql (lambda-component clambda) + (block-component (ir2-block-block ir2-block)))) + ;; Check for some weirdness which came up in bug + ;; 138, 2002-01-02. + ;; + ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts an :ENTRY record + ;; into the IR2-COMPONENT-CONSTANTS table. The dump-a-COMPONENT + ;; code + ;; * treats every HANDLEless :ENTRY record into a + ;; patch, and + ;; * expects every patch to correspond to an + ;; IR2-COMPONENT-ENTRIES record. + ;; The IR2-COMPONENT-ENTRIES records are set by ENTRY-ANALYZE + ;; walking over COMPONENT-LAMBDAS. Bug 138b arose because there + ;; was a HANDLEless :ENTRY record which didn't correspond to an + ;; IR2-COMPONENT-ENTRIES record. That problem is hard to debug + ;; when it's caught at dump time, so this assertion tries to catch + ;; it here. + (aver (member clambda + (component-lambdas (lambda-component clambda)))) + ;; another bug-138-related issue: COMPONENT-NEW-FUNCTIONALS is + ;; used as a queue for stuff pending to do in IR1, and now that + ;; we're doing IR2 it should've been completely flushed (but + ;; wasn't). + (aver (null (component-new-functionals (lambda-component clambda)))) + (values)) + +;;; Emit code to load a function object implementing FUNCTIONAL into ;;; RES. This gets interesting when the referenced function is a ;;; closure: we must make the closure and move the closed-over values ;;; into it. ;;; -;;; FUN is either a :TOPLEVEL-XEP functional or the XEP lambda for the -;;; called function, since local call analysis converts all closure -;;; references. If a :TOPLEVEL-XEP, we know it is not a closure. +;;; FUNCTIONAL is either a :TOPLEVEL-XEP functional or the XEP lambda +;;; for the called function, since local call analysis converts all +;;; closure references. If a :TOPLEVEL-XEP, we know it is not a +;;; closure. ;;; ;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we ;;; don't initialize that slot. This can happen with closures over ;;; top level variables, where optimization of the closure deleted the ;;; variable. Since we committed to the closure format when we ;;; pre-analyzed the top level code, we just leave an empty slot. -(defun ir2-convert-closure (ref ir2-block fun res) - (declare (type ref ref) (type ir2-block ir2-block) - (type functional fun) (type tn res)) - - (unless (leaf-info fun) - (setf (leaf-info fun) - (make-entry-info :name (functional-debug-name fun)))) - (let ((entry (make-load-time-constant-tn :entry fun)) - (closure (etypecase fun +(defun ir2-convert-closure (ref ir2-block functional res) + (declare (type ref ref) + (type ir2-block ir2-block) + (type functional functional) + (type tn res)) + (aver (not (eql (functional-kind functional) :deleted))) + (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 (clambda - - ;; This assertion was sort of an experiment. It - ;; would be nice and sane and easier to understand - ;; things if it were *always* true, but - ;; experimentally I observe that it's only - ;; *almost* always true. -- WHN 2001-01-02 - #+nil - (aver (eql (lambda-component fun) - (block-component (ir2-block-block ir2-block)))) - - ;; Check for some weirdness which came up in bug - ;; 138, 2002-01-02. - ;; - ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts - ;; an :ENTRY record into the - ;; IR2-COMPONENT-CONSTANTS table. The - ;; dump-a-COMPONENT code - ;; * treats every HANDLEless :ENTRY record into a - ;; patch, and - ;; * expects every patch to correspond to an - ;; IR2-COMPONENT-ENTRIES record. - ;; The IR2-COMPONENT-ENTRIES records are set by - ;; ENTRY-ANALYZE walking over COMPONENT-LAMBDAS. - ;; Bug 138b arose because there was a HANDLEless - ;; :ENTRY record which didn't correspond to an - ;; IR2-COMPONENT-ENTRIES record. That problem is - ;; hard to debug when it's caught at dump time, so - ;; this assertion tries to catch it here. - (aver (member fun - (component-lambdas (lambda-component fun)))) - - ;; another bug-138-related issue: COMPONENT-NEW-FUNS - ;; is an IR1 temporary, and now that we're doing IR2 - ;; it should've been completely flushed (but wasn't). - (aver (null (component-new-funs (lambda-component fun)))) - - (physenv-closure (get-lambda-physenv fun))) + (assertions-on-ir2-converted-clambda functional) + (physenv-closure (get-lambda-physenv functional))) (functional - (aver (eq (functional-kind fun) :toplevel-xep)) + (aver (eq (functional-kind functional) :toplevel-xep)) nil)))) (cond (closure @@ -230,18 +233,18 @@ (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. +;;; 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* ((cont (node-cont node)) + (let* ((lvar (node-lvar node)) (leaf (set-var node)) - (val (continuation-tn node block (set-value node))) - (locs (if (continuation-info cont) - (continuation-result-tns - cont (list (primitive-type (leaf-type leaf)))) + (val (lvar-tn node block (set-value node))) + (locs (if lvar + (lvar-result-tns + lvar (list (primitive-type (leaf-type leaf)))) nil))) (etypecase leaf (lambda-var @@ -257,118 +260,90 @@ (vop set node block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) - (move-continuation-result node block locs cont))) + (move-lvar-result node block locs lvar))) (values)) ;;;; utilities for receiving fixed values -;;; Return a TN that can be referenced to get the value of CONT. CONT -;;; 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. +;;; 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 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. -(defun continuation-tn (node block cont) - (declare (type node node) (type ir2-block block) (type continuation cont)) - (let* ((2cont (continuation-info cont)) - (cont-tn - (ecase (ir2-continuation-kind 2cont) +;;; 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)) + (lvar-tn + (ecase (ir2-lvar-kind 2lvar) (:delayed - (let ((ref (continuation-use cont))) + (let ((ref (lvar-uses lvar))) (leaf-tn (ref-leaf ref) (node-physenv ref)))) (:fixed - (aver (= (length (ir2-continuation-locs 2cont)) 1)) - (first (ir2-continuation-locs 2cont))))) - (ptype (ir2-continuation-primitive-type 2cont))) - - (cond ((and (eq (continuation-type-check cont) t) - (multiple-value-bind (check types) - (continuation-check-types cont) - (aver (eq check :simple)) - ;; If the proven type is a subtype of the possibly - ;; weakened type check then it's always true and is - ;; flushed. - (unless (values-subtypep (continuation-proven-type cont) - (first types)) - (let ((temp (make-normal-tn ptype))) - (emit-type-check node block cont-tn temp - (first types)) - temp))))) - ((eq (tn-primitive-type cont-tn) ptype) cont-tn) + (aver (= (length (ir2-lvar-locs 2lvar)) 1)) + (first (ir2-lvar-locs 2lvar))))) + (ptype (ir2-lvar-primitive-type 2lvar))) + + (cond ((eq (tn-primitive-type lvar-tn) ptype) lvar-tn) (t (let ((temp (make-normal-tn ptype))) - (emit-move node block cont-tn temp) + (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 continuation-tns (node block cont ptypes) +(defun lvar-tns (node block lvar ptypes) (declare (type node node) (type ir2-block block) - (type continuation cont) (list ptypes)) - (let* ((locs (ir2-continuation-locs (continuation-info cont))) + (type lvar lvar) (list ptypes)) + (let* ((locs (ir2-lvar-locs (lvar-info lvar))) (nlocs (length locs))) (aver (= nlocs (length ptypes))) - (if (eq (continuation-type-check cont) t) - (multiple-value-bind (check types) (continuation-check-types cont) - (aver (eq check :simple)) - (let ((ntypes (length types))) - (mapcar (lambda (from to-type assertion) - (let ((temp (make-normal-tn to-type))) - (if assertion - (emit-type-check node block from temp assertion) - (emit-move node block from temp)) - temp)) - locs ptypes - (if (< ntypes nlocs) - (append types (make-list (- nlocs ntypes) - :initial-element nil)) - types)))) - (mapcar (lambda (from to-type) - (if (eq (tn-primitive-type from) to-type) - from - (let ((temp (make-normal-tn to-type))) - (emit-move node block from temp) - temp))) - locs - ptypes)))) + + (mapcar (lambda (from to-type) + (if (eq (tn-primitive-type from) to-type) + from + (let ((temp (make-normal-tn to-type))) + (emit-move node block from temp) + temp))) + 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. -(defun continuation-result-tns (cont types) - (declare (type continuation cont) (type list types)) - (let ((2cont (continuation-info cont))) - (if (not 2cont) - (mapcar #'make-normal-tn types) - (ecase (ir2-continuation-kind 2cont) +;;; 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) + (mapcar #'make-normal-tn types) + (let ((2lvar (lvar-info lvar))) + (ecase (ir2-lvar-kind 2lvar) (:fixed - (let* ((locs (ir2-continuation-locs 2cont)) + (let* ((locs (ir2-lvar-locs 2lvar)) (nlocs (length locs)) (ntypes (length types))) (if (and (= nlocs ntypes) @@ -402,21 +377,21 @@ ;;; 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. -(defun standard-result-tns (cont) - (declare (type continuation cont)) - (let ((2cont (continuation-info cont))) - (if 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed - (make-standard-value-tns (length (ir2-continuation-locs 2cont))))) - ()))) +;;; If the lvar is annotated, then it must be :FIXED. +(defun standard-result-tns (lvar) + (declare (type (or lvar null) lvar)) + (if lvar + (let ((2lvar (lvar-info lvar))) + (ecase (ir2-lvar-kind 2lvar) + (:fixed + (make-standard-value-tns (length (ir2-lvar-locs 2lvar)))))) + nil)) ;;; Just move each SRC TN into the corresponding DEST TN, defaulting ;;; any unsupplied source values to NIL. We let EMIT-MOVE worry about @@ -435,44 +410,95 @@ dest)) (values)) +;;; Move each SRC TN into the corresponding DEST TN, checking types +;;; and defaulting any unsupplied source values to NIL +(defun move-results-checked (node block src dest types) + (declare (type node node) (type ir2-block block) (list src dest types)) + (let ((nsrc (length src)) + (ndest (length dest)) + (ntypes (length types))) + (mapc (lambda (from to type) + (if type + (emit-type-check node block from to type) + (emit-move node block from to))) + (if (> ndest nsrc) + (append src (make-list (- ndest nsrc) + :initial-element (emit-constant nil))) + src) + dest + (if (> ndest ntypes) + (append types (make-list (- ndest ntypes))) + types))) + (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. -(defun move-continuation-result (node block results cont) +;;; 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 continuation cont)) - (let* ((2cont (continuation-info cont))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed - (let ((locs (ir2-continuation-locs 2cont))) - (unless (eq locs results) - (move-results-coerced node block results locs)))) - (:unknown - (let* ((nvals (length results)) - (locs (make-standard-value-tns nvals))) - (move-results-coerced node block results locs) - (vop* push-values node block - ((reference-tn-list locs nil)) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) - nvals)))))) + (list results) (type (or lvar null) lvar)) + (when lvar + (let ((2lvar (lvar-info lvar))) + (ecase (ir2-lvar-kind 2lvar) + (:fixed + (let ((locs (ir2-lvar-locs 2lvar))) + (unless (eq locs results) + (move-results-coerced node block results locs)))) + (:unknown + (let* ((nvals (length results)) + (locs (make-standard-value-tns nvals))) + (move-results-coerced node block results locs) + (vop* push-values node block + ((reference-tn-list locs nil)) + ((reference-tn-list (ir2-lvar-locs 2lvar) t)) + nvals)))))) (values)) + +;;; CAST +(defun ir2-convert-cast (node block) + (declare (type cast node) + (type ir2-block block)) + (binding* ((lvar (node-lvar node) :exit-if-null) + (2lvar (lvar-info lvar)) + (value (cast-value node)) + (2value (lvar-info value))) + (cond ((eq (ir2-lvar-kind 2lvar) :unused)) + ((eq (ir2-lvar-kind 2lvar) :unknown) + (aver (eq (ir2-lvar-kind 2value) :unknown)) + (aver (not (cast-type-check node))) + (move-results-coerced node block + (ir2-lvar-locs 2value) + (ir2-lvar-locs 2lvar))) + ((eq (ir2-lvar-kind 2lvar) :fixed) + (aver (eq (ir2-lvar-kind 2value) :fixed)) + (if (cast-type-check node) + (move-results-checked node block + (ir2-lvar-locs 2value) + (ir2-lvar-locs 2lvar) + (multiple-value-bind (check types) + (cast-check-types node nil) + (aver (eq check :simple)) + types)) + (move-results-coerced node block + (ir2-lvar-locs 2value) + (ir2-lvar-locs 2lvar)))) + (t (bug "CAST cannot be :DELAYED."))))) ;;;; 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. -(defun reference-arguments (node block args template) +;;; Build a TN-REFS list that represents access to the values of the +;;; 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)) (collect ((info-args)) @@ -484,8 +510,8 @@ (let ((type (first types)) (arg (first args))) (if (and (consp type) (eq (car type) ':constant)) - (info-args (continuation-value arg)) - (let ((ref (reference-tn (continuation-tn node block arg) nil))) + (info-args (lvar-value arg)) + (let ((ref (reference-tn (lvar-tn node block arg) nil))) (if last (setf (tn-ref-across last) ref) (setf first ref)) @@ -518,29 +544,23 @@ (defun ir2-convert-if (node block) (declare (type ir2-block block) (type cif node)) (let* ((test (if-test node)) - (test-ref (reference-tn (continuation-tn node block test) nil)) + (test-ref (reference-tn (lvar-tn node block test) nil)) (nil-ref (reference-tn (emit-constant nil) nil))) (setf (tn-ref-across test-ref) nil-ref) (ir2-convert-conditional node block (template-or-lose 'if-eq) 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 ;;; restrictions. -(defun find-template-result-types (call cont template rtypes) - (declare (type combination call) (type continuation cont) +(defun find-template-result-types (call template rtypes) + (declare (type combination call) (type template template) (list rtypes)) (let* ((dtype (node-derived-type call)) - (type (if (and (or (eq (template-ltn-policy template) :safe) - (policy call (= safety 0))) - (continuation-type-check cont)) - (values-type-intersection - dtype - (continuation-asserted-type cont)) - dtype)) + (type dtype) (types (mapcar #'primitive-type (if (values-type-p type) (append (values-type-required type) @@ -558,16 +578,16 @@ 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. -(defun make-template-result-tns (call cont template rtypes) - (declare (type combination call) (type continuation cont) +;;; 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)) - (let ((2cont (continuation-info cont))) - (if (and 2cont (eq (ir2-continuation-kind 2cont) :fixed)) - (let ((locs (ir2-continuation-locs 2cont))) + (let ((2lvar (when lvar (lvar-info lvar)))) + (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed)) + (let ((locs (ir2-lvar-locs 2lvar))) (if (and (= (length rtypes) (length locs)) (do ((loc locs (cdr loc)) (rtype rtypes (cdr rtype))) @@ -578,34 +598,34 @@ :t-ok nil) (return nil)))) locs - (continuation-result-tns - cont - (find-template-result-types call cont template rtypes)))) - (continuation-result-tns - cont - (find-template-result-types call cont template rtypes))))) - -;;; Get the operands into TNs, make TN-Refs for them, and then call + (lvar-result-tns + lvar + (find-template-result-types call template rtypes)))) + (lvar-result-tns + lvar + (find-template-result-types call template rtypes))))) + +;;; Get the operands into TNs, make TN-REFs for them, and then call ;;; the template emit function. (defun ir2-convert-template (call block) (declare (type combination call) (type ir2-block block)) (let* ((template (combination-info call)) - (cont (node-cont call)) + (lvar (node-lvar call)) (rtypes (template-result-types template))) (multiple-value-bind (args info-args) - (reference-arguments call block (combination-args call) template) + (reference-args call block (combination-args call) template) (aver (not (template-more-results-type template))) (if (eq rtypes :conditional) (ir2-convert-conditional call block template args info-args - (continuation-dest cont) nil) - (let* ((results (make-template-result-tns call cont template rtypes)) + (lvar-dest lvar) nil) + (let* ((results (make-template-result-tns call lvar template rtypes)) (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) (if info-args (emit-template call block template args r-refs info-args) (emit-template call block template args r-refs)) - (move-continuation-result call block results cont))))) + (move-lvar-result call block results lvar))))) (values)) ;;; We don't have to do much because operand count checking is done by @@ -613,15 +633,14 @@ ;;; case of IR2-CONVERT-TEMPLATE is that there can be codegen-info ;;; arguments. (defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block) - (let* ((template (continuation-value template)) - (info (continuation-value info)) - (cont (node-cont call)) + (let* ((template (lvar-value template)) + (info (lvar-value info)) + (lvar (node-lvar call)) (rtypes (template-result-types template)) - (results (make-template-result-tns call cont template rtypes)) + (results (make-template-result-tns call lvar template rtypes)) (r-refs (reference-tn-list results t))) (multiple-value-bind (args info-args) - (reference-arguments call block (cddr (combination-args call)) - template) + (reference-args call block (cddr (combination-args call)) template) (aver (not (template-more-results-type template))) (aver (not (eq rtypes :conditional))) (aver (null info-args)) @@ -630,7 +649,7 @@ (emit-template call block template args r-refs info) (emit-template call block template args r-refs)) - (move-continuation-result call block results cont))) + (move-lvar-result call block results lvar))) (values)) ;;;; local call @@ -644,7 +663,7 @@ (declare (type combination node) (type ir2-block block) (type clambda fun)) (mapc (lambda (var arg) (when arg - (let ((src (continuation-tn node block arg)) + (let ((src (lvar-tn node block arg)) (dest (leaf-info var))) (if (lambda-var-indirect var) (do-make-value-cell node block src dest) @@ -667,12 +686,10 @@ (defun emit-psetq-moves (node block fun old-fp) (declare (type combination node) (type ir2-block block) (type clambda fun) (type (or tn null) old-fp)) - (let* ((called-env (physenv-info (lambda-physenv fun))) - (this-1env (node-physenv node)) - (actuals (mapcar (lambda (x) - (when x - (continuation-tn node block x))) - (combination-args node)))) + (let ((actuals (mapcar (lambda (x) + (when x + (lvar-tn node block x))) + (combination-args node)))) (collect ((temps) (locs)) (dolist (var (lambda-vars fun)) @@ -694,12 +711,13 @@ (locs loc)))) (when old-fp - (dolist (thing (ir2-physenv-closure called-env)) - (temps (find-in-physenv (car thing) this-1env)) - (locs (cdr thing))) - - (temps old-fp) - (locs (ir2-physenv-old-fp called-env))) + (let ((this-1env (node-physenv node)) + (called-env (physenv-info (lambda-physenv fun)))) + (dolist (thing (ir2-physenv-closure called-env)) + (temps (find-in-physenv (car thing) this-1env)) + (locs (cdr thing))) + (temps old-fp) + (locs (ir2-physenv-old-fp called-env)))) (values (temps) (locs))))) @@ -755,10 +773,10 @@ (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. -(defun ir2-convert-local-known-call (node block fun returns cont start) +;;; 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 continuation cont) + (type return-info returns) (type (or lvar null) lvar) (type label start)) (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) @@ -767,37 +785,37 @@ (fp nfp (reference-tn-list temps nil)) ((reference-tn-list locs t)) arg-locs (physenv-info (lambda-physenv fun)) start) - (move-continuation-result node block locs cont))) + (move-lvar-result node block locs lvar))) (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. -(defun ir2-convert-local-unknown-call (node block fun cont start) +;;; 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 continuation cont) (type label start)) + (type (or lvar null) lvar) (type label start)) (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) - (let ((2cont (continuation-info cont)) + (let ((2lvar (and lvar (lvar-info lvar))) (env (physenv-info (lambda-physenv fun))) (temp-refs (reference-tn-list temps nil))) - (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) + (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown)) (vop* multiple-call-local node block (fp nfp temp-refs) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) + ((reference-tn-list (ir2-lvar-locs 2lvar) t)) arg-locs env start) - (let ((locs (standard-result-tns cont))) + (let ((locs (standard-result-tns lvar))) (vop* call-local node block (fp nfp temp-refs) ((reference-tn-list locs t)) arg-locs env start (length locs)) - (move-continuation-result node block locs cont))))) + (move-lvar-result node block locs lvar))))) (values)) ;;; Dispatch to the appropriate function, depending on whether we have @@ -806,7 +824,7 @@ ;;; tail call, but that might seem confusing in the debugger. (defun ir2-convert-local-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((fun (ref-leaf (continuation-use (basic-combination-fun node)))) + (let* ((fun (ref-leaf (lvar-uses (basic-combination-fun node)))) (kind (functional-kind fun))) (cond ((eq kind :let) (ir2-convert-let node block fun)) @@ -817,51 +835,43 @@ (t (let ((start (block-label (lambda-block fun))) (returns (tail-set-info (lambda-tail-set fun))) - (cont (node-cont node))) + (lvar (node-lvar node))) (ecase (if returns (return-info-kind returns) :unknown) (:unknown - (ir2-convert-local-unknown-call node block fun cont start)) + (ir2-convert-local-unknown-call node block fun lvar start)) (:fixed (ir2-convert-local-known-call node block fun returns - cont start))))))) + lvar start))))))) (values)) ;;;; full call -;;; Given a function continuation FUN, return as values a TN holding -;;; the thing that we call and true if the thing is named (false if it -;;; is a function). There are two interesting non-named cases: -;;; -- Known to be a function, no check needed: return the -;;; continuation loc. -;;; -- Not known what it is. -(defun fun-continuation-tn (node block cont) - (declare (type continuation cont)) - (let ((2cont (continuation-info cont))) - (if (eq (ir2-continuation-kind 2cont) :delayed) - (let ((name (continuation-fun-name cont t))) +;;; 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 +;;; lvar LOC. +;;; -- We don't know what it is. +(defun fun-lvar-tn (node block lvar) + (declare (type lvar lvar)) + (let ((2lvar (lvar-info lvar))) + (if (eq (ir2-lvar-kind 2lvar) :delayed) + (let ((name (lvar-fun-name lvar t))) (aver name) (values (make-load-time-constant-tn :fdefinition name) t)) - (let* ((locs (ir2-continuation-locs 2cont)) + (let* ((locs (ir2-lvar-locs 2lvar)) (loc (first locs)) - (check (continuation-type-check cont)) (function-ptype (primitive-type-or-lose 'function))) - (aver (and (eq (ir2-continuation-kind 2cont) :fixed) + (aver (and (eq (ir2-lvar-kind 2lvar) :fixed) (= (length locs) 1))) - (cond ((eq (tn-primitive-type loc) function-ptype) - (aver (not (eq check t))) - (values loc nil)) - (t - (let ((temp (make-normal-tn function-ptype))) - (aver (and (eq (ir2-continuation-primitive-type 2cont) - function-ptype) - (eq check t))) - (emit-type-check node block loc temp - (specifier-type 'function)) - (values temp nil)))))))) - -;;; Set up the args to Node in the current frame, and return a tn-ref + (aver (eq (tn-primitive-type loc) function-ptype)) + (values loc nil))))) + +;;; Set up the args to NODE in the current frame, and return a TN-REF ;;; list for the passing locations. (defun move-tail-full-call-args (node block) (declare (type combination node) (type ir2-block block)) @@ -870,7 +880,7 @@ (first nil)) (dotimes (num (length args)) (let ((loc (standard-arg-location num))) - (emit-move node block (continuation-tn node block (elt args num)) loc) + (emit-move node block (lvar-tn node block (elt args num)) loc) (let ((ref (reference-tn loc nil))) (if last (setf (tn-ref-across last) ref) @@ -890,7 +900,7 @@ (return-pc (ir2-physenv-return-pc env))) (multiple-value-bind (fun-tn named) - (fun-continuation-tn node block (basic-combination-fun node)) + (fun-lvar-tn node block (basic-combination-fun node)) (if named (vop* tail-call-named node block (fun-tn old-fp return-pc pass-refs) @@ -915,7 +925,7 @@ (first nil)) (dotimes (num nargs) (locs (standard-arg-location num)) - (let ((ref (reference-tn (continuation-tn node block (elt args num)) + (let ((ref (reference-tn (lvar-tn node block (elt args num)) nil))) (if last (setf (tn-ref-across last) ref) @@ -925,25 +935,24 @@ (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) (ir2-convert-full-call-args node block) - (let* ((cont (node-cont node)) - (locs (standard-result-tns cont)) + (let* ((lvar (node-lvar node)) + (locs (standard-result-tns lvar)) (loc-refs (reference-tn-list locs t)) (nvals (length locs))) (multiple-value-bind (fun-tn named) - (fun-continuation-tn node block (basic-combination-fun node)) + (fun-lvar-tn node block (basic-combination-fun node)) (if named (vop* call-named node block (fp fun-tn args) (loc-refs) arg-locs nargs nvals) (vop* call node block (fp fun-tn args) (loc-refs) arg-locs nargs nvals)) - (move-continuation-result node block locs cont)))) + (move-lvar-result node block locs lvar)))) (values)) ;;; Do full call when unknown values are desired. @@ -951,11 +960,11 @@ (declare (type combination node) (type ir2-block block)) (multiple-value-bind (fp args arg-locs nargs) (ir2-convert-full-call-args node block) - (let* ((cont (node-cont node)) - (locs (ir2-continuation-locs (continuation-info cont))) + (let* ((lvar (node-lvar node)) + (locs (ir2-lvar-locs (lvar-info lvar))) (loc-refs (reference-tn-list locs t))) (multiple-value-bind (fun-tn named) - (fun-continuation-tn node block (basic-combination-fun node)) + (fun-lvar-tn node block (basic-combination-fun node)) (if named (vop* multiple-call-named node block (fp fun-tn args) (loc-refs) arg-locs nargs) @@ -963,7 +972,7 @@ arg-locs nargs))))) (values)) -;;; stuff to check in CHECK-FULL-CALL +;;; stuff to check in PONDER-FULL-CALL ;;; ;;; There are some things which are intended always to be optimized ;;; away by DEFTRANSFORMs and such, and so never compiled into full @@ -976,7 +985,7 @@ ;;; list. (defvar *always-optimized-away* '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug - ;; reported to cmucl-imp@cons.org 2000-06-20. + ;; reported to cmucl-imp 2000-06-20. %instance-ref ;; These should always turn into VOPs, but wasn't in a bug which ;; appeared when LTN-POLICY stuff was being tweaked in @@ -984,7 +993,7 @@ data-vector-set data-vector-ref)) -;;; more stuff to check in CHECK-FULL-CALL +;;; more stuff to check in PONDER-FULL-CALL ;;; ;;; These came in handy when troubleshooting cold boot after making ;;; major changes in the package structure: various transforms and @@ -996,14 +1005,17 @@ #!+sb-show (defvar *show-full-called-fnames-p* nil) #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal)) -;;; Do some checks on a full call: +;;; Do some checks (and store some notes relevant for future checks) +;;; on a full call: ;;; * Is this a full call to something we have reason to know should -;;; never be full called? +;;; never be full called? (Except as of sbcl-0.7.18 or so, we no +;;; longer try to ensure this behavior when *FAILURE-P* has already +;;; been detected.) ;;; * Is this a full call to (SETF FOO) which might conflict with ;;; a DEFSETF or some such thing elsewhere in the program? -(defun check-full-call (node) - (let* ((cont (basic-combination-fun node)) - (fname (continuation-fun-name cont t))) +(defun ponder-full-call (node) + (let* ((lvar (basic-combination-fun node)) + (fname (lvar-fun-name lvar t))) (declare (type (or symbol cons) fname)) #!+sb-show (unless (gethash fname *full-called-fnames*) @@ -1013,23 +1025,29 @@ (/show (basic-combination-args node)) (/show (policy node speed) (policy node safety)) (/show (policy node compilation-speed)) - (let ((arg-types (mapcar (lambda (maybe-continuation) - (when maybe-continuation + (let ((arg-types (mapcar (lambda (lvar) + (when lvar (type-specifier - (continuation-type - maybe-continuation)))) + (lvar-type lvar)))) (basic-combination-args node)))) (/show arg-types))) - (when (memq fname *always-optimized-away*) - (/show (policy node speed) (policy node safety)) - (/show (policy node compilation-speed)) - (error "internal error: full call to ~S" fname)) + ;; When illegal code is compiled, all sorts of perverse paths + ;; through the compiler can be taken, and it's much harder -- and + ;; probably pointless -- to guarantee that always-optimized-away + ;; functions are actually optimized away. Thus, we skip the check + ;; in that case. + (unless *failure-p* + (when (memq fname *always-optimized-away*) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (bug "full call to ~S" fname))) (when (consp fname) - (destructuring-bind (setf stem) fname - (aver (eq setf 'setf)) - (setf (gethash stem *setf-assumed-fboundp*) t))))) + (aver (legal-fun-name-p fname)) + (destructuring-bind (setfoid &rest stem) fname + (when (eq setfoid 'setf) + (setf (gethash (car stem) *setf-assumed-fboundp*) t)))))) ;;; If the call is in a tail recursive position and the return ;;; convention is standard, then do a tail full call. If one or fewer @@ -1037,15 +1055,15 @@ ;;; multiple-values call. (defun ir2-convert-full-call (node block) (declare (type combination node) (type ir2-block block)) - (check-full-call node) - (let ((2cont (continuation-info (node-cont node)))) - (cond ((node-tail-p node) - (ir2-convert-tail-full-call node block)) - ((and 2cont - (eq (ir2-continuation-kind 2cont) :unknown)) - (ir2-convert-multiple-full-call node block)) - (t - (ir2-convert-fixed-full-call node block)))) + (ponder-full-call node) + (cond ((node-tail-p node) + (ir2-convert-tail-full-call node block)) + ((let ((lvar (node-lvar node))) + (and lvar + (eq (ir2-lvar-kind (lvar-info lvar)) :unknown))) + (ir2-convert-multiple-full-call node block)) + (t + (ir2-convert-fixed-full-call node block))) (values)) ;;;; entering functions @@ -1141,9 +1159,9 @@ ;;; RETURN-MULTIPLE. (defun ir2-convert-return (node block) (declare (type creturn node) (type ir2-block block)) - (let* ((cont (return-result node)) - (2cont (continuation-info cont)) - (cont-kind (ir2-continuation-kind 2cont)) + (let* ((lvar (return-result node)) + (2lvar (lvar-info lvar)) + (lvar-kind (ir2-lvar-kind 2lvar)) (fun (return-lambda node)) (env (physenv-info (lambda-physenv fun))) (old-fp (ir2-physenv-old-fp env)) @@ -1152,20 +1170,20 @@ (cond ((and (eq (return-info-kind returns) :fixed) (not (xep-p fun))) - (let ((locs (continuation-tns node block cont + (let ((locs (lvar-tns node block lvar (return-info-types returns)))) (vop* known-return node block (old-fp return-pc (reference-tn-list locs nil)) (nil) (return-info-locations returns)))) - ((eq cont-kind :fixed) - (let* ((types (mapcar #'tn-primitive-type (ir2-continuation-locs 2cont))) - (cont-locs (continuation-tns node block cont types)) - (nvals (length cont-locs)) + ((eq lvar-kind :fixed) + (let* ((types (mapcar #'tn-primitive-type (ir2-lvar-locs 2lvar))) + (lvar-locs (lvar-tns node block lvar types)) + (nvals (length lvar-locs)) (locs (make-standard-value-tns nvals))) (mapc (lambda (val loc) (emit-move node block val loc)) - cont-locs + lvar-locs locs) (if (= nvals 1) (vop return-single node block old-fp return-pc (car locs)) @@ -1174,10 +1192,10 @@ (nil) nvals)))) (t - (aver (eq cont-kind :unknown)) + (aver (eq lvar-kind :unknown)) (vop* return-multiple node block (old-fp return-pc - (reference-tn-list (ir2-continuation-locs 2cont) nil)) + (reference-tn-list (ir2-lvar-locs 2lvar) nil)) (nil))))) (values)) @@ -1189,21 +1207,21 @@ ;;; function as multiple values. (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) (let ((ir2-physenv (physenv-info (node-physenv node)))) - (move-continuation-result node block + (move-lvar-result node block (list (ir2-physenv-old-fp ir2-physenv) (ir2-physenv-return-pc ir2-physenv)) - (node-cont node)))) + (node-lvar node)))) ;;;; multiple values -;;; This is almost identical to IR2-Convert-Let. Since LTN annotates -;;; the continuation for the correct number of values (with the -;;; continuation user responsible for defaulting), we can just pick -;;; them up from the continuation. +;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates +;;; the lvarinuation 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* ((cont (first (basic-combination-args node))) - (fun (ref-leaf (continuation-use (basic-combination-fun node)))) + (let* ((lvar (first (basic-combination-args node))) + (fun (ref-leaf (lvar-uses (basic-combination-fun node)))) (vars (lambda-vars fun))) (aver (eq (functional-kind fun) :mv-let)) (mapc (lambda (src var) @@ -1212,7 +1230,7 @@ (if (lambda-var-indirect var) (do-make-value-cell node block src dest) (emit-move node block src dest))))) - (continuation-tns node block cont + (lvar-tns node block lvar (mapcar (lambda (x) (primitive-type (leaf-type x))) vars)) @@ -1221,53 +1239,53 @@ ;;; 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) (declare (type mv-combination node) (type ir2-block block)) (aver (basic-combination-args node)) - (let* ((start-cont (continuation-info (first (basic-combination-args node)))) - (start (first (ir2-continuation-locs start-cont))) + (let* ((start-lvar (lvar-info (first (basic-combination-args node)))) + (start (first (ir2-lvar-locs start-lvar))) (tails (and (node-tail-p node) (lambda-tail-set (node-home-lambda node)))) - (cont (node-cont node)) - (2cont (continuation-info cont))) + (lvar (node-lvar node)) + (2lvar (and lvar (lvar-info lvar)))) (multiple-value-bind (fun named) - (fun-continuation-tn node block (basic-combination-fun node)) + (fun-lvar-tn node block (basic-combination-fun node)) (aver (and (not named) - (eq (ir2-continuation-kind start-cont) :unknown))) + (eq (ir2-lvar-kind start-lvar) :unknown))) (cond (tails (let ((env (physenv-info (node-physenv node)))) (vop tail-call-variable node block start fun (ir2-physenv-old-fp env) (ir2-physenv-return-pc env)))) - ((and 2cont - (eq (ir2-continuation-kind 2cont) :unknown)) + ((and 2lvar + (eq (ir2-lvar-kind 2lvar) :unknown)) (vop* multiple-call-variable node block (start fun nil) - ((reference-tn-list (ir2-continuation-locs 2cont) t)))) + ((reference-tn-list (ir2-lvar-locs 2lvar) t)))) (t - (let ((locs (standard-result-tns cont))) + (let ((locs (standard-result-tns lvar))) (vop* call-variable node block (start fun nil) ((reference-tn-list locs t)) (length locs)) - (move-continuation-result node block locs cont))))))) + (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) ((continuation) node block) - (let ((2cont (continuation-info (continuation-value continuation)))) - (aver (eq (ir2-continuation-kind 2cont) :unknown)) +;;; unknown-values lvar (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-continuation-locs 2cont))))) + (first (ir2-lvar-locs 2lvar))))) -;;; Deliver the values TNs to CONT using MOVE-CONTINUATION-RESULT. +;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) (let ((tns (mapcar (lambda (x) - (continuation-tn node block x)) + (lvar-tn node block x)) values))) - (move-continuation-result node block tns (node-cont node)))) + (move-lvar-result node block tns (node-lvar node)))) ;;; In the normal case where unknown values are desired, we use the ;;; VALUES-LIST VOP. In the relatively unimportant case of VALUES-LIST @@ -1276,39 +1294,39 @@ ;;; defaulting any unsupplied values. It seems unworthwhile to ;;; optimize this case. (defoptimizer (values-list ir2-convert) ((list) node block) - (let* ((cont (node-cont node)) - (2cont (continuation-info cont))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed (ir2-convert-full-call node block)) - (:unknown - (let ((locs (ir2-continuation-locs 2cont))) - (vop* values-list node block - ((continuation-tn node block list) nil) - ((reference-tn-list locs t))))))))) + (let* ((lvar (node-lvar node)) + (2lvar (and lvar (lvar-info lvar)))) + (cond ((and 2lvar + (eq (ir2-lvar-kind 2lvar) :unknown)) + (let ((locs (ir2-lvar-locs 2lvar))) + (vop* values-list node block + ((lvar-tn node block list) nil) + ((reference-tn-list locs t))))) + (t (aver (or (not 2lvar) ; i.e. we want to check the argument + (eq (ir2-lvar-kind 2lvar) :fixed))) + (ir2-convert-full-call node block))))) (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block) - (let* ((cont (node-cont node)) - (2cont (continuation-info cont))) - (when 2cont - (ecase (ir2-continuation-kind 2cont) - (:fixed (ir2-convert-full-call node block)) - (:unknown - (let ((locs (ir2-continuation-locs 2cont))) - (vop* %more-arg-values node block - ((continuation-tn node block context) - (continuation-tn node block start) - (continuation-tn node block count) - nil) - ((reference-tn-list locs t))))))))) + (binding* ((lvar (node-lvar node) :exit-if-null) + (2lvar (lvar-info lvar))) + (ecase (ir2-lvar-kind 2lvar) + (:fixed (ir2-convert-full-call node block)) + (:unknown + (let ((locs (ir2-lvar-locs 2lvar))) + (vop* %more-arg-values node block + ((lvar-tn node block context) + (lvar-tn node block start) + (lvar-tn node block count) + nil) + ((reference-tn-list locs t)))))))) ;;;; special binding ;;; This is trivial, given our assumption of a shallow-binding ;;; implementation. (defoptimizer (%special-bind ir2-convert) ((var value) node block) - (let ((name (leaf-source-name (continuation-value var)))) - (vop bind node block (continuation-tn node block value) + (let ((name (leaf-source-name (lvar-value var)))) + (vop bind node block (lvar-tn node block value) (emit-constant name)))) (defoptimizer (%special-unbind ir2-convert) ((var) node block) (vop unbind node block)) @@ -1317,35 +1335,47 @@ ;;; should really be done this way, but this is the least violation of ;;; abstraction in the current setup. We don't want to wire ;;; shallow-binding assumptions into IR1tran. -(def-ir1-translator progv ((vars vals &body body) start cont) +(def-ir1-translator progv + ((vars vals &body body) start next result) (ir1-convert - start cont - (once-only ((n-save-bs '(%primitive current-binding-pointer))) - `(unwind-protect - (progn - (mapc (lambda (var val) - (%primitive bind val var)) - ,vars - ,vals) - ,@body) - (%primitive unbind-to-here ,n-save-bs))))) + 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)))))) ;;;; non-local exit -;;; Convert a non-local lexical exit. First find the NLX-Info in our +;;; Convert a non-local lexical exit. First find the NLX-INFO in our ;;; environment. Note that this is never called on the escape exits ;;; for CATCH and UNWIND-PROTECT, since the escape functions aren't ;;; IR2 converted. (defun ir2-convert-exit (node block) (declare (type exit node) (type ir2-block block)) - (let ((loc (find-in-physenv (find-nlx-info (exit-entry node) - (node-cont node)) + (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) (if value - (let ((locs (ir2-continuation-locs (continuation-info value)))) + (let ((locs (ir2-lvar-locs (lvar-info value)))) (vop unwind node block temp (first locs) (second locs))) (let ((0-tn (emit-constant 0))) (vop unwind node block temp 0-tn 0-tn)))) @@ -1361,30 +1391,31 @@ ;;; 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 (continuation-value info) (node-physenv node)) + (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))) + (check-catch-tag-type (first args)) (vop* throw node block - ((continuation-tn node block (first args)) + ((lvar-tn node block (first args)) (reference-tn-list - (ir2-continuation-locs (continuation-info (second args))) + (ir2-lvar-locs (lvar-info (second args))) nil)) (nil))) - (move-continuation-result node block () (node-cont node)) + (move-lvar-result node block () (node-lvar node)) (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. +;;; Emit code to set up a non-local exit. INFO is the NLX-INFO for the +;;; 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 continuation null) tag)) + (type (or lvar null) tag)) (let* ((2info (nlx-info-info info)) (kind (cleanup-kind (nlx-info-cleanup info))) (block-tn (physenv-live-tn @@ -1403,7 +1434,7 @@ (ecase kind (:catch (vop make-catch-block node block block-tn - (continuation-tn node block tag) target-label res)) + (lvar-tn node block tag) target-label res)) ((:unwind-protect :block :tagbody) (vop make-unwind-block node block block-tn target-label res))) @@ -1420,7 +1451,7 @@ (defun ir2-convert-entry (node block) (declare (type entry node) (type ir2-block block)) (dolist (exit (entry-exits node)) - (let ((info (find-nlx-info node (node-cont exit)))) + (let ((info (find-nlx-info exit))) (when (and info (member (cleanup-kind (nlx-info-cleanup info)) '(:block :tagbody))) @@ -1428,62 +1459,62 @@ (values)) ;;; Set up the unwind block for these guys. -(defoptimizer (%catch ir2-convert) ((info-cont tag) node block) - (emit-nlx-start node block (continuation-value info-cont) tag)) -(defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block) - (emit-nlx-start node block (continuation-value info-cont) nil)) +(defoptimizer (%catch ir2-convert) ((info-lvar tag) node block) + (check-catch-tag-type tag) + (emit-nlx-start node block (lvar-value info-lvar) tag)) +(defoptimizer (%unwind-protect ir2-convert) ((info-lvar cleanup) node block) + (emit-nlx-start node block (lvar-value info-lvar) nil)) ;;; 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 ;;; pointer. In an UNWIND-PROTECT cleanup, we want to leave the stack ;;; pointer alone, since the thrown values are still out there. -(defoptimizer (%nlx-entry ir2-convert) ((info-cont) node block) - (let* ((info (continuation-value info-cont)) - (cont (nlx-info-continuation info)) - (2cont (continuation-info cont)) +(defoptimizer (%nlx-entry ir2-convert) ((info-lvar) node block) + (let* ((info (lvar-value info-lvar)) + (lvar (nlx-info-lvar info)) (2info (nlx-info-info info)) (top-loc (ir2-nlx-info-save-sp 2info)) - (start-loc (make-nlx-entry-argument-start-location)) + (start-loc (make-nlx-entry-arg-start-location)) (count-loc (make-arg-count-location)) (target (ir2-nlx-info-target 2info))) (ecase (cleanup-kind (nlx-info-cleanup info)) ((:catch :block :tagbody) - (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* nlx-entry-multiple node block - (top-loc start-loc count-loc nil) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) - target) - (let ((locs (standard-result-tns cont))) - (vop* nlx-entry node block - (top-loc start-loc count-loc nil) - ((reference-tn-list locs t)) - target - (length locs)) - (move-continuation-result node block locs cont)))) + (let ((2lvar (and lvar (lvar-info lvar)))) + (if (and 2lvar (eq (ir2-lvar-kind 2lvar) :unknown)) + (vop* nlx-entry-multiple node block + (top-loc start-loc count-loc nil) + ((reference-tn-list (ir2-lvar-locs 2lvar) t)) + target) + (let ((locs (standard-result-tns lvar))) + (vop* nlx-entry node block + (top-loc start-loc count-loc nil) + ((reference-tn-list locs t)) + target + (length locs)) + (move-lvar-result node block locs lvar))))) (:unwind-protect (let ((block-loc (standard-arg-location 0))) (vop uwp-entry node block target block-loc start-loc count-loc) - (move-continuation-result + (move-lvar-result node block (list block-loc start-loc count-loc) - cont)))) + lvar)))) #!+sb-dyncount (when *collect-dynamic-statistics* @@ -1498,18 +1529,18 @@ ;;;; n-argument functions -(macrolet ((def-frob (name) +(macrolet ((def (name) `(defoptimizer (,name ir2-convert) ((&rest args) node block) (let* ((refs (move-tail-full-call-args node block)) - (cont (node-cont node)) - (res (continuation-result-tns - cont + (lvar (node-lvar node)) + (res (lvar-result-tns + lvar (list (primitive-type (specifier-type 'list)))))) (vop* ,name node block (refs) ((first res) nil) (length args)) - (move-continuation-result node block res cont))))) - (def-frob list) - (def-frob list*)) + (move-lvar-result node block res lvar))))) + (def list) + (def list*)) ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) @@ -1540,11 +1571,11 @@ (setf (block-number block) num) #!+sb-dyncount (when *collect-dynamic-statistics* - (let ((first-node (continuation-next (block-start block)))) + (let ((first-node (block-start-node block))) (unless (or (and (bind-p first-node) (xep-p (bind-lambda first-node))) - (eq (continuation-fun-name - (node-cont first-node)) + (eq (lvar-fun-name + (node-lvar first-node)) '%nlx-entry)) (vop count-me first-node @@ -1566,13 +1597,13 @@ (last (block-last block)) (succ (block-succ block))) (unless (if-p last) - (aver (and succ (null (rest succ)))) + (aver (singleton-p succ)) (let ((target (first succ))) (cond ((eq target (component-tail (block-component block))) (when (and (basic-combination-p last) (eq (basic-combination-kind last) :full)) (let* ((fun (basic-combination-fun last)) - (use (continuation-use fun)) + (use (lvar-uses fun)) (name (and (ref-p use) (leaf-has-source-name-p (ref-leaf use)) (leaf-source-name (ref-leaf use))))) @@ -1583,7 +1614,7 @@ (if name (emit-constant name) (multiple-value-bind (tn named) - (fun-continuation-tn last 2block fun) + (fun-lvar-tn last 2block fun) (aver (not named)) tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) @@ -1595,13 +1626,14 @@ (defun ir2-convert-block (block) (declare (type cblock block)) (let ((2block (block-info block))) - (do-nodes (node cont block) + (do-nodes (node lvar block) (etypecase node (ref - (let ((2cont (continuation-info cont))) - (when (and 2cont - (not (eq (ir2-continuation-kind 2cont) :delayed))) - (ir2-convert-ref node 2block)))) + (when lvar + (let ((2lvar (lvar-info lvar))) + ;; function REF in a local call is not annotated + (when (and 2lvar (not (eq (ir2-lvar-kind 2lvar) :delayed))) + (ir2-convert-ref node 2block))))) (combination (let ((kind (basic-combination-kind node))) (case kind @@ -1618,7 +1650,7 @@ (t (ir2-convert-template node 2block)))))))) (cif - (when (continuation-info (if-test node)) + (when (lvar-info (if-test node)) (ir2-convert-if node 2block))) (bind (let ((fun (bind-lambda node))) @@ -1628,15 +1660,17 @@ (ir2-convert-return node 2block)) (cset (ir2-convert-set node 2block)) + (cast + (ir2-convert-cast node 2block)) (mv-combination (cond - ((eq (basic-combination-kind node) :local) - (ir2-convert-mv-bind node 2block)) - ((eq (continuation-fun-name (basic-combination-fun node)) - '%throw) - (ir2-convert-throw node 2block)) - (t - (ir2-convert-mv-call node 2block)))) + ((eq (basic-combination-kind node) :local) + (ir2-convert-mv-bind node 2block)) + ((eq (lvar-fun-name (basic-combination-fun node)) + '%throw) + (ir2-convert-throw node 2block)) + (t + (ir2-convert-mv-call node 2block)))) (exit (when (exit-entry node) (ir2-convert-exit node 2block)))