From 9b55754d5328a5f44ee224d32865fc8dadee123b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 13 May 2005 18:30:44 +0000 Subject: [PATCH] 0.9.0.30: towards callbacks: static-vectors * SB-INT:MAKE-STATIC-VECTOR allows direct allocation of specialized vectors to static space. This is eventually destined to become SB-EXT:MAKE-STATIC-ARRAY, but needs more frills before that -- current setup is enough to support callbacks (and a bit more then that). * unrelated defrobnification, s/&rest/&body/ in a few places, and commentary on cunning punning. --- build-order.lisp-expr | 1 + package-data-list.lisp-expr | 12 ++++++--- src/assembly/ppc/array.lisp | 28 +++++++++++---------- src/assembly/sparc/array.lisp | 1 + src/code/alloc.lisp | 54 ++++++++++++++++++++++++++++++++++++++++ src/code/array.lisp | 47 +++++++++++++++++++++++++++++++++- src/code/condition.lisp | 2 ++ src/code/sysmacs.lisp | 2 +- src/compiler/ppc/macros.lisp | 8 +++--- src/compiler/sparc/macros.lisp | 6 ++--- tests/static-alloc.impure.lisp | 14 +++++++++++ version.lisp-expr | 2 +- 12 files changed, 150 insertions(+), 27 deletions(-) create mode 100644 src/code/alloc.lisp create mode 100644 tests/static-alloc.impure.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index d7e739f..7d82033 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -635,6 +635,7 @@ ("src/code/save" :not-host) ; uses the definition of PATHNAME ; from "code/pathname" ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" + ("src/code/alloc" :not-host) #!+sb-thread ("src/code/target-thread" :not-host) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0820a6f..b45d0b3 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -790,10 +790,10 @@ retained, possibly temporariliy, because it might be used internally." ;; error-reporting facilities "ENCAPSULATED-CONDITION" "COMPILED-PROGRAM-ERROR" "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" - "SIMPLE-PARSE-ERROR" - "SIMPLE-PROGRAM-ERROR" "SIMPLE-STREAM-ERROR" - + "SIMPLE-PARSE-ERROR" "SIMPLE-PROGRAM-ERROR" + "SIMPLE-STREAM-ERROR" "SIMPLE-STORAGE-CONDITION" "SIMPLE-STYLE-WARNING" + "SPECIAL-FORM-FUNCTION" "STYLE-WARN" "SIMPLE-COMPILER-NOTE" @@ -966,6 +966,9 @@ retained, possibly temporariliy, because it might be used internally." ;; need it: "*EOF-OBJECT*" + ;; allocation to static space + "MAKE-STATIC-VECTOR" + ;; alien interface utilities "C-STRINGS->STRING-LIST" @@ -1131,7 +1134,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "WORD-LOGICAL-OR" "WORD-LOGICAL-ORC1" "WORD-LOGICAL-ORC2" "WORD-LOGICAL-XOR" "ALIEN-TYPE-TYPE" "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" - "ALLOCATE-VECTOR" "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" + "ALLOCATE-VECTOR" "ALLOCATE-STATIC-VECTOR" + "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" "COMPILER-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" "DISABLED-PACKAGE-LOCKS" "WITH-SINGLE-PACKAGE-LOCKED-ERROR" diff --git a/src/assembly/ppc/array.lisp b/src/assembly/ppc/array.lisp index bfb2958..4e0fb53 100644 --- a/src/assembly/ppc/array.lisp +++ b/src/assembly/ppc/array.lisp @@ -18,23 +18,25 @@ (:arg-types positive-fixnum positive-fixnum positive-fixnum)) - ((:arg type any-reg a0-offset) - (:arg length any-reg a1-offset) - (:arg words any-reg a2-offset) - (:res result descriptor-reg a0-offset) - - (:temp ndescr non-descriptor-reg nl0-offset) - (:temp pa-flag non-descriptor-reg nl3-offset) - (:temp vector descriptor-reg a3-offset)) + ((:arg type any-reg a0-offset) + (:arg length any-reg a1-offset) + (:arg words any-reg a2-offset) + (:res result descriptor-reg a0-offset) + + (:temp ndescr non-descriptor-reg nl0-offset) + (:temp pa-flag non-descriptor-reg nl3-offset) + (:temp vector descriptor-reg a3-offset)) (pseudo-atomic (pa-flag) - (inst ori vector alloc-tn sb!vm:other-pointer-lowtag) - (inst addi ndescr words (* (1+ sb!vm:vector-data-offset) sb!vm:n-word-bytes)) + (inst ori vector alloc-tn other-pointer-lowtag) + ;; boxed words == unboxed bytes + (inst addi ndescr words (* (1+ vector-data-offset) n-word-bytes)) (inst clrrwi ndescr ndescr n-lowtag-bits) (inst add alloc-tn alloc-tn ndescr) - (inst srwi ndescr type sb!vm:word-shift) - (storew ndescr vector 0 sb!vm:other-pointer-lowtag) - (storew length vector sb!vm:vector-length-slot sb!vm:other-pointer-lowtag)) + (inst srwi ndescr type word-shift) + (storew ndescr vector 0 other-pointer-lowtag) + (storew length vector vector-length-slot other-pointer-lowtag)) ;; This makes sure the zero byte at the end of a string is paged in so ;; the kernel doesn't bitch if we pass it the string. (storew zero-tn alloc-tn 0) (move result vector)) + diff --git a/src/assembly/sparc/array.lisp b/src/assembly/sparc/array.lisp index 7f428e7..717fa07 100644 --- a/src/assembly/sparc/array.lisp +++ b/src/assembly/sparc/array.lisp @@ -26,6 +26,7 @@ (:temp vector descriptor-reg a3-offset)) (pseudo-atomic () (inst or vector alloc-tn other-pointer-lowtag) + ;; boxed words == unboxed bytes (inst add ndescr words (* (1+ vector-data-offset) n-word-bytes)) (inst andn ndescr 7) (inst add alloc-tn ndescr) diff --git a/src/code/alloc.lisp b/src/code/alloc.lisp new file mode 100644 index 0000000..866a9ee --- /dev/null +++ b/src/code/alloc.lisp @@ -0,0 +1,54 @@ +;;;; Lisp-side allocation (used currently only for direct allocation +;;;; to static space). + +;;;; 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") + +#!-sb-fluid (declaim (inline store-word)) +(defun store-word (word base &optional (offset 0) (lowtag 0)) + (declare (type (unsigned-byte #.sb!vm:n-word-bits) word base offset) + (type (unsigned-byte #.n-lowtag-bits) lowtag)) + (setf (sap-ref-word (int-sap base) (- (ash offset word-shift) lowtag)) word)) + +(defun allocate-static-vector (widetag length words) + (declare (type (unsigned-byte #.n-widetag-bits) widetag) + (type (unsigned-byte #.n-word-bits) words) + (type index length)) + (handler-case + ;; FIXME: Is WITHOUT-GCING enough to do lisp-side allocation + ;; to static space, or should we have WITHOUT-INTERRUPTS here + ;; as well? + (without-gcing + (let* ((pointer *static-space-free-pointer*) ; in words + (free (* pointer n-word-bytes)) + (vector (logior free other-pointer-lowtag)) ; in bytes, yay + ;; rounded to dual word boundary + (nwords (logandc2 (+ lowtag-mask (+ words vector-data-offset 1)) + lowtag-mask)) + (new-pointer (+ *static-space-free-pointer* nwords)) + (new-free (* new-pointer n-word-bytes))) + (unless (> static-space-end new-free) + (error 'simple-storage-condition + :format-control "Not enough memory left in static space to ~ + allocate vector.")) + (store-word widetag + vector 0 other-pointer-lowtag) + (store-word (ash length word-shift) + vector vector-length-slot other-pointer-lowtag) + (store-word 0 new-free) + (prog1 + (make-lisp-obj vector) + (setf *static-space-free-pointer* new-pointer)))) + (serious-condition (c) + ;; unwind from WITHOUT-GCING + (error c)))) + + \ No newline at end of file diff --git a/src/code/array.lisp b/src/code/array.lisp index 4022e11..9f1eb0f 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -160,7 +160,7 @@ type length (ceiling - (* (if (or (= type sb!vm:simple-base-string-widetag) + (* (if (or (= type sb!vm:simple-base-string-widetag) #!+sb-unicode (= type sb!vm:simple-character-string-widetag)) @@ -235,6 +235,51 @@ (incf axis))) array)))) +(defun make-static-vector (length &key + (element-type '(unsigned-byte 8)) + (initial-contents nil initial-contents-p) + (initial-element nil initial-element-p)) + "Allocate vector of LENGTH elements in static space. Only allocation +of specialized arrays is supported." + ;; STEP 1: check inputs fully + ;; + ;; This way of doing explicit checks before the vector is allocated + ;; is expensive, but probably worth the trouble as once we've allocated + ;; the vector we have no way to get rid of it anymore... + (when (eq t (upgraded-array-element-type element-type)) + (error "Static arrays of type ~S not supported." + element-type)) + (when initial-contents-p + (when initial-element-p + (error "can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) + (unless (= length (length initial-contents)) + (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~ + vector length is ~W." + (length initial-contents) + length)) + (unless (every (lambda (x) (typep x element-type)) initial-contents) + (error ":INITIAL-CONTENTS contains elements not of type ~S." + element-type))) + (when initial-element-p + (unless (typep initial-element element-type) + (error ":INITIAL-ELEMENT ~S is not of type ~S." + initial-element element-type))) + ;; STEP 2 + ;; + ;; Allocate and possibly initialize the vector. + (multiple-value-bind (type n-bits) + (sb!impl::%vector-widetag-and-n-bits element-type) + (let ((vector + (allocate-static-vector type length + (ceiling (* length n-bits) + sb!vm:n-word-bits)))) + (cond (initial-element-p + (fill vector initial-element)) + (initial-contents-p + (replace vector initial-contents)) + (t + vector))))) + ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of diff --git a/src/code/condition.lisp b/src/code/condition.lisp index f1e6e0d..4b62d88 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -775,6 +775,8 @@ .~:@>" '((fmakunbound 'compile)))))) +(define-condition simple-storage-condition (storage-condition simple-condition) ()) + ;;; a condition for use in stubs for operations which aren't supported ;;; on some platforms ;;; diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index a368a03..66114f0 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -23,7 +23,7 @@ (declaim (type index *gc-inhibit*)) (defvar *gc-inhibit*) ; initialized in cold init -(defmacro without-gcing (&rest body) +(defmacro without-gcing (&body body) #!+sb-doc "Executes the forms in the body without doing a garbage collection." `(unwind-protect diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index a4293d2..2920052 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -21,11 +21,11 @@ (inst mr ,n-dst ,n-src)))) (macrolet - ((frob (op inst shift) + ((def (op inst shift) `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) - (frob loadw lwz word-shift) - (frob storew stw word-shift)) + (def loadw lwz word-shift) + (def storew stw word-shift)) (defmacro load-symbol (reg symbol) `(inst addi ,reg null-tn (static-symbol-offset ,symbol))) @@ -218,7 +218,7 @@ ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN. -(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms) +(defmacro pseudo-atomic ((flag-tn &key (extra 0)) &body forms) (let ((n-extra (gensym))) `(let ((,n-extra ,extra)) (without-scheduling () diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp index 5ca6733..be01f98 100644 --- a/src/compiler/sparc/macros.lisp +++ b/src/compiler/sparc/macros.lisp @@ -21,11 +21,11 @@ (inst move ,n-dst ,n-src)))) (macrolet - ((frob (op inst shift) + ((def (op inst shift) `(defmacro ,op (object base &optional (offset 0) (lowtag 0)) `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))))) - (frob loadw ld word-shift) - (frob storew st word-shift)) + (def loadw ld word-shift) + (def storew st word-shift)) (defmacro load-symbol (reg symbol) `(inst add ,reg null-tn (static-symbol-offset ,symbol))) diff --git a/tests/static-alloc.impure.lisp b/tests/static-alloc.impure.lisp new file mode 100644 index 0000000..4709855 --- /dev/null +++ b/tests/static-alloc.impure.lisp @@ -0,0 +1,14 @@ + +(dolist (type '(single-float double-float (unsigned-byte 8) + (unsigned-byte 32) (signed-byte 32))) + (let* ((vectors (loop + for i upto 1024 + collect (sb-int:make-static-vector + 256 :element-type type))) + (saps (mapcar #'sb-sys:vector-sap vectors))) + (gc :full t) + (assert (every #'sb-sys:sap= + saps + (mapcar #'sb-sys:vector-sap vectors))))) + +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 1808bfb..63f589c 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.0.29" +"0.9.0.30" -- 1.7.10.4