(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))))
+ ;; 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.")))