From: Nikodemus Siivola Date: Sun, 19 Jun 2005 13:48:16 +0000 (+0000) Subject: 0.9.1.54: dynamic-extent lists and closures on ppc X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=16a6592367eec7c5e9da668ec42fd260e7705b0c;p=sbcl.git 0.9.1.54: dynamic-extent lists and closures on ppc * Implement stack-allocating of lists and closures on PPC, cribbing liberally from the Alpha backend. --- diff --git a/NEWS b/NEWS index d2ba1dc..9b337a8 100644 --- a/NEWS +++ b/NEWS @@ -34,11 +34,9 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: * optimization: structure instances with raw slots now use less memory, and probably show better memory locality. (thanks to David Lichteblau) - * optimization: DYNAMIC-EXTENT declarations for &REST lists are - treated as requests for stack allocation on PPC platforms. * optimization: DYNAMIC-EXTENT declarations for lists and closures - are treated as requests for stack allocation on the x86-64 and - Alpha-32 platforms. + are treated as requests for stack allocation on the x86-64, + Alpha-32, and PPC 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 ff5abee..e875071 100644 --- a/make-config.sh +++ b/make-config.sh @@ -213,9 +213,11 @@ elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then # versions 2.3.1 and 2.3.2 # # FIXME: integrate to grovel-features., maypahps + printf ' :stack-allocatable-closures' >> $ltf $GNUMAKE -C tools-for-build where-is-mcontext -I src/runtime tools-for-build/where-is-mcontext > src/runtime/ppc-linux-mcontext.h elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "darwin" ]; then + printf ' :stack-allocatable-closures' >> $ltf # We provide a dlopen shim, so a little lie won't hurt printf " :os-provides-dlopen :linkage-table" >> $ltf # The default stack ulimit under darwin is too small to run PURIFY. diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp index 713e6a3..7a7cf44 100644 --- a/src/compiler/ppc/alloc.lisp +++ b/src/compiler/ppc/alloc.lisp @@ -1,11 +1,21 @@ -;;; -;;; Written by William Lott. -;;; +;;;; allocation VOPs for the Alpha port -(in-package "SB!VM") +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(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)) @@ -18,6 +28,7 @@ (:results (result :scs (descriptor-reg))) (:variant-vars star) (:policy :safe) + (:node-var node) (:generator 0 (cond ((zerop num) (move result null-tn)) @@ -33,11 +44,17 @@ (control-stack (load-stack-tn temp ,tn) temp))))) - (let* ((cons-cells (if star (1- num) num)) + (let* ((dx-p (node-stack-allocate-p node)) + (cons-cells (if star (1- num) num)) (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (pa-flag :extra alloc) - (inst clrrwi res alloc-tn n-lowtag-bits) - (inst ori res res list-pointer-lowtag) + (pseudo-atomic (pa-flag :extra (if dx-p 0 alloc)) + (let ((allocation-area-tn (if dx-p csp-tn alloc-tn))) + (when dx-p + (align-csp res)) + (inst clrrwi res allocation-area-tn n-lowtag-bits) + (inst ori res res list-pointer-lowtag) + (when dx-p + (inst addi csp-tn csp-tn alloc))) (move ptr res) (dotimes (i (1- cons-cells)) (storew (maybe-load (tn-ref-tn things)) ptr @@ -106,7 +123,6 @@ (storew null-tn result fdefn-fun-slot other-pointer-lowtag) (storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))) - (define-vop (make-closure) (:args (function :to :save :scs (descriptor-reg))) (:info length stack-allocate-p) @@ -114,10 +130,18 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:results (result :scs (descriptor-reg))) + (:node-var node) (:generator 10 - (let ((size (+ length closure-info-offset))) - (pseudo-atomic (pa-flag :extra (pad-data-block size)) - (inst clrrwi. result alloc-tn n-lowtag-bits) + (let* ((size (+ length closure-info-offset)) + (alloc-size (pad-data-block size)) + (dx-p (node-stack-allocate-p node)) + (allocation-area-tn (if dx-p csp-tn alloc-tn))) + (pseudo-atomic (pa-flag :extra (if dx-p 0 alloc-size)) + ;; no need to align CSP for DX: FUN-POINTER-LOWTAG already has + ;; the corresponding bit set + (inst clrrwi. result allocation-area-tn n-lowtag-bits) + (when dx-p + (inst addi csp-tn alloc-size)) (inst ori result result fun-pointer-lowtag) (inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag)) (storew temp result 0 fun-pointer-lowtag))) diff --git a/src/compiler/ppc/values.lisp b/src/compiler/ppc/values.lisp index 36cbd5b..c3b2340 100644 --- a/src/compiler/ppc/values.lisp +++ b/src/compiler/ppc/values.lisp @@ -11,26 +11,6 @@ (:generator 1 (move csp-tn ptr))) -(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."))) - ;;; sparc version translated to ppc by David Steuber with help from #lisp. (define-vop (%%nip-values) (:args (last-nipped-ptr :scs (any-reg) :target dest) diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 3c0d247..6844273 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -127,13 +127,9 @@ (assert-no-consing (dxlength t t t t t t)) (assert-no-consing (dxlength)) (assert-no-consing (dxcaller 1 2 3 4 5 6 7)) - #-ppc (assert-no-consing (test-nip-values)) - #-ppc (assert-no-consing (test-let-var-subst1 17)) - #-ppc (assert-no-consing (test-let-var-subst2 17)) - #-ppc (assert-no-consing (test-lvar-subst 11))) diff --git a/version.lisp-expr b/version.lisp-expr index db82d28..e097442 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.53" +"0.9.1.54"