(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.
(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
(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))
(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)))))
\f
;;;; 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)))
(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))
(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
\f
;;;; 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.
\f
;;;; non-local exit
-;;; Convert a non-local lexical exit. First find the NLX-Info in our
+;;; Convert a non-local lexical exit. First find the NLX-INFO in our
;;; environment. Note that this is never called on the escape exits
;;; for CATCH and UNWIND-PROTECT, since the escape functions aren't
;;; IR2 converted.
(defun ir2-convert-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
(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.
;;; 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))
\f
;;;; 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))
(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*))
\f
;;; Convert the code in a component into VOPs.
(defun ir2-convert (component)
projects / sbcl.git / blobdiff