X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=43b213d073df80de63679a80d711055acc9f24a1;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=95b97fd2c38c5073c1032fb46f4c651e306e1478;hpb=e2b33e0d99f0f93263defcd2e0dffe20c4e388f3;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 95b97fd..43b213d 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -46,9 +46,14 @@ ;;; Allocate an indirect value cell. Maybe do some clever stack ;;; allocation someday. -(defevent make-value-cell "Allocate heap value cell for lexical var.") +;;; +;;; 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 @@ -57,7 +62,7 @@ (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-environment (physenv-info physenv)))) + (or (cdr (assoc thing (ir2-physenv-closure (physenv-info physenv)))) (etypecase thing (lambda-var ;; I think that a failure of this assertion means that we're @@ -76,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. @@ -146,43 +152,85 @@ (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. +;;; 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. ;;; -;;; LEAF is either a :TOPLEVEL-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. +;;; 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 (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 +(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 - (physenv-closure (get-lambda-physenv leaf))) + (assertions-on-ir2-converted-clambda functional) + (physenv-closure (get-lambda-physenv functional))) (functional - (aver (eq (functional-kind leaf) :toplevel-xep)) + (aver (eq (functional-kind functional) :toplevel-xep)) nil)))) + (cond (closure - (let ((this-env (node-physenv 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-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 @@ -218,7 +266,7 @@ ;;;; 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, +;;; 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 @@ -243,7 +291,7 @@ (cond ((and (eq (continuation-type-check cont) t) (multiple-value-bind (check types) - (continuation-check-types cont) + (continuation-check-types cont nil) (aver (eq check :simple)) ;; If the proven type is a subtype of the possibly ;; weakened type check then it's always true and is @@ -275,26 +323,26 @@ (nlocs (length locs))) (aver (= nlocs (length ptypes))) (if (eq (continuation-type-check cont) t) - (multiple-value-bind (check types) (continuation-check-types cont) + (multiple-value-bind (check types) (continuation-check-types cont nil) (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)))) @@ -333,10 +381,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 @@ -351,7 +399,7 @@ (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 @@ -380,9 +428,9 @@ (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))) @@ -390,7 +438,7 @@ dest)) (values)) -;;; If necessary, emit coercion code needed to deliver the Results to +;;; 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 @@ -422,12 +470,12 @@ ;;;; template conversion -;;; Build a TN-Refs list that represents access to the values of the +;;; 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) +(defun reference-args (node block args template) (declare (type node node) (type ir2-block block) (list args) (type template template)) (collect ((info-args)) @@ -540,7 +588,7 @@ cont (find-template-result-types call cont template rtypes))))) -;;; Get the operands into TNs, make TN-Refs for them, and then call +;;; 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)) @@ -548,7 +596,7 @@ (cont (node-cont 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 @@ -575,8 +623,7 @@ (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) + (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)) @@ -597,13 +644,13 @@ ;;; 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)) @@ -622,11 +669,9 @@ (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))) + (let ((actuals (mapcar (lambda (x) + (when x + (continuation-tn node block x))) (combination-args node)))) (collect ((temps) (locs)) @@ -649,12 +694,13 @@ (locs loc)))) (when old-fp - (dolist (thing (ir2-physenv-environment 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))))) @@ -668,8 +714,8 @@ (multiple-value-bind (temps locs) (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 @@ -687,8 +733,8 @@ (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)) @@ -785,13 +831,15 @@ ;;;; 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 (VALUES TN-TO-CALL +;;; NAMED-P), where TN-TO-CALL is a TN holding the thing that we call +;;; NAMED-P is true if the thing is named (false if it is a function). +;;; +;;; There are two interesting non-named cases: +;;; -- We know it's a function. No check needed: return the +;;; continuation LOC. +;;; -- We don't know 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) @@ -816,7 +864,7 @@ (specifier-type 'function)) (values temp nil)))))))) -;;; Set up the args to Node in the current frame, and return a tn-ref +;;; 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)) @@ -824,7 +872,7 @@ (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 @@ -845,7 +893,7 @@ (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) @@ -869,7 +917,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 @@ -892,7 +940,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) @@ -910,7 +958,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) @@ -918,7 +966,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 @@ -931,7 +979,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 @@ -939,7 +987,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 @@ -951,12 +999,15 @@ #!+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) +(defun ponder-full-call (node) (let* ((cont (basic-combination-fun node)) (fname (continuation-fun-name cont t))) (declare (type (or symbol cons) fname)) @@ -976,15 +1027,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 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))))) + (destructuring-bind (setfoid &rest stem) fname + (aver (member setfoid + '(setf sb!pcl::class-predicate sb!pcl::slot-accessor))) + (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 @@ -992,7 +1051,7 @@ ;;; multiple-values call. (defun ir2-convert-full-call (node block) (declare (type combination node) (type ir2-block block)) - (check-full-call node) + (ponder-full-call node) (let ((2cont (continuation-info (node-cont node)))) (cond ((node-tail-p node) (ir2-convert-tail-full-call node block)) @@ -1023,13 +1082,13 @@ (t ;; No more args, so normal entry. (vop xep-allocate-frame node block start-label nil))) - (if (ir2-physenv-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-physenv-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))) @@ -1037,11 +1096,11 @@ (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) @@ -1067,7 +1126,7 @@ (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* @@ -1106,7 +1165,7 @@ (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 @@ -1118,8 +1177,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) @@ -1143,15 +1202,15 @@ ;;; 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 (physenv-info (node-physenv node)))) + (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-continuation-result node block - (list (ir2-physenv-old-fp env) - (ir2-physenv-return-pc env)) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) (node-cont node)))) ;;;; multiple values -;;; This is almost identical to IR2-Convert-Let. Since LTN annotates +;;; 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. @@ -1161,15 +1220,15 @@ (fun (ref-leaf (continuation-use (basic-combination-fun node)))) (vars (lambda-vars fun))) (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))))) + (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)) @@ -1189,7 +1248,7 @@ (cont (node-cont node)) (2cont (continuation-info cont))) (multiple-value-bind (fun named) - (function-continuation-tn node block (basic-combination-fun node)) + (fun-continuation-tn node block (basic-combination-fun node)) (aver (and (not named) (eq (ir2-continuation-kind start-cont) :unknown))) (cond @@ -1219,8 +1278,8 @@ ;;; 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)))) @@ -1233,14 +1292,15 @@ (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))))))))) + (cond ((and 2cont + (eq (ir2-continuation-kind 2cont) :unknown)) + (let ((locs (ir2-continuation-locs 2cont))) + (vop* values-list node block + ((continuation-tn node block list) nil) + ((reference-tn-list locs t))))) + (t (aver (or (not 2cont) ; i.e. we want to check the argument + (eq (ir2-continuation-kind 2cont) :fixed))) + (ir2-convert-full-call node block))))) (defoptimizer (%more-arg-values ir2-convert) ((context start count) node block) (let* ((cont (node-cont node)) @@ -1275,19 +1335,30 @@ (def-ir1-translator progv ((vars vals &body body) start cont) (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))))) + (let ((bind (gensym "BIND")) + (unbind (gensym "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. @@ -1324,17 +1395,17 @@ (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)) (reference-tn-list (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 +;;; 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. @@ -1385,6 +1456,7 @@ ;;; Set up the unwind block for these guys. (defoptimizer (%catch ir2-convert) ((info-cont tag) node block) + (check-catch-tag-type tag) (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)) @@ -1415,8 +1487,8 @@ (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)) @@ -1434,7 +1506,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 @@ -1454,7 +1526,7 @@ ;;;; 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)) @@ -1464,40 +1536,8 @@ (vop* ,name node block (refs) ((first res) nil) (length args)) (move-continuation-result node block res cont))))) - (def-frob list) - (def-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) @@ -1530,8 +1570,7 @@ (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))) + (xep-p (bind-lambda first-node))) (eq (continuation-fun-name (node-cont first-node)) '%nlx-entry)) @@ -1568,11 +1607,11 @@ (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) + (fun-continuation-tn last 2block fun) (aver (not named)) tn))))))) ((not (eq (ir2-block-next 2block) (block-info target))) @@ -1599,7 +1638,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)