X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=7e42924b763feb86827000bb7807db47106d6f0c;hb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;hp=06caf36d9bea4549bdf9c8d614f5aba61b72c75d;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 06caf36..7e42924 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 @@ -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,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 @@ -391,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 @@ -467,7 +475,7 @@ ;;; 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)) @@ -588,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 @@ -615,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)) @@ -662,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)) @@ -689,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))))) @@ -864,7 +870,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 @@ -909,7 +915,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 @@ -1019,7 +1025,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 @@ -1077,11 +1083,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) @@ -1191,7 +1197,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. @@ -1327,7 +1333,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. @@ -1373,7 +1379,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. @@ -1454,8 +1460,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)) @@ -1473,7 +1479,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 @@ -1493,7 +1499,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)) @@ -1503,40 +1509,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)