X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=bedbda8ebd411fbeff1dc544e5610544af1348de;hb=f741a144c386acdb82cac2e3352abab7cff65f1d;hp=78513e6c51f61fc930aa187cd19ed18b01f8b47e;hpb=5cf3c4259d529e180d75d4d140f344e600d2b06b;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 78513e6..bedbda8 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -56,11 +56,7 @@ (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))) - (vop make-value-cell node block value - ;; FIXME: See bug 419 - (and leaf (eq :truly (leaf-dynamic-extent leaf))) - res))) + (vop make-value-cell node block value nil res)) ;;;; leaf reference @@ -129,10 +125,17 @@ (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))))) + (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 @@ -141,12 +144,18 @@ (let ((unsafe (policy node (zerop safety))) (name (leaf-source-name leaf))) (ecase (global-var-kind leaf) - ((:special :global) + ((:special :unknown) (aver (symbolp name)) (let ((name-tn (emit-constant name))) - (if unsafe + (if (or unsafe (info :variable :always-bound name)) (vop fast-symbol-value node block name-tn res) (vop symbol-value node block name-tn res)))) + (:global + (aver (symbolp name)) + (let ((name-tn (emit-constant name))) + (if (or unsafe (info :variable :always-bound name)) + (vop fast-symbol-global-value node block name-tn res) + (vop symbol-global-value node block name-tn res)))) (:global-function (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name))) (if unsafe @@ -230,6 +239,21 @@ (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) @@ -246,7 +270,11 @@ (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) @@ -267,11 +295,16 @@ ;; 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)))) @@ -293,15 +326,25 @@ (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))))) + (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) ((:special) - (aver (symbolp (leaf-source-name leaf))) - (vop set node block (emit-constant (leaf-source-name leaf)) val))))) + (vop set node block (emit-constant (leaf-source-name leaf)) val)) + ((:global) + (vop %set-symbol-global-value node + block (emit-constant (leaf-source-name leaf)) val))))) (when locs (emit-move node block val (first locs)) (move-lvar-result node block locs lvar))) @@ -721,7 +764,8 @@ (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)) @@ -753,7 +797,8 @@ (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) @@ -770,7 +815,7 @@ (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 old-fp)) (locs (cdr thing))) (temps old-fp) (locs (ir2-physenv-old-fp called-env)))) @@ -1146,7 +1191,8 @@ (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)))) @@ -1253,15 +1299,21 @@ (values)) ;;;; debugger hooks +;;;; +;;;; These are used by the debugger to find the top function on the +;;;; stack. They return the OLD-FP and RETURN-PC for the current +;;;; function as multiple values. + +(defoptimizer (%caller-frame ir2-convert) (() node block) + (let ((ir2-physenv (physenv-info (node-physenv node)))) + (move-lvar-result node block + (list (ir2-physenv-old-fp ir2-physenv)) + (node-lvar node)))) -;;; This is used by the debugger to find the top function on the -;;; 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) +(defoptimizer (%caller-pc ir2-convert) (() node block) (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-lvar-result node block - (list (ir2-physenv-old-fp ir2-physenv) - (ir2-physenv-return-pc ir2-physenv)) + (list (ir2-physenv-return-pc ir2-physenv)) (node-lvar node)))) ;;;; multiple values @@ -1279,7 +1331,8 @@ (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 @@ -1446,7 +1499,7 @@ (dolist (var vars) ;; CLHS says "bound and then made to have no value" -- user ;; should not be able to tell the difference between that and this. - (about-to-modify-symbol-value var "bind ~S") + (about-to-modify-symbol-value var 'progv) (%primitive bind unbound-marker var)))) (,bind (vars vals) (declare (optimize (speed 2) (debug 0) @@ -1456,7 +1509,7 @@ (t (let ((val (car vals)) (var (car vars))) - (about-to-modify-symbol-value var "bind ~S" val) + (about-to-modify-symbol-value var 'progv val t) (%primitive bind val var)) (,bind (cdr vars) (cdr vals)))))) (,bind ,vars ,vals))