("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)
;; 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"
;; need it:
"*EOF-OBJECT*"
+ ;; allocation to static space
+ "MAKE-STATIC-VECTOR"
+
;; alien interface utilities
"C-STRINGS->STRING-LIST"
"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"
(: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))
+
(: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)
--- /dev/null
+;;;; 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
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))
(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
<http://sbcl.sourceforge.net/>.~:@>"
'((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
;;;
(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
(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)))
;;; 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 ()
(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)))
--- /dev/null
+
+(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)
;;; 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"
projects / sbcl.git / commitdiff