Compiler support for specialised implicit value cells

 Enables the use of non-T stack TNs for closed-over dynamic-extent variables.

 SB!VM:PRIMITIVE-TYPE-INDIRECT-CELL-TYPE takes a primitive-type and returns
 NIL, or a list of 4 values:
  - the primitive type of the implicit indirect value cell
  - the SC of that cell
  - a function that takes the NODE, BLOCK, FP, VALUE and RESULT, and
    emits a reference to that cell.
  - a function that takes the NODE, BLOCK, FP, NEW-VALUE and VALUE, and
    emits a write to that cell.

 Some correctness tests to make sure codegen is correct (without verifying
 DXness).

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 1ee1566..0444ebb 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -313,7 +313,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "%%POP-DX"
                "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF"
                "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP"
-               "PRIMITIVE-TYPE-NAME" "PUSH-VALUES"
+               "PRIMITIVE-TYPE-NAME"
+               "PRIMITIVE-TYPE-INDIRECT-CELL-TYPE"
+               "PUSH-VALUES"
                "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING"
                #!+inline-constants "REGISTER-INLINE-CONSTANT"
                "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE"
@@ -2662,7 +2664,8 @@ structure representations"
                "PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME"
                "PRIMITIVE-OBJECT-OPTIONS" "PRIMITIVE-OBJECT-P"
                "PRIMITIVE-OBJECT-SIZE" "PRIMITIVE-OBJECT-SLOTS"
-               "PRIMITIVE-OBJECT-VARIABLE-LENGTH-P" "PRINT-ALLOCATED-OBJECTS"
+               "PRIMITIVE-OBJECT-VARIABLE-LENGTH-P"
+               "PRINT-ALLOCATED-OBJECTS"
                "RANDOM-IMMEDIATE-SC-NUMBER" "RATIO-DENOMINATOR-SLOT"
                "RATIO-NUMERATOR-SLOT" "RATIO-SIZE" "RATIO-WIDETAG"
                "*READ-ONLY-SPACE-FREE-POINTER*"

diff --git a/src/compiler/alpha/vm.lisp b/src/compiler/alpha/vm.lisp
index 32103ed..d16e08a 100644 (file)
--- a/src/compiler/alpha/vm.lisp
+++ b/src/compiler/alpha/vm.lisp
@@ -358,3 +358,7 @@
 (!def-vm-support-routine combination-implementation-style (node)
   (declare (type sb!c::combination node) (ignore node))
   (values :default nil))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp
index ca2c23f..af808d2 100644 (file)
--- a/src/compiler/gtn.lisp
+++ b/src/compiler/gtn.lisp
@@ -40,8 +40,15 @@
   (declare (type clambda fun))
   (dolist (var (lambda-vars fun))
     (when (leaf-refs var)
-      (let* ((type (if (lambda-var-indirect var)
-                       *backend-t-primitive-type*
+      (let* (ptype-info
+             (type (if (lambda-var-indirect var)
+                       (if (lambda-var-explicit-value-cell var)
+                           *backend-t-primitive-type*
+                           (or (first
+                                (setf ptype-info
+                                      (primitive-type-indirect-cell-type
+                                       (primitive-type (leaf-type var)))))
+                               *backend-t-primitive-type*))
                        (primitive-type (leaf-type var))))
              (res (make-normal-tn type))
              (node (lambda-bind fun))
@@ -54,8 +61,9 @@
           ;; 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))
+          (setf (tn-sc res) (if ptype-info
+                                (second ptype-info)
+                                (sc-or-lose 'sb!vm::control-stack)))
           (physenv-live-tn res (lambda-physenv fun)))
 
          (debug-variable-p

diff --git a/src/compiler/hppa/vm.lisp b/src/compiler/hppa/vm.lisp
index 66f0fdd..740ffca 100644 (file)
--- a/src/compiler/hppa/vm.lisp
+++ b/src/compiler/hppa/vm.lisp
@@ -387,3 +387,7 @@
 (!def-vm-support-routine combination-implementation-style (node)
   (declare (type sb!c::combination node) (ignore node))
   (values :default nil))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index d764e82..a4fda56 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -134,7 +134,11 @@
           ((and indirect
                 (not (eq (node-physenv node)
                          (lambda-physenv (lambda-var-home leaf)))))
-           (vop ancestor-frame-ref node block tn (leaf-info leaf) res))
+           (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))
@@ -335,7 +339,11 @@
             ((and indirect
                   (not (eq (node-physenv node)
                            (lambda-physenv (lambda-var-home leaf)))))
-             (vop ancestor-frame-set node block tn val (leaf-info 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)))

diff --git a/src/compiler/mips/vm.lisp b/src/compiler/mips/vm.lisp
index 098e00d..a32c6d7 100644 (file)
--- a/src/compiler/mips/vm.lisp
+++ b/src/compiler/mips/vm.lisp
@@ -374,3 +374,7 @@
 (!def-vm-support-routine combination-implementation-style (node)
   (declare (type sb!c::combination node) (ignore node))
   (values :default nil))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp
index e655d12..9de32a9 100644 (file)
--- a/src/compiler/ppc/vm.lisp
+++ b/src/compiler/ppc/vm.lisp
@@ -394,3 +394,7 @@
                     (%%ldb integer size posn))))
          (t (values :default nil))))
       (t (values :default nil)))))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/src/compiler/sparc/vm.lisp b/src/compiler/sparc/vm.lisp
