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.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 13ec91b..cd9b6a2 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"