X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=2a374930274052d32b8800cb609e096dd0b69fe2;hb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;hp=22501914320b13572c98238212179ee72c69435d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 2250191..2a37493 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -21,8 +21,8 @@ (vop move node block x y)) (values)) -;;; If there is any CHECK-xxx template for Type, then return it, otherwise -;;; return NIL. +;;; If there is any CHECK-xxx template for TYPE, then return it, +;;; otherwise return NIL. (defun type-check-template (type) (declare (type ctype type)) (multiple-value-bind (check-ptype exact) (primitive-type type) @@ -33,91 +33,112 @@ (template-or-lose name) nil))))) -;;; Emit code in Block to check that Value is of the specified Type, -;;; yielding the checked result in Result. Value and result may be of any -;;; primitive type. There must be CHECK-xxx VOP for Type. Any other type -;;; checks should have been converted to an explicit type test. +;;; Emit code in BLOCK to check that VALUE is of the specified TYPE, +;;; yielding the checked result in RESULT. VALUE and result may be of +;;; any primitive type. There must be CHECK-xxx VOP for TYPE. Any +;;; other type checks should have been converted to an explicit type +;;; test. (defun emit-type-check (node block value result type) (declare (type tn value result) (type node node) (type ir2-block block) (type ctype type)) (emit-move-template node block (type-check-template type) value result) (values)) -;;; Allocate an indirect value cell. Maybe do some clever stack allocation -;;; someday. -(defevent make-value-cell "Allocate heap value cell for lexical var.") +;;; Allocate an indirect value cell. Maybe do some clever stack +;;; allocation someday. +;;; +;;; FIXME: DO-MAKE-VALUE-CELL is a bad name, since it doesn't make +;;; clear what's the distinction between it and the MAKE-VALUE-CELL +;;; VOP, and since the DO- further connotes iteration, which has +;;; nothing to do with this. Clearer, more systematic names, anyone? +(defevent make-value-cell-event "Allocate heap value cell for lexical var.") (defun do-make-value-cell (node block value res) - (event make-value-cell node) + (event make-value-cell-event node) (vop make-value-cell node block value res)) ;;;; leaf reference -;;; Return the TN that holds the value of Thing in the environment Env. -(defun find-in-environment (thing env) - (declare (type (or nlx-info lambda-var) thing) (type environment env) - (values tn)) - (or (cdr (assoc thing (ir2-environment-environment (environment-info env)))) +;;; Return the TN that holds the value of THING in the environment ENV. +(declaim (ftype (function ((or nlx-info lambda-var) physenv) tn) + find-in-physenv)) +(defun find-in-physenv (thing physenv) + (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) (etypecase thing (lambda-var - (assert (eq env (lambda-environment (lambda-var-home thing)))) + ;; I think that a failure of this assertion means that we're + ;; trying to access a variable which was improperly closed + ;; over. The PHYSENV describes a physical environment. Every + ;; variable that a form refers to should either be in its + ;; physical environment directly, or grabbed from a + ;; surrounding physical environment when it was closed over. + ;; The ASSOC expression above finds closed-over variables, so + ;; if we fell through the ASSOC expression, it wasn't closed + ;; over. Therefore, it must be in our physical environment + ;; directly. If instead it is in some other physical + ;; environment, then it's bogus for us to reference it here + ;; without it being closed over. -- WHN 2001-09-29 + (aver (eq physenv (lambda-physenv (lambda-var-home thing)))) (leaf-info thing)) (nlx-info - (assert (eq env (block-environment (nlx-info-target thing)))) + (aver (eq physenv (block-physenv (nlx-info-target thing)))) (ir2-nlx-info-home (nlx-info-info thing)))))) -;;; If Leaf already has a constant TN, return that, otherwise make a TN for it. +;;; If LEAF already has a constant TN, return that, otherwise make a +;;; TN for it. (defun constant-tn (leaf) (declare (type constant leaf)) (or (leaf-info leaf) (setf (leaf-info leaf) (make-constant-tn leaf)))) -;;; Return a TN that represents the value of Leaf, or NIL if Leaf isn't -;;; directly represented by a TN. Env is the environment that the reference is -;;; done in. +;;; Return a TN that represents the value of LEAF, or NIL if LEAF +;;; isn't directly represented by a TN. ENV is the environment that +;;; the reference is done in. (defun leaf-tn (leaf env) - (declare (type leaf leaf) (type environment env)) + (declare (type leaf leaf) (type physenv env)) (typecase leaf (lambda-var (unless (lambda-var-indirect leaf) - (find-in-environment leaf env))) + (find-in-physenv leaf env))) (constant (constant-tn leaf)) (t nil))) -;;; Used to conveniently get a handle on a constant TN during IR2 -;;; conversion. Returns a constant TN representing the Lisp object Value. +;;; This is used to conveniently get a handle on a constant TN during +;;; IR2 conversion. It returns a constant TN representing the Lisp +;;; object VALUE. (defun emit-constant (value) (constant-tn (find-constant value))) -;;; Convert a Ref node. The reference must not be delayed. +;;; 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)) (leaf (ref-leaf node)) - (name (leaf-name leaf)) (locs (continuation-result-tns cont (list (primitive-type (leaf-type leaf))))) (res (first locs))) (etypecase leaf (lambda-var - (let ((tn (find-in-environment leaf (node-environment node)))) + (let ((tn (find-in-physenv leaf (node-physenv node)))) (if (lambda-var-indirect leaf) (vop value-cell-ref node block tn res) (emit-move node block tn res)))) (constant (if (legal-immediate-constant-p leaf) (emit-move node block (constant-tn leaf) res) - (let ((name-tn (emit-constant name))) + (let* ((name (leaf-source-name leaf)) + (name-tn (emit-constant name))) (if (policy node (zerop safety)) (vop fast-symbol-value node block name-tn res) (vop symbol-value node block name-tn res))))) (functional (ir2-convert-closure node block leaf res)) (global-var - (let ((unsafe (policy node (zerop safety)))) + (let ((unsafe (policy node (zerop safety))) + (name (leaf-source-name leaf))) (ecase (global-var-kind leaf) - ((:special :global :constant) - (assert (symbolp name)) + ((:special :global) + (aver (symbolp name)) (let ((name-tn (emit-constant name))) (if unsafe (vop fast-symbol-value node block name-tn res) @@ -125,54 +146,94 @@ (:global-function (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) (if unsafe - (vop fdefn-function node block fdefn-tn res) - (vop safe-fdefn-function node block fdefn-tn res)))))))) + (vop fdefn-fun node block fdefn-tn res) + (vop safe-fdefn-fun node block fdefn-tn res)))))))) (move-continuation-result node block locs cont)) (values)) -;;; Emit code to load a function object representing Leaf 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. +;;; Emit code to load a function object implementing FUN 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. ;;; -;;; Leaf is either a :TOP-LEVEL-XEP functional or the XEP lambda for the called -;;; function, since local call analysis converts all closure references. If a -;;; TL-XEP, we know it is not a closure. +;;; 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. ;;; -;;; 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 (node block leaf res) - (declare (type ref node) (type ir2-block block) - (type functional leaf) (type tn res)) - (unless (leaf-info leaf) - (setf (leaf-info leaf) (make-entry-info))) - (let ((entry (make-load-time-constant-tn :entry leaf)) - (closure (etypecase leaf +;;; 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 (clambda - (environment-closure (get-lambda-environment leaf))) + + ;; 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))) (functional - (assert (eq (functional-kind leaf) :top-level-xep)) + (aver (eq (functional-kind fun) :toplevel-xep)) nil)))) + (cond (closure - (let ((this-env (node-environment node))) - (vop make-closure node block entry (length closure) res) + (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 node block + (vop closure-init ref ir2-block res - (find-in-environment what this-env) + (find-in-physenv what this-env) n))))) (t - (emit-move node block entry res)))) + (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 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. (defun ir2-convert-set (node block) (declare (type cset node) (type ir2-block block)) (let* ((cont (node-cont node)) @@ -185,15 +246,15 @@ (etypecase leaf (lambda-var (when (leaf-refs leaf) - (let ((tn (find-in-environment leaf (node-environment node)))) + (let ((tn (find-in-physenv leaf (node-physenv node)))) (if (lambda-var-indirect leaf) (vop value-cell-set node block tn val) (emit-move node block val tn))))) (global-var (ecase (global-var-kind leaf) ((:special :global) - (assert (symbolp (leaf-name leaf))) - (vop set node block (emit-constant (leaf-name leaf)) val))))) + (aver (symbolp (leaf-source-name leaf))) + (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))) @@ -201,16 +262,17 @@ ;;;; 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 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. ;;; -;;; 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. +;;; 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)) @@ -218,18 +280,18 @@ (ecase (ir2-continuation-kind 2cont) (:delayed (let ((ref (continuation-use cont))) - (leaf-tn (ref-leaf ref) (node-environment ref)))) + (leaf-tn (ref-leaf ref) (node-physenv ref)))) (:fixed - (assert (= (length (ir2-continuation-locs 2cont)) 1)) + (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) - (assert (eq check :simple)) + (aver (eq check :simple)) ;; If the proven type is a subtype of the possibly - ;; weakened type check then it's always True and is + ;; weakened type check then it's always true and is ;; flushed. (unless (values-subtypep (continuation-proven-type cont) (first types)) @@ -243,61 +305,62 @@ (emit-move node block cont-tn temp) temp))))) -;;; 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 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. ;;; -;;; If the continuation 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. +;;; If the continuation 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) (declare (type node node) (type ir2-block block) (type continuation cont) (list ptypes)) (let* ((locs (ir2-continuation-locs (continuation-info cont))) (nlocs (length locs))) - (assert (= nlocs (length ptypes))) + (aver (= nlocs (length ptypes))) (if (eq (continuation-type-check cont) t) (multiple-value-bind (check types) (continuation-check-types cont) - (assert (eq check :simple)) + (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)) + (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))) + (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 -;;; 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. +;;; 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. ;;; -;;; 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 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 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 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))) @@ -315,10 +378,10 @@ (unless (eq (tn-primitive-type (car loc)) (car type)) (return nil)))) locs - (mapcar #'(lambda (loc type) - (if (eq (tn-primitive-type loc) type) - loc - (make-normal-tn type))) + (mapcar (lambda (loc type) + (if (eq (tn-primitive-type loc) type) + loc + (make-normal-tn type))) (if (< nlocs ntypes) (append locs (mapcar #'make-normal-tn @@ -333,18 +396,19 @@ (declare (type unsigned-byte n)) (collect ((res)) (dotimes (i n) - (res (standard-argument-location i))) + (res (standard-arg-location i))) (res))) -;;; 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. +;;; 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. ;;; ;;; If the continuation 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 continuation is annotated, then it must be :FIXED. (defun standard-result-tns (cont) (declare (type continuation cont)) (let ((2cont (continuation-info cont))) @@ -354,16 +418,16 @@ (make-standard-value-tns (length (ir2-continuation-locs 2cont))))) ()))) -;;; Just move each Src TN into the corresponding Dest TN, defaulting any -;;; unsupplied source values to NIL. We let Emit-Move worry about doing the -;;; appropriate coercions. +;;; Just move each SRC TN into the corresponding DEST TN, defaulting +;;; any unsupplied source values to NIL. We let EMIT-MOVE worry about +;;; doing the appropriate coercions. (defun move-results-coerced (node block src dest) (declare (type node node) (type ir2-block block) (list src dest)) (let ((nsrc (length src)) (ndest (length dest))) - (mapc #'(lambda (from to) - (unless (eq from to) - (emit-move node block from to))) + (mapc (lambda (from to) + (unless (eq from to) + (emit-move node block from to))) (if (> ndest nsrc) (append src (make-list (- ndest nsrc) :initial-element (emit-constant nil))) @@ -371,15 +435,16 @@ dest)) (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 number of TNs. +;;; 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 +;;; 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 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) (declare (type node node) (type ir2-block block) (list results) (type continuation cont)) @@ -403,11 +468,11 @@ ;;;; 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) +;;; 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-args (node block args template) (declare (type node node) (type ir2-block block) (list args) (type template template)) (collect ((info-args)) @@ -428,14 +493,15 @@ (values (the (or tn-ref null) first) (info-args))))) -;;; Convert a conditional template. We try to exploit any drop-through, but -;;; emit an unconditional branch afterward if we fail. Not-P is true if the -;;; sense of the Template's test should be negated. +;;; Convert a conditional template. We try to exploit any +;;; drop-through, but emit an unconditional branch afterward if we +;;; fail. NOT-P is true if the sense of the TEMPLATE's test should be +;;; negated. (defun ir2-convert-conditional (node block template args info-args if not-p) (declare (type node node) (type ir2-block block) (type template template) (type (or tn-ref null) args) (list info-args) (type cif if) (type boolean not-p)) - (assert (= (template-info-arg-count template) (+ (length info-args) 2))) + (aver (= (template-info-arg-count template) (+ (length info-args) 2))) (let ((consequent (if-consequent if)) (alternative (if-alternative if))) (cond ((drop-thru-p if consequent) @@ -459,15 +525,16 @@ 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 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. +;;; CONTINUATION-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) (type template template) (list rtypes)) (let* ((dtype (node-derived-type call)) - (type (if (and (or (eq (template-policy template) :safe) + (type (if (and (or (eq (template-ltn-policy template) :safe) (policy call (= safety 0))) (continuation-type-check cont)) (values-type-intersection @@ -490,11 +557,11 @@ (t 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. +;;; 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) (type template template) (list rtypes)) @@ -518,32 +585,33 @@ cont (find-template-result-types call cont template rtypes))))) -;;; Get the operands into TNs, make TN-Refs for them, and then call the -;;; template emit function. +;;; 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)) (rtypes (template-result-types template))) (multiple-value-bind (args info-args) - (reference-arguments call block (combination-args call) template) - (assert (not (template-more-results-type 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)) (r-refs (reference-tn-list results t))) - (assert (= (length info-args) - (template-info-arg-count template))) + (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))))) (values)) -;;; We don't have to do much because operand count checking is done by IR1 -;;; conversion. The only difference between this and the function case of -;;; IR2-Convert-Template is that there can be codegen-info arguments. +;;; We don't have to do much because operand count checking is done by +;;; IR1 conversion. The only difference between this and the function +;;; 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)) @@ -552,11 +620,10 @@ (results (make-template-result-tns call cont template rtypes)) (r-refs (reference-tn-list results t))) (multiple-value-bind (args info-args) - (reference-arguments call block (cddr (combination-args call)) - template) - (assert (not (template-more-results-type template))) - (assert (not (eq rtypes :conditional))) - (assert (null info-args)) + (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)) (if info (emit-template call block template args r-refs info) @@ -567,42 +634,44 @@ ;;;; local call -;;; Convert a let by moving the argument values into the variables. Since a -;;; a let doesn't have any passing locations, we move the arguments directly -;;; into the variables. We must also allocate any indirect value cells, since -;;; there is no function prologue to do this. +;;; Convert a LET by moving the argument values into the variables. +;;; Since a LET doesn't have any passing locations, we move the +;;; arguments directly into the variables. We must also allocate any +;;; indirect value cells, since there is no function prologue to do +;;; this. (defun ir2-convert-let (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (mapc #'(lambda (var arg) - (when arg - (let ((src (continuation-tn node block arg)) - (dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) + (mapc (lambda (var arg) + (when arg + (let ((src (continuation-tn node block arg)) + (dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest))))) (lambda-vars fun) (basic-combination-args node)) (values)) -;;; Emit any necessary moves into assignment temps for a local call to Fun. -;;; We return two lists of TNs: TNs holding the actual argument values, and -;;; (possibly EQ) TNs that are the actual destination of the arguments. When -;;; necessary, we allocate temporaries for arguments to preserve parallel -;;; assignment semantics. These lists exclude unused arguments and include -;;; implicit environment arguments, i.e. they exactly correspond to the -;;; arguments passed. +;;; Emit any necessary moves into assignment temps for a local call to +;;; FUN. We return two lists of TNs: TNs holding the actual argument +;;; values, and (possibly EQ) TNs that are the actual destination of +;;; the arguments. When necessary, we allocate temporaries for +;;; arguments to preserve parallel assignment semantics. These lists +;;; exclude unused arguments and include implicit environment +;;; arguments, i.e. they exactly correspond to the arguments passed. ;;; -;;; OLD-FP is the TN currently holding the value we want to pass as OLD-FP. If -;;; null, then the call is to the same environment (an :ASSIGNMENT), so we -;;; only move the arguments, and leave the environment alone. +;;; OLD-FP is the TN currently holding the value we want to pass as +;;; OLD-FP. If null, then the call is to the same environment (an +;;; :ASSIGNMENT), so we only move the arguments, and leave the +;;; environment alone. (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 (environment-info (lambda-environment fun))) - (this-1env (node-environment node)) - (actuals (mapcar #'(lambda (x) - (when x - (continuation-tn node block x))) - (combination-args node)))) + (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)))) (collect ((temps) (locs)) (dolist (var (lambda-vars fun)) @@ -624,53 +693,53 @@ (locs loc)))) (when old-fp - (dolist (thing (ir2-environment-environment called-env)) - (temps (find-in-environment (car thing) this-1env)) + (dolist (thing (ir2-physenv-closure called-env)) + (temps (find-in-physenv (car thing) this-1env)) (locs (cdr thing))) (temps old-fp) - (locs (ir2-environment-old-fp called-env))) + (locs (ir2-physenv-old-fp called-env))) (values (temps) (locs))))) -;;; A tail-recursive local call is done by emitting moves of stuff into the -;;; appropriate passing locations. After setting up the args and environment, -;;; we just move our return-pc into the called function's passing -;;; location. +;;; A tail-recursive local call is done by emitting moves of stuff +;;; into the appropriate passing locations. After setting up the args +;;; and environment, we just move our return-pc into the called +;;; function's passing location. (defun ir2-convert-tail-local-call (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (let ((this-env (environment-info (node-environment node)))) + (let ((this-env (physenv-info (node-physenv node)))) (multiple-value-bind (temps locs) - (emit-psetq-moves node block fun (ir2-environment-old-fp this-env)) + (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) - (mapc #'(lambda (temp loc) - (emit-move node block temp loc)) + (mapc (lambda (temp loc) + (emit-move node block temp loc)) temps locs)) (emit-move node block - (ir2-environment-return-pc this-env) - (ir2-environment-return-pc-pass - (environment-info - (lambda-environment fun))))) + (ir2-physenv-return-pc this-env) + (ir2-physenv-return-pc-pass + (physenv-info + (lambda-physenv fun))))) (values)) ;;; Convert an :ASSIGNMENT call. This is just like a tail local call, -;;; except that the caller and callee environment are the same, so we don't -;;; need to mess with the environment locations, return PC, etc. +;;; except that the caller and callee environment are the same, so we +;;; don't need to mess with the environment locations, return PC, etc. (defun ir2-convert-assignment (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) (multiple-value-bind (temps locs) (emit-psetq-moves node block fun nil) - (mapc #'(lambda (temp loc) - (emit-move node block temp loc)) + (mapc (lambda (temp loc) + (emit-move node block temp loc)) temps locs)) (values)) -;;; Do stuff to set up the arguments to a non-tail local call (including -;;; implicit environment args.) We allocate a frame (returning the FP and -;;; NFP), and also compute the TN-Refs list for the values to pass and the list -;;; of passing location TNs. +;;; Do stuff to set up the arguments to a non-tail local call +;;; (including implicit environment args.) We allocate a frame +;;; (returning the FP and NFP), and also compute the TN-REFS list for +;;; the values to pass and the list of passing location TNs. (defun ir2-convert-local-call-args (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) (let ((fp (make-stack-pointer-tn)) @@ -680,12 +749,12 @@ (emit-psetq-moves node block fun old-fp) (vop current-fp node block old-fp) (vop allocate-frame node block - (environment-info (lambda-environment fun)) + (physenv-info (lambda-physenv fun)) fp nfp) (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. +;;; 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) (declare (type node node) (type ir2-block block) (type clambda fun) (type return-info returns) (type continuation cont) @@ -696,27 +765,27 @@ (vop* known-call-local node block (fp nfp (reference-tn-list temps nil)) ((reference-tn-list locs t)) - arg-locs (environment-info (lambda-environment fun)) start) + arg-locs (physenv-info (lambda-physenv fun)) start) (move-continuation-result node block locs cont))) (values)) ;;; Handle a non-TR unknown-values local call. We do different things ;;; depending on what kind of values the continuation 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 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. ;;; -;;; 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. +;;; 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) (declare (type node node) (type ir2-block block) (type clambda fun) (type continuation cont) (type label start)) (multiple-value-bind (fp nfp temps arg-locs) (ir2-convert-local-call-args node block fun) (let ((2cont (continuation-info cont)) - (env (environment-info (lambda-environment fun))) + (env (physenv-info (lambda-physenv fun))) (temp-refs (reference-tn-list temps nil))) (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) (vop* multiple-call-local node block (fp nfp temp-refs) @@ -730,10 +799,10 @@ (move-continuation-result node block locs cont))))) (values)) -;;; Dispatch to the appropriate function, depending on whether we have a -;;; let, tail or normal call. If the function doesn't return, call it using -;;; the unknown-value convention. We could compile it as a tail call, but that -;;; might seem confusing in the debugger. +;;; Dispatch to the appropriate function, depending on whether we have +;;; a let, tail or normal call. If the function doesn't return, call +;;; it using the unknown-value convention. We could compile it as a +;;; 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)))) @@ -745,7 +814,7 @@ ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (let ((start (block-label (node-block (lambda-bind fun)))) + (let ((start (block-label (lambda-block fun))) (returns (tail-set-info (lambda-tail-set fun))) (cont (node-cont node))) (ecase (if returns @@ -760,45 +829,46 @@ ;;;; 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 function-continuation-tn (node block cont) +;;; 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-function-name cont t))) - (assert name) + (let ((name (continuation-fun-name cont t))) + (aver name) (values (make-load-time-constant-tn :fdefinition name) t)) (let* ((locs (ir2-continuation-locs 2cont)) (loc (first locs)) (check (continuation-type-check cont)) (function-ptype (primitive-type-or-lose 'function))) - (assert (and (eq (ir2-continuation-kind 2cont) :fixed) - (= (length locs) 1))) + (aver (and (eq (ir2-continuation-kind 2cont) :fixed) + (= (length locs) 1))) (cond ((eq (tn-primitive-type loc) function-ptype) - (assert (not (eq check t))) + (aver (not (eq check t))) (values loc nil)) (t (let ((temp (make-normal-tn function-ptype))) - (assert (and (eq (ir2-continuation-primitive-type 2cont) - function-ptype) - (eq check t))) + (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 list -;;; for the passing locations. +;;; 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)) (let ((args (basic-combination-args node)) (last nil) (first nil)) (dotimes (num (length args)) - (let ((loc (standard-argument-location num))) + (let ((loc (standard-arg-location num))) (emit-move node block (continuation-tn node block (elt args num)) loc) (let ((ref (reference-tn loc nil))) (if last @@ -807,19 +877,19 @@ (setq last ref)))) first)) -;;; Move the arguments into the passing locations and do a (possibly named) -;;; tail call. +;;; Move the arguments into the passing locations and do a (possibly +;;; named) tail call. (defun ir2-convert-tail-full-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((env (environment-info (node-environment node))) + (let* ((env (physenv-info (node-physenv node))) (args (basic-combination-args node)) (nargs (length args)) (pass-refs (move-tail-full-call-args node block)) - (old-fp (ir2-environment-old-fp env)) - (return-pc (ir2-environment-return-pc env))) + (old-fp (ir2-physenv-old-fp env)) + (return-pc (ir2-physenv-return-pc env))) (multiple-value-bind (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) + (fun-continuation-tn node block (basic-combination-fun node)) (if named (vop* tail-call-named node block (fun-tn old-fp return-pc pass-refs) @@ -832,7 +902,7 @@ (values)) -;;; Like IR2-CONVERT-LOCAL-CALL-ARGS, only different. +;;; like IR2-CONVERT-LOCAL-CALL-ARGS, only different (defun ir2-convert-full-call-args (node block) (declare (type combination node) (type ir2-block block)) (let* ((args (basic-combination-args node)) @@ -843,7 +913,7 @@ (let ((last nil) (first nil)) (dotimes (num nargs) - (locs (standard-argument-location num)) + (locs (standard-arg-location num)) (let ((ref (reference-tn (continuation-tn node block (elt args num)) nil))) (if last @@ -854,8 +924,9 @@ (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 continuation, then deliver the result +;;; using MOVE-CONTINUATION-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) @@ -865,7 +936,7 @@ (loc-refs (reference-tn-list locs t)) (nvals (length locs))) (multiple-value-bind (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) + (fun-continuation-tn node block (basic-combination-fun node)) (if named (vop* call-named node block (fp fun-tn args) (loc-refs) arg-locs nargs nvals) @@ -883,7 +954,7 @@ (locs (ir2-continuation-locs (continuation-info cont))) (loc-refs (reference-tn-list locs t))) (multiple-value-bind (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) + (fun-continuation-tn node block (basic-combination-fun node)) (if named (vop* multiple-call-named node block (fp fun-tn args) (loc-refs) arg-locs nargs) @@ -891,6 +962,29 @@ arg-locs nargs))))) (values)) +;;; stuff to check in CHECK-FULL-CALL +;;; +;;; There are some things which are intended always to be optimized +;;; away by DEFTRANSFORMs and such, and so never compiled into full +;;; calls. This has been a source of bugs so many times that it seems +;;; worth listing some of them here so that we can check the list +;;; whenever we compile a full call. +;;; +;;; FIXME: It might be better to represent this property by setting a +;;; flag in DEFKNOWN, instead of representing it by membership in this +;;; 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. + %instance-ref + ;; These should always turn into VOPs, but wasn't in a bug which + ;; appeared when LTN-POLICY stuff was being tweaked in + ;; sbcl-0.6.9.16. in sbcl-0.6.0 + data-vector-set + data-vector-ref)) + +;;; more stuff to check in CHECK-FULL-CALL +;;; ;;; These came in handy when troubleshooting cold boot after making ;;; major changes in the package structure: various transforms and ;;; VOPs and stuff got attached to the wrong symbol, so that @@ -901,15 +995,14 @@ #!+sb-show (defvar *show-full-called-fnames-p* nil) #!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal)) -;;; 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 -;;; values are desired, then use a single-value call, otherwise use a -;;; multiple-values call. -(defun ir2-convert-full-call (node block) - (declare (type combination node) (type ir2-block block)) - +;;; Do some checks on a full call: +;;; * Is this a full call to something we have reason to know should +;;; never be full called? +;;; * 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-function-name cont t))) + (fname (continuation-fun-name cont t))) (declare (type (or symbol cons) fname)) #!+sb-show (unless (gethash fname *full-called-fnames*) @@ -917,6 +1010,8 @@ #!+sb-show (when *show-full-called-fnames-p* (/show "converting full call to named function" fname) (/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 (type-specifier @@ -925,11 +1020,23 @@ (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 (consp fname) (destructuring-bind (setf stem) fname - (assert (eq setf 'setf)) - (setf (gethash stem *setf-assumed-fboundp*) t)))) + (aver (eq setf 'setf)) + (setf (gethash 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 +;;; values are desired, then use a single-value call, otherwise use a +;;; 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)) @@ -938,22 +1045,21 @@ (ir2-convert-multiple-full-call node block)) (t (ir2-convert-fixed-full-call node block)))) - (values)) ;;;; entering functions ;;; Do all the stuff that needs to be done on XEP entry: -;;; -- Create frame -;;; -- Copy any more arg -;;; -- Set up the environment, accessing any closure variables +;;; -- Create frame. +;;; -- Copy any more arg. +;;; -- Set up the environment, accessing any closure variables. ;;; -- Move args from the standard passing locations to their internal ;;; locations. (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) (let ((start-label (entry-info-offset (leaf-info fun))) - (env (environment-info (node-environment node)))) - (let ((ef (functional-entry-function fun))) + (env (physenv-info (node-physenv node)))) + (let ((ef (functional-entry-fun fun))) (cond ((and (optional-dispatch-p ef) (optional-dispatch-more-entry ef)) ;; Special case the xep-allocate-frame + copy-more-arg case. (vop xep-allocate-frame node block start-label t) @@ -961,25 +1067,25 @@ (t ;; No more args, so normal entry. (vop xep-allocate-frame node block start-label nil))) - (if (ir2-environment-environment env) + (if (ir2-physenv-closure env) (let ((closure (make-normal-tn *backend-t-primitive-type*))) (vop setup-closure-environment node block start-label closure) (when (getf (functional-plist ef) :fin-function) (vop funcallable-instance-lexenv node block closure closure)) (let ((n -1)) - (dolist (loc (ir2-environment-environment env)) + (dolist (loc (ir2-physenv-closure env)) (vop closure-ref node block closure (incf n) (cdr loc))))) (vop setup-environment node block start-label))) - (unless (eq (functional-kind fun) :top-level) + (unless (eq (functional-kind fun) :toplevel) (let ((vars (lambda-vars fun)) (n 0)) (when (leaf-refs (first vars)) - (emit-move node block (make-argument-count-location) + (emit-move node block (make-arg-count-location) (leaf-info (first vars)))) (dolist (arg (rest vars)) (when (leaf-refs arg) - (let ((pass (standard-argument-location n)) + (let ((pass (standard-arg-location n)) (home (leaf-info arg))) (if (lambda-var-indirect arg) (do-make-value-cell node block pass home) @@ -987,36 +1093,38 @@ (incf n)))) (emit-move node block (make-old-fp-passing-location t) - (ir2-environment-old-fp env))) + (ir2-physenv-old-fp env))) (values)) ;;; Emit function prolog code. This is only called on bind nodes for -;;; functions that allocate environments. All semantics of let calls are -;;; handled by IR2-Convert-Let. +;;; functions that allocate environments. All semantics of let calls +;;; are handled by IR2-CONVERT-LET. ;;; ;;; If not an XEP, all we do is move the return PC from its passing -;;; location, since in a local call, the caller allocates the frame and sets up -;;; the arguments. +;;; location, since in a local call, the caller allocates the frame +;;; and sets up the arguments. (defun ir2-convert-bind (node block) (declare (type bind node) (type ir2-block block)) (let* ((fun (bind-lambda node)) - (env (environment-info (lambda-environment fun)))) - (assert (member (functional-kind fun) - '(nil :external :optional :top-level :cleanup))) + (env (physenv-info (lambda-physenv fun)))) + (aver (member (functional-kind fun) + '(nil :external :optional :toplevel :cleanup))) - (when (external-entry-point-p fun) + (when (xep-p fun) (init-xep-environment node block fun) #!+sb-dyncount (when *collect-dynamic-statistics* (vop count-me node block *dynamic-counts-tn* (block-number (ir2-block-block block))))) - (emit-move node block (ir2-environment-return-pc-pass env) - (ir2-environment-return-pc env)) + (emit-move node + block + (ir2-physenv-return-pc-pass env) + (ir2-physenv-return-pc env)) (let ((lab (gen-label))) - (setf (ir2-environment-environment-start env) lab) + (setf (ir2-physenv-environment-start env) lab) (vop note-environment-start node block lab))) (values)) @@ -1024,24 +1132,25 @@ ;;;; function return ;;; Do stuff to return from a function with the specified values and -;;; convention. If the return convention is :Fixed and we aren't returning -;;; from an XEP, then we do a known return (letting representation selection -;;; insert the correct move-arg VOPs.) Otherwise, we use the unknown-values -;;; convention. If there is a fixed number of return values, then use Return, -;;; otherwise use Return-Multiple. +;;; convention. If the return convention is :FIXED and we aren't +;;; returning from an XEP, then we do a known return (letting +;;; representation selection insert the correct move-arg VOPs.) +;;; Otherwise, we use the unknown-values convention. If there is a +;;; fixed number of return values, then use RETURN, otherwise use +;;; 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)) (fun (return-lambda node)) - (env (environment-info (lambda-environment fun))) - (old-fp (ir2-environment-old-fp env)) - (return-pc (ir2-environment-return-pc env)) + (env (physenv-info (lambda-physenv fun))) + (old-fp (ir2-physenv-old-fp env)) + (return-pc (ir2-physenv-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) (cond ((and (eq (return-info-kind returns) :fixed) - (not (external-entry-point-p fun))) + (not (xep-p fun))) (let ((locs (continuation-tns node block cont (return-info-types returns)))) (vop* known-return node block @@ -1053,8 +1162,8 @@ (cont-locs (continuation-tns node block cont types)) (nvals (length cont-locs)) (locs (make-standard-value-tns nvals))) - (mapc #'(lambda (val loc) - (emit-move node block val loc)) + (mapc (lambda (val loc) + (emit-move node block val loc)) cont-locs locs) (if (= nvals 1) @@ -1064,7 +1173,7 @@ (nil) nvals)))) (t - (assert (eq cont-kind :unknown)) + (aver (eq cont-kind :unknown)) (vop* return-multiple node block (old-fp return-pc (reference-tn-list (ir2-continuation-locs 2cont) nil)) @@ -1074,49 +1183,49 @@ ;;;; debugger hooks -;;; This is used by the debugger to find the top function on the stack. It -;;; returns the OLD-FP and RETURN-PC for the current function as multiple -;;; values. +;;; This is used by the debugger to find the top function on the +;;; stack. It returns the OLD-FP and RETURN-PC for the current +;;; function as multiple values. (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) - (let ((env (environment-info (node-environment node)))) + (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-continuation-result node block - (list (ir2-environment-old-fp env) - (ir2-environment-return-pc env)) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) (node-cont node)))) ;;;; multiple values -;;; 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 continuation for the correct number of values (with the +;;; continuation user responsible for defaulting), we can just pick +;;; them up from the continuation. (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)))) (vars (lambda-vars fun))) - (assert (eq (functional-kind fun) :mv-let)) - (mapc #'(lambda (src var) - (when (leaf-refs var) - (let ((dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) + (aver (eq (functional-kind fun) :mv-let)) + (mapc (lambda (src var) + (when (leaf-refs var) + (let ((dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest))))) (continuation-tns node block cont - (mapcar #'(lambda (x) - (primitive-type (leaf-type x))) + (mapcar (lambda (x) + (primitive-type (leaf-type x))) vars)) vars)) (values)) ;;; 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 ignored. This -;;; is because we require all of the values globs to be contiguous and on stack -;;; top. +;;; CALL-VARIABLE. Note that we only need to pass the values start for +;;; the first argument: all the other argument continuation 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)) - (assert (basic-combination-args node)) + (aver (basic-combination-args node)) (let* ((start-cont (continuation-info (first (basic-combination-args node)))) (start (first (ir2-continuation-locs start-cont))) (tails (and (node-tail-p node) @@ -1124,15 +1233,15 @@ (cont (node-cont node)) (2cont (continuation-info cont))) (multiple-value-bind (fun named) - (function-continuation-tn node block (basic-combination-fun node)) - (assert (and (not named) - (eq (ir2-continuation-kind start-cont) :unknown))) + (fun-continuation-tn node block (basic-combination-fun node)) + (aver (and (not named) + (eq (ir2-continuation-kind start-cont) :unknown))) (cond (tails - (let ((env (environment-info (node-environment node)))) + (let ((env (physenv-info (node-physenv node)))) (vop tail-call-variable node block start fun - (ir2-environment-old-fp env) - (ir2-environment-return-pc env)))) + (ir2-physenv-old-fp env) + (ir2-physenv-return-pc env)))) ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) (vop* multiple-call-variable node block (start fun nil) @@ -1143,26 +1252,28 @@ ((reference-tn-list locs t)) (length locs)) (move-continuation-result node block locs cont))))))) -;;; Reset the stack pointer to the start of the specified unknown-values -;;; continuation (discarding it and all values globs on top of it.) +;;; 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)))) - (assert (eq (ir2-continuation-kind 2cont) :unknown)) + (aver (eq (ir2-continuation-kind 2cont) :unknown)) (vop reset-stack-pointer node block (first (ir2-continuation-locs 2cont))))) -;;; Deliver the values TNs to Cont using Move-Continuation-Result. +;;; Deliver the values TNs to CONT using MOVE-CONTINUATION-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) - (let ((tns (mapcar #'(lambda (x) - (continuation-tn node block x)) + (let ((tns (mapcar (lambda (x) + (continuation-tn node block x)) values))) (move-continuation-result node block tns (node-cont node)))) ;;; In the normal case where unknown values are desired, we use the -;;; Values-List VOP. In the relatively unimportant case of Values-List for a -;;; fixed number of values, we punt by doing a full call to the Values-List -;;; function. This gets the full call VOP to deal with defaulting any -;;; unsupplied values. It seems unworthwhile to optimize this case. +;;; VALUES-LIST VOP. In the relatively unimportant case of VALUES-LIST +;;; for a fixed number of values, we punt by doing a full call to the +;;; VALUES-LIST function. This gets the full call VOP to deal with +;;; 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))) @@ -1192,43 +1303,43 @@ ;;;; special binding -;;; Trivial, given our assumption of a shallow-binding implementation. +;;; This is trivial, given our assumption of a shallow-binding +;;; implementation. (defoptimizer (%special-bind ir2-convert) ((var value) node block) - (let ((name (leaf-name (continuation-value var)))) + (let ((name (leaf-source-name (continuation-value var)))) (vop bind node block (continuation-tn node block value) (emit-constant name)))) (defoptimizer (%special-unbind ir2-convert) ((var) node block) (vop unbind node block)) -;;; ### Not clear that this really belongs in this file, or 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. +;;; ### It's not clear that this really belongs in this file, or +;;; 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) (ir1-convert start cont - (if (or *converting-for-interpreter* (byte-compiling)) - `(%progv ,vars ,vals #'(lambda () ,@body)) - (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)))))) + (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))))) ;;;; non-local exit ;;; 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. +;;; 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-environment (find-nlx-info (exit-entry node) - (node-cont node)) - (node-environment node))) + (let ((loc (find-in-physenv (find-nlx-info (exit-entry node) + (node-cont node)) + (node-physenv node))) (temp (make-stack-pointer-tn)) (value (exit-value node))) (vop value-cell-ref node block loc temp) @@ -1240,20 +1351,20 @@ (values)) -;;; Cleanup-point doesn't to anything except prevent the body from being -;;; entirely deleted. +;;; %CLEANUP-POINT doesn't do anything except prevent the body from +;;; being entirely deleted. (defoptimizer (%cleanup-point ir2-convert) (() node block) node block) -;;; This function invalidates a lexical exit on exiting from the dynamic -;;; extent. This is done by storing 0 into the indirect value cell that holds -;;; the closed unwind block. +;;; This function invalidates a lexical exit on exiting from the +;;; 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-environment (continuation-value info) (node-environment node)) + (find-in-physenv (continuation-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 +;;; continuation 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))) @@ -1263,22 +1374,21 @@ (ir2-continuation-locs (continuation-info (second args))) nil)) (nil))) - (move-continuation-result node block () (node-cont 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 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. (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)) (let* ((2info (nlx-info-info info)) (kind (cleanup-kind (nlx-info-cleanup info))) - (block-tn (environment-live-tn + (block-tn (physenv-live-tn (make-normal-tn (primitive-type-or-lose 'catch-block)) - (node-environment node))) + (node-physenv node))) (res (make-stack-pointer-tn)) (target-label (ir2-nlx-info-target 2info))) @@ -1305,7 +1415,7 @@ (values)) -;;; Scan each of Entry's exits, setting up the exit for each lexical exit. +;;; 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)) @@ -1322,33 +1432,34 @@ (defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block) (emit-nlx-start node block (continuation-value info-cont) nil)) -;;; Emit the entry code for a non-local exit. We receive values and restore -;;; dynamic state. +;;; 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 +;;; 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 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. +;;; 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. ;;; ;;; 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. +;;; 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)) (2info (nlx-info-info info)) (top-loc (ir2-nlx-info-save-sp 2info)) - (start-loc (make-nlx-entry-argument-start-location)) - (count-loc (make-argument-count-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)) @@ -1366,7 +1477,7 @@ (length locs)) (move-continuation-result node block locs cont)))) (:unwind-protect - (let ((block-loc (standard-argument-location 0))) + (let ((block-loc (standard-arg-location 0))) (vop uwp-entry node block target block-loc start-loc count-loc) (move-continuation-result node block @@ -1386,7 +1497,7 @@ ;;;; n-argument functions -(macrolet ((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)) @@ -1396,40 +1507,8 @@ (vop* ,name node block (refs) ((first res) nil) (length args)) (move-continuation-result node block res cont))))) - (frob list) - (frob list*)) - -;;;; structure accessors -;;;; -;;;; These guys have to bizarrely determine the slot offset by looking at the -;;;; called function. - -(defoptimizer (%slot-accessor ir2-convert) ((str) node block) - (let* ((cont (node-cont node)) - (res (continuation-result-tns cont - (list *backend-t-primitive-type*)))) - (vop instance-ref node block - (continuation-tn node block str) - (dsd-index - (slot-accessor-slot - (ref-leaf - (continuation-use - (combination-fun node))))) - (first res)) - (move-continuation-result node block res cont))) - -(defoptimizer (%slot-setter ir2-convert) ((value str) node block) - (let ((val (continuation-tn node block value))) - (vop instance-set node block - (continuation-tn node block str) - val - (dsd-index - (slot-accessor-slot - (ref-leaf - (continuation-use - (combination-fun node)))))) - - (move-continuation-result node block (list val) (node-cont node)))) + (def list) + (def list*)) ;;; Convert the code in a component into VOPs. (defun ir2-convert (component) @@ -1462,9 +1541,8 @@ (when *collect-dynamic-statistics* (let ((first-node (continuation-next (block-start block)))) (unless (or (and (bind-p first-node) - (external-entry-point-p - (bind-lambda first-node))) - (eq (continuation-function-name + (xep-p (bind-lambda first-node))) + (eq (continuation-fun-name (node-cont first-node)) '%nlx-entry)) (vop count-me @@ -1477,32 +1555,35 @@ (values)) ;;; If necessary, emit a terminal unconditional branch to go to the -;;; successor block. If the successor is the component tail, then there isn't -;;; really any successor, but if the end is an unknown, non-tail call, then we -;;; emit an error trap just in case the function really does return. +;;; successor block. If the successor is the component tail, then +;;; there isn't really any successor, but if the end is an unknown, +;;; non-tail call, then we emit an error trap just in case the +;;; function really does return. (defun finish-ir2-block (block) (declare (type cblock block)) (let* ((2block (block-info block)) (last (block-last block)) (succ (block-succ block))) (unless (if-p last) - (assert (and succ (null (rest succ)))) + (aver (and succ (null (rest 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)) - (name (and (ref-p use) (leaf-name (ref-leaf use))))) + (name (and (ref-p use) + (leaf-has-source-name-p (ref-leaf use)) + (leaf-source-name (ref-leaf use))))) (unless (or (node-tail-p last) (info :function :info name) (policy last (zerop safety))) - (vop nil-function-returned-error last 2block + (vop nil-fun-returned-error last 2block (if name (emit-constant name) (multiple-value-bind (tn named) - (function-continuation-tn last 2block fun) - (assert (not named)) + (fun-continuation-tn last 2block fun) + (aver (not named)) tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) (vop branch last 2block (block-label target))))))) @@ -1528,7 +1609,7 @@ (:full (ir2-convert-full-call node 2block)) (t - (let ((fun (function-info-ir2-convert kind))) + (let ((fun (fun-info-ir2-convert kind))) (cond (fun (funcall fun node 2block)) ((eq (basic-combination-info node) :full) @@ -1550,7 +1631,7 @@ (cond ((eq (basic-combination-kind node) :local) (ir2-convert-mv-bind node 2block)) - ((eq (continuation-function-name (basic-combination-fun node)) + ((eq (continuation-fun-name (basic-combination-fun node)) '%throw) (ir2-convert-throw node 2block)) (t