X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=d722ba5471973dffe834beba4d617c2b012237fd;hb=11b8fcf55c80cb2686fb49663fa4d96f9b152ce4;hp=f00461065a05289b72633ae35116ad19f280a07e;hpb=104ee7ee303efa16e415f5e75df635ac54dba733;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index f004610..d722ba5 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -81,7 +81,8 @@ (leaf-info thing)) (nlx-info (aver (eq physenv (block-physenv (nlx-info-target thing)))) - (ir2-nlx-info-home (nlx-info-info thing)))))) + (ir2-nlx-info-home (nlx-info-info thing)))) + (bug "~@<~2I~_~S ~_not found in ~_~S~:>" thing physenv))) ;;; If LEAF already has a constant TN, return that, otherwise make a ;;; TN for it. @@ -151,69 +152,71 @@ (move-continuation-result node block locs cont)) (values)) -;;; Emit code to load a function object implementing FUN into +;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE +(defun assertions-on-ir2-converted-clambda (clambda) + ;; This assertion was sort of an experiment. It would be nice and + ;; sane and easier to understand things if it were *always* true, + ;; but experimentally I observe that it's only *almost* always + ;; true. -- WHN 2001-01-02 + #+nil + (aver (eql (lambda-component clambda) + (block-component (ir2-block-block ir2-block)))) + ;; Check for some weirdness which came up in bug + ;; 138, 2002-01-02. + ;; + ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts an :ENTRY record + ;; into the IR2-COMPONENT-CONSTANTS table. The dump-a-COMPONENT + ;; code + ;; * treats every HANDLEless :ENTRY record into a + ;; patch, and + ;; * expects every patch to correspond to an + ;; IR2-COMPONENT-ENTRIES record. + ;; The IR2-COMPONENT-ENTRIES records are set by ENTRY-ANALYZE + ;; walking over COMPONENT-LAMBDAS. Bug 138b arose because there + ;; was a HANDLEless :ENTRY record which didn't correspond to an + ;; IR2-COMPONENT-ENTRIES record. That problem is hard to debug + ;; when it's caught at dump time, so this assertion tries to catch + ;; it here. + (aver (member clambda + (component-lambdas (lambda-component clambda)))) + ;; another bug-138-related issue: COMPONENT-NEW-FUNCTIONALS is + ;; used as a queue for stuff pending to do in IR1, and now that + ;; we're doing IR2 it should've been completely flushed (but + ;; wasn't). + (aver (null (component-new-functionals (lambda-component clambda)))) + (values)) + +;;; Emit code to load a function object implementing FUNCTIONAL into ;;; RES. This gets interesting when the referenced function is a ;;; closure: we must make the closure and move the closed-over values ;;; into it. ;;; -;;; FUN is either a :TOPLEVEL-XEP functional or the XEP lambda for the -;;; called function, since local call analysis converts all closure -;;; references. If a :TOPLEVEL-XEP, we know it is not a closure. +;;; FUNCTIONAL is either a :TOPLEVEL-XEP functional or the XEP lambda +;;; for the called function, since local call analysis converts all +;;; closure references. If a :TOPLEVEL-XEP, we know it is not a +;;; closure. ;;; ;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we ;;; don't initialize that slot. This can happen with closures over ;;; top level variables, where optimization of the closure deleted the ;;; variable. Since we committed to the closure format when we ;;; pre-analyzed the top level code, we just leave an empty slot. -(defun ir2-convert-closure (ref ir2-block fun res) - (declare (type ref ref) (type ir2-block ir2-block) - (type functional fun) (type tn res)) - - (unless (leaf-info fun) - (setf (leaf-info fun) - (make-entry-info :name (functional-debug-name fun)))) - (let ((entry (make-load-time-constant-tn :entry fun)) - (closure (etypecase fun +(defun ir2-convert-closure (ref ir2-block functional res) + (declare (type ref ref) + (type ir2-block ir2-block) + (type functional functional) + (type tn res)) + (aver (not (eql (functional-kind functional) :deleted))) + (unless (leaf-info functional) + (setf (leaf-info functional) + (make-entry-info :name (functional-debug-name functional)))) + (let ((entry (make-load-time-constant-tn :entry functional)) + (closure (etypecase functional (clambda - - ;; This assertion was sort of an experiment. It - ;; would be nice and sane and easier to understand - ;; things if it were *always* true, but - ;; experimentally I observe that it's only - ;; *almost* always true. -- WHN 2001-01-02 - #+nil - (aver (eql (lambda-component fun) - (block-component (ir2-block-block ir2-block)))) - - ;; Check for some weirdness which came up in bug - ;; 138, 2002-01-02. - ;; - ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts - ;; an :ENTRY record into the - ;; IR2-COMPONENT-CONSTANTS table. The - ;; dump-a-COMPONENT code - ;; * treats every HANDLEless :ENTRY record into a - ;; patch, and - ;; * expects every patch to correspond to an - ;; IR2-COMPONENT-ENTRIES record. - ;; The IR2-COMPONENT-ENTRIES records are set by - ;; ENTRY-ANALYZE walking over COMPONENT-LAMBDAS. - ;; Bug 138b arose because there was a HANDLEless - ;; :ENTRY record which didn't correspond to an - ;; IR2-COMPONENT-ENTRIES record. That problem is - ;; hard to debug when it's caught at dump time, so - ;; this assertion tries to catch it here. - (aver (member fun - (component-lambdas (lambda-component fun)))) - - ;; another bug-138-related issue: COMPONENT-NEW-FUNS - ;; is an IR1 temporary, and now that we're doing IR2 - ;; it should've been completely flushed (but wasn't). - (aver (null (component-new-funs (lambda-component fun)))) - - (physenv-closure (get-lambda-physenv fun))) + (assertions-on-ir2-converted-clambda functional) + (physenv-closure (get-lambda-physenv functional))) (functional - (aver (eq (functional-kind fun) :toplevel-xep)) + (aver (eq (functional-kind functional) :toplevel-xep)) nil)))) (cond (closure @@ -666,12 +669,10 @@ (defun emit-psetq-moves (node block fun old-fp) (declare (type combination node) (type ir2-block block) (type clambda fun) (type (or tn null) old-fp)) - (let* ((called-env (physenv-info (lambda-physenv fun))) - (this-1env (node-physenv node)) - (actuals (mapcar (lambda (x) - (when x - (continuation-tn node block x))) - (combination-args node)))) + (let ((actuals (mapcar (lambda (x) + (when x + (continuation-tn node block x))) + (combination-args node)))) (collect ((temps) (locs)) (dolist (var (lambda-vars fun)) @@ -693,12 +694,13 @@ (locs loc)))) (when old-fp - (dolist (thing (ir2-physenv-closure called-env)) - (temps (find-in-physenv (car thing) this-1env)) - (locs (cdr thing))) - - (temps old-fp) - (locs (ir2-physenv-old-fp called-env))) + (let ((this-1env (node-physenv node)) + (called-env (physenv-info (lambda-physenv fun)))) + (dolist (thing (ir2-physenv-closure called-env)) + (temps (find-in-physenv (car thing) this-1env)) + (locs (cdr thing))) + (temps old-fp) + (locs (ir2-physenv-old-fp called-env)))) (values (temps) (locs))))) @@ -829,12 +831,14 @@ ;;;; 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. +;;; 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))) @@ -860,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)) @@ -1023,7 +1027,7 @@ (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)) + (bug "full call to ~S" fname)) (when (consp fname) (destructuring-bind (setf stem) fname @@ -1195,7 +1199,7 @@ ;;;; 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. @@ -1331,7 +1335,7 @@ ;;;; 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. @@ -1368,6 +1372,7 @@ (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 @@ -1377,7 +1382,7 @@ (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. @@ -1428,6 +1433,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)) @@ -1497,7 +1503,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)) @@ -1507,8 +1513,8 @@ (vop* ,name node block (refs) ((first res) nil) (length args)) (move-continuation-result node block res cont))))) - (def-frob list) - (def-frob list*)) + (def list) + (def list*)) ;;; Convert the code in a component into VOPs. (defun ir2-convert (component)