From 7c7e6276719b8d40fddec2070cad81064a25c8ed Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sun, 19 Jun 2005 06:30:50 +0000 Subject: [PATCH] 0.9.1.52: * Implement stack allocation of dynamic extent lists, &REST-lists and closures for Alpha-32; ... remove obsolete "economic" implementation of stack allocation. --- NEWS | 4 ++-- make-config.sh | 2 ++ src/compiler/alpha/alloc.lisp | 34 +++++++++++++++++++++++------- src/compiler/alpha/call.lisp | 18 +++++++++++----- src/compiler/alpha/macros.lisp | 9 ++++++++ src/compiler/alpha/values.lisp | 20 ------------------ src/compiler/generic/early-objdef.lisp | 2 ++ src/compiler/ir2tran.lisp | 36 +++----------------------------- src/compiler/ltn.lisp | 2 -- src/compiler/vop.lisp | 6 ------ tests/dynamic-extent.impure.lisp | 25 ++++++++++++++++++++-- version.lisp-expr | 2 +- 12 files changed, 82 insertions(+), 78 deletions(-) diff --git a/NEWS b/NEWS index b0a8820..972981d 100644 --- a/NEWS +++ b/NEWS @@ -35,8 +35,8 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: memory, and probably show better memory locality. (thanks to David Lichteblau) * optimization: DYNAMIC-EXTENT declarations for lists and closures - are treated as requests for stack allocation on the x86-64 - platform. + are treated as requests for stack allocation on the x86-64 and + Alpha-32 platforms. * contrib improvement: it's harder to cause SOCKET-CLOSE to close() the wrong file descriptor; implementation of SOCKET-OPEN-P. (thanks to Tony Martinez) diff --git a/make-config.sh b/make-config.sh index 3dcbe1e..ff5abee 100644 --- a/make-config.sh +++ b/make-config.sh @@ -234,6 +234,8 @@ elif [ "$sbcl_arch" = "sparc" ]; then if [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "linux" ]; then printf ' :linkage-table' >> $ltf fi +elif [ "$sbcl_arch" = "alpha" ]; then + printf ' :stack-allocatable-closures' >> $ltf else # Nothing need be done in this case, but sh syntax wants a placeholder. echo > /dev/null diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp index 7966981..9a440a3 100644 --- a/src/compiler/alpha/alloc.lisp +++ b/src/compiler/alpha/alloc.lisp @@ -12,6 +12,10 @@ (in-package "SB!VM") ;;;; LIST and LIST* +(defoptimizer (list stack-allocate-result) ((&rest args)) + (not (null args))) +(defoptimizer (list* stack-allocate-result) ((&rest args)) + (not (null (rest args)))) (define-vop (list-or-list*) (:args (things :more t)) @@ -23,6 +27,7 @@ (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) + (:node-var node) (:generator 0 (cond ((zerop num) (move null-tn result)) @@ -40,10 +45,16 @@ (load-stack-tn temp ,tn) temp)))) (storew reg ,list ,slot list-pointer-lowtag)))) - (let ((cons-cells (if star (1- num) num))) - (pseudo-atomic (:extra (* (pad-data-block cons-size) - cons-cells)) - (inst bis alloc-tn list-pointer-lowtag res) + (let* ((dx-p (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it))) + (cons-cells (if star (1- num) num)) + (space (* (pad-data-block cons-size) cons-cells))) + (pseudo-atomic (:extra (if dx-p 0 space)) + (cond (dx-p + (align-csp res) + (inst bis csp-tn list-pointer-lowtag res) + (inst lda csp-tn space csp-tn)) + (t + (inst bis alloc-tn list-pointer-lowtag res))) (move res ptr) (dotimes (i (1- cons-cells)) (store-car (tn-ref-tn things) ptr) @@ -117,13 +128,22 @@ (:ignore stack-allocate-p) (:temporary (:scs (non-descriptor-reg)) temp) (:results (result :scs (descriptor-reg))) + (:node-var node) (:generator 10 - (let ((size (+ length closure-info-offset))) + (let* ((size (+ length closure-info-offset)) + (alloc-size (pad-data-block size)) + (dx-p (node-stack-allocate-p node))) (inst li (logior (ash (1- size) n-widetag-bits) closure-header-widetag) temp) - (pseudo-atomic (:extra (pad-data-block size)) - (inst bis alloc-tn fun-pointer-lowtag result) + (pseudo-atomic (:extra (if dx-p 0 alloc-size)) + (cond (dx-p + ;; no need to align CSP: FUN-POINTER-LOWTAG already has + ;; the corresponding bit set + (inst bis csp-tn fun-pointer-lowtag result) + (inst lda csp-tn alloc-size csp-tn)) + (t + (inst bis alloc-tn fun-pointer-lowtag result))) (storew temp result 0 fun-pointer-lowtag)) (storew function result closure-fun-slot fun-pointer-lowtag)))) diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 5b37fad..fd82448 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -1106,6 +1106,9 @@ default-value-8 (define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg) ;;; Turn &MORE arg (context, count) into a list. +(defoptimizer (%listify-rest-args stack-allocate-result) ((&rest args)) + t) + (define-vop (listify-rest-args) (:args (context-arg :target context :scs (descriptor-reg)) (count-arg :target count :scs (any-reg))) @@ -1116,10 +1119,13 @@ default-value-8 (:results (result :scs (descriptor-reg))) (:translate %listify-rest-args) (:policy :safe) + (:node-var node) (:generator 20 - (let ((enter (gen-label)) - (loop (gen-label)) - (done (gen-label))) + (let* ((enter (gen-label)) + (loop (gen-label)) + (done (gen-label)) + (dx-p (node-stack-allocate-p node)) + (alloc-area-tn (if dx-p csp-tn alloc-tn))) (move context-arg context) (move count-arg count) ;; Check to see if there are any arguments. @@ -1128,11 +1134,13 @@ default-value-8 ;; We need to do this atomically. (pseudo-atomic () + ;; align CSP + (when dx-p (align-csp temp)) ;; Allocate a cons (2 words) for each item. - (inst bis alloc-tn list-pointer-lowtag result) + (inst bis alloc-area-tn list-pointer-lowtag result) (move result dst) (inst sll count 1 temp) - (inst addq alloc-tn temp alloc-tn) + (inst addq alloc-area-tn temp alloc-area-tn) (inst br zero-tn enter) ;; Store the current cons in the cdr of the previous cons. diff --git a/src/compiler/alpha/macros.lisp b/src/compiler/alpha/macros.lisp index b964659..7aaebf6 100644 --- a/src/compiler/alpha/macros.lisp +++ b/src/compiler/alpha/macros.lisp @@ -177,6 +177,15 @@ (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn) (storew ,temp-tn ,result-tn 0 other-pointer-lowtag) ,@body))) + +(defun align-csp (temp) + ;; is used for stack allocation of dynamic-extent objects + (let ((aligned (gen-label))) + (inst and csp-tn lowtag-mask temp) + (inst beq temp aligned) + (inst addq csp-tn n-word-bytes csp-tn) + (storew zero-tn csp-tn -1) + (emit-label aligned))) ;;;; error code (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/compiler/alpha/values.lisp b/src/compiler/alpha/values.lisp index cfdecac..6b385a4 100644 --- a/src/compiler/alpha/values.lisp +++ b/src/compiler/alpha/values.lisp @@ -16,26 +16,6 @@ (:generator 1 (move ptr csp-tn))) -(define-vop (%%pop-dx) - (:args (ptr :scs (any-reg))) - (:ignore ptr) - (:generator 1 - (bug "VOP %%POP-DX is not implemented."))) - -(define-vop (%%nip-dx) - (:args (last-nipped-ptr :scs (any-reg) :target dest) - (last-preserved-ptr :scs (any-reg) :target src) - (moved-ptrs :scs (any-reg) :more t)) - (:results (r-moved-ptrs :scs (any-reg) :more t)) - (:temporary (:sc any-reg) src) - (:temporary (:sc any-reg) dest) - (:temporary (:sc non-descriptor-reg) temp) - (:ignore r-moved-ptrs - last-nipped-ptr last-preserved-ptr moved-ptrs - src dest temp) - (:generator 1 - (bug "VOP %%NIP-DX is not implemented."))) - (define-vop (%%nip-values) (:args (last-nipped-ptr :scs (any-reg) :target dest) (last-preserved-ptr :scs (any-reg) :target src) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index e1e7b6a..c728fad 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -35,6 +35,8 @@ ;;; section. ;;; * OTHER-IMMEDIATE-0-LOWTAG are spaced 4 apart: various code wants to ;;; iterate through these +;;; * Allocation code on Alpha wants lowtags for heap-allocated +;;; objects to be odd. ;;; (These are just the ones we know about as of sbcl-0.7.1.22. There ;;; might easily be more, since these values have stayed highly ;;; constrained for more than a decade, an inviting target for diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index bf1796a..d796e12 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -236,19 +236,12 @@ (let ((info (make-ir2-lvar *backend-t-primitive-type*))) (setf (ir2-lvar-kind info) :delayed) (setf (lvar-info leaves) info) - #!+stack-grows-upward-not-downward - (let ((tn (make-normal-tn *backend-t-primitive-type*))) - (setf (ir2-lvar-locs info) (list tn))) - #!+stack-grows-downward-not-upward (setf (ir2-lvar-stack-pointer info) (make-stack-pointer-tn))))) (defoptimizer (%allocate-closures ir2-convert) ((leaves) call 2block) - (let ((dx-p (lvar-dynamic-extent leaves)) - #!+stack-grows-upward-not-downward - (first-closure nil)) + (let ((dx-p (lvar-dynamic-extent leaves))) (collect ((delayed)) - #!+stack-grows-downward-not-upward (when dx-p (vop current-stack-pointer call 2block (ir2-lvar-stack-pointer (lvar-info leaves)))) @@ -263,9 +256,6 @@ (leaf-dx-p (and dx-p (leaf-dynamic-extent leaf)))) (vop make-closure call 2block entry (length closure) leaf-dx-p tn) - #!+stack-grows-upward-not-downward - (when (and (not first-closure) leaf-dx-p) - (setq first-closure tn)) (loop for what in closure and n from 0 do (unless (and (lambda-var-p what) (null (leaf-refs what))) @@ -282,10 +272,6 @@ tn (find-in-physenv what this-env) n))))))) - #!+stack-grows-upward-not-downward - (when dx-p - (emit-move call 2block first-closure - (first (ir2-lvar-locs (lvar-info leaves))))) (loop for (tn what n) in (delayed) do (vop closure-init call 2block tn what n)))) @@ -681,7 +667,6 @@ (r-refs (reference-tn-list results t))) (aver (= (length info-args) (template-info-arg-count template))) - #!+stack-grows-downward-not-upward (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer call block (ir2-lvar-stack-pointer (lvar-info lvar)))) @@ -1345,12 +1330,8 @@ (vop reset-stack-pointer node block (first (ir2-lvar-locs 2lvar)))) ((lvar-dynamic-extent lvar) - #!+stack-grows-downward-not-upward (vop reset-stack-pointer node block - (ir2-lvar-stack-pointer 2lvar)) - #!-stack-grows-downward-not-upward - (vop %%pop-dx node block - (first (ir2-lvar-locs 2lvar)))) + (ir2-lvar-stack-pointer 2lvar))) (t (bug "Trying to pop a not stack-allocated LVAR ~S." lvar))))) @@ -1382,21 +1363,11 @@ (nipped (first (ir2-lvar-locs 2first)) (reference-tn-list moved-tns nil)) - ((reference-tn-list moved-tns t)))) - #!-stack-grows-downward-not-upward - (nip-unaligned (nipped) - (vop* %%nip-dx node block - (nipped - (first (ir2-lvar-locs 2first)) - (reference-tn-list moved-tns nil)) ((reference-tn-list moved-tns t))))) (cond ((eq (ir2-lvar-kind 2after) :unknown) (nip-aligned (first (ir2-lvar-locs 2after)))) ((lvar-dynamic-extent after) - #!+stack-grows-downward-not-upward - (nip-aligned (ir2-lvar-stack-pointer 2after)) - #!-stack-grows-downward-not-upward - (nip-unaligned (ir2-lvar-stack-pointer 2after))) + (nip-aligned (ir2-lvar-stack-pointer 2after))) (t (bug "Trying to nip a not stack-allocated LVAR ~S." after)))))) @@ -1665,7 +1636,6 @@ (res (lvar-result-tns lvar (list (primitive-type (specifier-type 'list)))))) - #!+stack-grows-downward-not-upward (when (and lvar (lvar-dynamic-extent lvar)) (vop current-stack-pointer node block (ir2-lvar-stack-pointer (lvar-info lvar)))) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index a721dee..7d12edb 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -100,7 +100,6 @@ (setf (ir2-lvar-kind info) :delayed)) (t (let ((tn (make-normal-tn (ir2-lvar-primitive-type info)))) (setf (ir2-lvar-locs info) (list tn)) - #!+stack-grows-downward-not-upward (when (lvar-dynamic-extent lvar) (setf (ir2-lvar-stack-pointer info) (make-stack-pointer-tn))))))) @@ -230,7 +229,6 @@ (setf (lvar-info lvar) info) (when (lvar-dynamic-extent lvar) (aver (proper-list-of-length-p types 1)) - #!+stack-grows-downward-not-upward (setf (ir2-lvar-stack-pointer info) (make-stack-pointer-tn)))) (ltn-annotate-casts lvar) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index f61ed9b..d738a0a 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -215,13 +215,7 @@ ;; these TNs primitive type is only based on the proven type ;; information. (locs nil :type list) - #!+stack-grows-downward-not-upward (stack-pointer nil :type (or tn null))) -;; For upward growing stack start of stack block and start of object -;; differ only by lowtag. -#!-stack-grows-downward-not-upward -(defmacro ir2-lvar-stack-pointer (2lvar) - `(first (ir2-lvar-locs ,2lvar))) (defprinter (ir2-lvar) kind diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index ece03b1..1069238 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -39,9 +39,14 @@ (defun-with-dx dxcaller (&rest rest) (declare (dynamic-extent rest)) (callee rest)) - (assert (= (dxcaller 1 2 3 4 5 6 7) 22)) +(defun-with-dx dxcaller-align-1 (x &rest rest) + (declare (dynamic-extent rest)) + (+ x (callee rest))) +(assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39)) +(assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40)) + ;;; %NIP-VALUES (defun-with-dx test-nip-values () (flet ((bar (x &rest y) @@ -90,6 +95,22 @@ (opaque-identity :bar) z))) +;;; alignment +(defvar *x*) +(defun-with-dx test-alignment-dx-list (form) + (multiple-value-prog1 (eval form) + (let ((l (list 1 2 3 4))) + (declare (dynamic-extent l)) + (setq *x* (copy-list l))))) +(dotimes (n 64) + (let* ((res (loop for i below n collect i)) + (form `(values ,@res))) + (assert (equal (multiple-value-list (test-alignment-dx-list form)) res)) + (assert (equal *x* '(1 2 3 4))))) + + + + (defmacro assert-no-consing (form &optional times) `(%assert-no-consing (lambda () ,form ,times))) (defun %assert-no-consing (thunk &optional times) @@ -100,7 +121,7 @@ (funcall thunk)) (assert (< (- (get-bytes-consed) before) times)))) -#+(or x86 x86-64) +#+(or x86 x86-64 alpha) (progn (assert-no-consing (dxlength 1 2 3)) (assert-no-consing (dxlength t t t t t t)) diff --git a/version.lisp-expr b/version.lisp-expr index c38b598..ee2687b 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".) -"0.9.1.51" +"0.9.1.52" -- 1.7.10.4