index 65865ae..8a85603 100644 (file)
--- a/src/compiler/sparc/vm.lisp
+++ b/src/compiler/sparc/vm.lisp
@@ -376,3 +376,7 @@
 (!def-vm-support-routine combination-implementation-style (node)
   (declare (type sb!c::combination node) (ignore node))
   (values :default nil))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index 63af4f9..77bd30e 100644 (file)
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -552,3 +552,7 @@
 (!def-vm-support-routine combination-implementation-style (node)
   (declare (type sb!c::combination node) (ignore node))
   (values :default nil))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp
index ae0b111..d2b7ba5 100644 (file)
--- a/src/compiler/x86/vm.lisp
+++ b/src/compiler/x86/vm.lisp
@@ -516,3 +516,7 @@
                                (%logbitp integer index))))
          (t (values :default nil))))
       (t (values :default nil)))))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 76d2cf8..4e0b077 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -993,3 +993,38 @@
       (assert (eql a 1))
       (assert (eql b 2))
       (assert (eql c 3)))))
+
+(defun opaque-funcall (function &rest arguments)
+  (apply function arguments))
+
+(with-test (:name :implicit-value-cells)
+  (flet ((test-it (type input output)
+           (let ((f (compile nil `(lambda (x)
+                                    (declare (type ,type x))
+                                    (flet ((inc ()
+                                             (incf x)))
+                                      (declare (dynamic-extent #'inc))
+                                      (list (opaque-funcall #'inc) x))))))
+             (assert (equal (funcall f input)
+                            (list output output))))))
+    (let ((width sb-vm:n-word-bits))
+      (test-it t (1- most-positive-fixnum) most-positive-fixnum)
+      (test-it `(unsigned-byte ,(1- width)) (ash 1 (- width 2)) (1+ (ash 1 (- width 2))))
+      (test-it `(signed-byte ,width) (ash -1 (- width 2)) (1+ (ash -1 (- width 2))))
+      (test-it `(unsigned-byte ,width) (ash 1 (1- width)) (1+ (ash 1 (1- width))))
+      (test-it 'single-float 3f0 4f0)
+      (test-it 'double-float 3d0 4d0)
+      (test-it '(complex single-float) #c(3f0 4f0) #c(4f0 4f0))
+      (test-it '(complex double-float) #c(3d0 4d0) #c(4d0 4d0)))))
+
+(with-test (:name :sap-implicit-value-cells)
+  (let ((f (compile nil `(lambda (x)
+                           (declare (type system-area-pointer x))
+                           (flet ((inc ()
+                                    (setf x (sb-sys:sap+ x 16))))
+                             (declare (dynamic-extent #'inc))
+                             (list (opaque-funcall #'inc) x)))))
+        (width sb-vm:n-machine-word-bits))
+    (assert (every (lambda (x)
+                     (sb-sys:sap= x (sb-sys:int-sap (+ 16 (ash 1 (1- width))))))
+                   (funcall f (sb-sys:int-sap (ash 1 (1- width))))))))