Utility predicates for packing: UNBOUNDED-SC-P and UNBOUNDED-TN-P

[sbcl.git] / src / code / alloc.lisp

diff --git a/src/code/alloc.lisp b/src/code/alloc.lisp
index 866a9ee..c7b76f9 100644 (file)
--- a/src/code/alloc.lisp
+++ b/src/code/alloc.lisp
@@ -15,40 +15,32 @@
 #!-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))
+           (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))))
+           (type (unsigned-byte #.n-word-bits) words)
+           (type index length))
+  ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS
+  (or
+   (without-gcing
+     (let* ((pointer (ash *static-space-free-pointer* n-fixnum-tag-bits))
+            (vector (logior pointer other-pointer-lowtag))
+            ;; rounded to dual word boundary
+            (nwords (logandc2 (+ lowtag-mask (+ words vector-data-offset 1))
+                              lowtag-mask))
+            (new-pointer (+ pointer (ash nwords word-shift))))
+       (when (> static-space-end new-pointer)
+         (store-word widetag
+                     vector 0 other-pointer-lowtag)
+         (store-word (fixnumize length)
+                     vector vector-length-slot other-pointer-lowtag)
+         (store-word 0 new-pointer)
+         (setf *static-space-free-pointer*
+               (ash new-pointer (- n-fixnum-tag-bits)))
+         (%make-lisp-obj vector))))
+   (error 'simple-storage-condition
+          :format-control "Not enough memory left in static space to ~
+                           allocate vector.")))
 
-  
\ No newline at end of file