From c097dfd6528faa7efb98d5e021711a9969a67212 Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Tue, 9 Nov 2010 19:45:23 +0000 Subject: [PATCH] 1.0.44.15: ir2: Skip value-cell allocation where possible. * Expose the new ANCESTOR-FRAME VOPs in package-data.lisp-expr. * When creating TNs for closed-over LAMBDA-VARs with "implicit" VALUE-CELLs, force the TNs to be allocated on the control-stack, and to be live over the entire extent of the PHYSENV. * When translating a REF or SET node for such LAMBDA-VARs from a NODE in a CLAMBDA with a different PHYSENV, use the new VOPs to access the LAMBDA-VAR. * When setting up a closure for such LAMBDA-VARs from a NODE in a CLAMBDA with the same PHYSENV as the variable, use the new CLOSURE-INIT-FROM-FP VOP to stash the frame pointer instead of a VALUE-CELL or the current value of the variable. * When setting up the closure environment for a local-call that closes over such a LAMBDA-VAR, and the call is being made from a NODE in a CLAMBDA with the same PHYSENV as the variable, store the current frame-pointer instead of a VALUE-CELL or the current value of the variable. --- package-data-list.lisp-expr | 3 +- src/compiler/gtn.lisp | 23 ++++++++++---- src/compiler/ir2tran.lisp | 74 ++++++++++++++++++++++++++++++++----------- version.lisp-expr | 2 +- 4 files changed, 76 insertions(+), 26 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 13ec91b..cd9b6a2 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -219,6 +219,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME" "ALLOCATE-DYNAMIC-CODE-OBJECT" "ALLOCATE-FULL-CALL-FRAME" "ALWAYS-TRANSLATABLE" + "ANCESTOR-FRAME-REF" "ANCESTOR-FRAME-SET" "ANY" "ARG-COUNT-ERROR" "ASSEMBLE-FILE" "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION" "ATTRIBUTES=" "BIND" @@ -231,7 +232,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "CHECK-SYMBOL" ;; FIXME: 32/64-bit issues "CHECK-UNSIGNED-BYTE-32" "CHECK-UNSIGNED-BYTE-64" - "CLOSURE-INIT" "CLOSURE-REF" + "CLOSURE-INIT" "CLOSURE-REF" "CLOSURE-INIT-FROM-FP" "CODE-CONSTANT-REF" "CODE-CONSTANT-SET" "*CODE-COVERAGE-INFO*" "COMPARE-AND-SWAP-SLOT" diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 2752acc..ca2c23f 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -43,13 +43,24 @@ (let* ((type (if (lambda-var-indirect var) *backend-t-primitive-type* (primitive-type (leaf-type var)))) - (temp (make-normal-tn type)) + (res (make-normal-tn type)) (node (lambda-bind fun)) - (res (if (or (and let-p (policy node (< debug 3))) - (policy node (zerop debug)) - (policy node (= speed 3))) - temp - (physenv-debug-live-tn temp (lambda-physenv fun))))) + (debug-variable-p (not (or (and let-p (policy node (< debug 3))) + (policy node (zerop debug)) + (policy node (= speed 3)))))) + (cond + ((and (lambda-var-indirect var) + (not (lambda-var-explicit-value-cell var))) + ;; Force closed-over indirect LAMBDA-VARs without explicit + ;; VALUE-CELLs to the stack, and make sure that they are + ;; live over the dynamic contour of the physenv. + (setf (tn-sc res) (svref *backend-sc-numbers* + sb!vm:control-stack-sc-number)) + (physenv-live-tn res (lambda-physenv fun))) + + (debug-variable-p + (physenv-debug-live-tn res (lambda-physenv fun)))) + (setf (tn-leaf res) var) (setf (leaf-info var) res)))) (values)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 4796850..d518f0c 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -132,10 +132,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 @@ -239,6 +246,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) @@ -280,11 +302,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)))) @@ -306,10 +333,17 @@ (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) @@ -737,7 +771,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)) @@ -769,7 +804,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) @@ -786,7 +822,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)))) @@ -1162,7 +1198,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)))) @@ -1301,7 +1338,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 diff --git a/version.lisp-expr b/version.lisp-expr index a6f6e08..c73fcc4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.44.14" +"1.0.44.15" -- 1.7.10.4