(defevent make-value-cell-event "Allocate heap value cell for lexical var.")
(defun emit-make-value-cell (node block value res)
(event make-value-cell-event node)
- (let* ((leaf (tn-leaf res))
- (dx (when leaf (leaf-dynamic-extent leaf))))
- (when (and dx (neq :truly dx) (leaf-has-source-name-p leaf))
- (compiler-notify "cannot stack allocate value cell for ~S" (leaf-source-name leaf)))
- (vop make-value-cell node block value
- ;; FIXME: See bug 419
- (eq :truly dx)
- res)))
+ (vop make-value-cell node block value nil res))
\f
;;;; leaf reference
(res (first locs)))
(etypecase leaf
(lambda-var
- (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))))
+ (let ((tn (find-in-physenv leaf (node-physenv node)))
+ (indirect (lambda-var-indirect leaf))
+ (explicit (lambda-var-explicit-value-cell leaf)))
+ (cond
+ ((and indirect explicit)
+ (vop value-cell-ref node block tn res))
+ ((and indirect
+ (not (eq (node-physenv node)
+ (lambda-physenv (lambda-var-home leaf)))))
+ (let ((reffer (third (primitive-type-indirect-cell-type
+ (primitive-type (leaf-type leaf))))))
+ (if reffer
+ (funcall reffer node block tn (leaf-info leaf) res)
+ (vop ancestor-frame-ref node block tn (leaf-info leaf) res))))
+ (t (emit-move node block tn res)))))
(constant
(emit-move node block (constant-tn leaf) res))
(functional
(emit-move ref ir2-block entry res)))))
(values))
+(defun closure-initial-value (what this-env current-fp)
+ (declare (type (or nlx-info lambda-var clambda) what)
+ (type physenv this-env)
+ (type (or tn null) current-fp))
+ ;; If we have an indirect LAMBDA-VAR that does not require an
+ ;; EXPLICIT-VALUE-CELL, and is from this environment (not from being
+ ;; closed over), we need to store the current frame pointer.
+ (if (and (lambda-var-p what)
+ (lambda-var-indirect what)
+ (not (lambda-var-explicit-value-cell what))
+ (eq (lambda-physenv (lambda-var-home what))
+ this-env))
+ current-fp
+ (find-in-physenv what this-env)))
+
(defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy)
ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
(when (lvar-dynamic-extent leaves)
(vop current-stack-pointer call 2block
(ir2-lvar-stack-pointer (lvar-info leaves))))
(dolist (leaf (lvar-value leaves))
- (binding* ((xep (functional-entry-fun leaf) :exit-if-null)
+ (binding* ((xep (awhen (functional-entry-fun leaf)
+ ;; if the xep's been deleted then we can skip it
+ (if (eq (functional-kind it) :deleted)
+ nil it))
+ :exit-if-null)
(nil (aver (xep-p xep)))
(entry-info (lambda-info xep) :exit-if-null)
(tn (entry-info-closure-tn entry-info) :exit-if-null)
;; putting of all closures after all creations
;; (though it may require more registers).
(if (lambda-p what)
- (delayed (list tn (find-in-physenv what this-env) n))
- (vop closure-init call 2block
- tn
- (find-in-physenv what this-env)
- n)))))))
+ (delayed (list tn (find-in-physenv what this-env) n))
+ (let ((initial-value (closure-initial-value
+ what this-env nil)))
+ (if initial-value
+ (vop closure-init call 2block
+ tn initial-value n)
+ ;; An initial-value of NIL means to stash
+ ;; the frame pointer... which requires a
+ ;; different VOP.
+ (vop closure-init-from-fp call 2block tn n)))))))))
(loop for (tn what n) in (delayed)
do (vop closure-init call 2block
tn what n))))
(etypecase leaf
(lambda-var
(when (leaf-refs leaf)
- (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)))))
+ (let ((tn (find-in-physenv leaf (node-physenv node)))
+ (indirect (lambda-var-indirect leaf))
+ (explicit (lambda-var-explicit-value-cell leaf)))
+ (cond
+ ((and indirect explicit)
+ (vop value-cell-set node block tn val))
+ ((and indirect
+ (not (eq (node-physenv node)
+ (lambda-physenv (lambda-var-home leaf)))))
+ (let ((setter (fourth (primitive-type-indirect-cell-type
+ (primitive-type (leaf-type leaf))))))
+ (if setter
+ (funcall setter node block tn val (leaf-info leaf))
+ (vop ancestor-frame-set node block tn val (leaf-info leaf)))))
+ (t (emit-move node block val tn))))))
(global-var
(aver (symbolp (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
(emit-template node block template args nil
(list* (block-label consequent) not-p
info-args))
- (unless (drop-thru-p if alternative)
- (vop branch node block (block-label alternative))))
+ (if (drop-thru-p if alternative)
+ (register-drop-thru alternative)
+ (vop branch node block (block-label alternative))))
(t
(emit-template node block template args nil info-args)
(vop branch-if node block (block-label consequent) flags not-p)
- (unless (drop-thru-p if alternative)
- (vop branch node block (block-label alternative)))))))
+ (if (drop-thru-p if alternative)
+ (register-drop-thru alternative)
+ (vop branch node block (block-label alternative)))))))
;;; Convert an IF that isn't the DEST of a conditional template.
(defun ir2-convert-if (node block)
(when arg
(let ((src (lvar-tn node block arg))
(dest (leaf-info var)))
- (if (lambda-var-indirect var)
+ (if (and (lambda-var-indirect var)
+ (lambda-var-explicit-value-cell var))
(emit-make-value-cell node block src dest)
(emit-move node block src dest)))))
(lambda-vars fun) (basic-combination-args node))
;;; 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)
+;;;
+;;; CLOSURE-FP is for calling a closure that has "implicit" value
+;;; cells (stored in the allocating stack frame), and is the frame
+;;; pointer TN to use for values allocated in the outbound stack
+;;; frame. This is distinct from OLD-FP for the specific case of a
+;;; tail-local-call.
+(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp))
(declare (type combination node) (type ir2-block block) (type clambda fun)
- (type (or tn null) old-fp))
+ (type (or tn null) old-fp closure-fp))
(let ((actuals (mapcar (lambda (x)
(when x
(lvar-tn node block x)))
(loc (leaf-info var)))
(when actual
(cond
- ((lambda-var-indirect var)
+ ((and (lambda-var-indirect var)
+ (lambda-var-explicit-value-cell var))
(let ((temp
(make-normal-tn *backend-t-primitive-type*)))
(emit-make-value-cell node block actual temp)
(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))
+ (temps (closure-initial-value (car thing) this-1env closure-fp))
(locs (cdr thing)))
(temps old-fp)
(locs (ir2-physenv-old-fp called-env))))
;;; 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 (physenv-info (node-physenv node))))
+ (let ((this-env (physenv-info (node-physenv node)))
+ (current-fp (make-stack-pointer-tn)))
(multiple-value-bind (temps locs)
- (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
+ (emit-psetq-moves node block fun
+ (ir2-physenv-old-fp this-env) current-fp)
+
+ ;; If we're about to emit a move from CURRENT-FP then we need to
+ ;; initialize it.
+ (when (find current-fp temps)
+ (vop current-fp node block current-fp))
(mapc (lambda (temp loc)
(emit-move node block temp loc))
((node-tail-p node)
(ir2-convert-tail-local-call node block fun))
(t
- (let ((start (block-label (lambda-block fun)))
+ (let ((start (block-trampoline (lambda-block fun)))
(returns (tail-set-info (lambda-tail-set fun)))
(lvar (node-lvar node)))
(ecase (if returns
(when (leaf-refs arg)
(let ((pass (standard-arg-location n))
(home (leaf-info arg)))
- (if (lambda-var-indirect arg)
+ (if (and (lambda-var-indirect arg)
+ (lambda-var-explicit-value-cell arg))
(emit-make-value-cell node block pass home)
(emit-move node block pass home))))
(incf n))))
(mapc (lambda (src var)
(when (leaf-refs var)
(let ((dest (leaf-info var)))
- (if (lambda-var-indirect var)
+ (if (and (lambda-var-indirect var)
+ (lambda-var-explicit-value-cell var))
(emit-make-value-cell node block src dest)
(emit-move node block src dest)))))
(lvar-tns node block lvar
(aver (not named))
tn)))))))
((not (eq (ir2-block-next 2block) (block-info target)))
- (vop branch last 2block (block-label target)))))))
+ (vop branch last 2block (block-label target)))
+ (t
+ (register-drop-thru target))))))
(values))
projects / sbcl.git / blobdiff