+;;;; 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