From: Paul Khuong Date: Tue, 21 Jun 2011 03:52:45 +0000 (-0400) Subject: Compiler support for specialised implicit value cells X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=56a2dbbb9d79a62db99cc4061e50fca74fcf907e;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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))))))))