src/code/alloc.lisp

   1 ;;;; Lisp-side allocation (used currently only for direct allocation
   2 ;;;; to static space).
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14
  15 #!-sb-fluid (declaim (inline store-word))
  16 (defun store-word (word base &optional (offset 0) (lowtag 0))
  17   (declare (type (unsigned-byte #.sb!vm:n-word-bits) word base offset)
  18            (type (unsigned-byte #.n-lowtag-bits) lowtag))
  19   (setf (sap-ref-word (int-sap base) (- (ash offset word-shift) lowtag)) word))
  20
  21 (defun allocate-static-vector (widetag length words)
  22   (declare (type (unsigned-byte #.n-widetag-bits) widetag)
  23            (type (unsigned-byte #.n-word-bits) words)
  24            (type index length))
  25   ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS
  26   (or
  27    (without-gcing
  28      (let* ((pointer *static-space-free-pointer*) ; in words
  29             (free (* pointer n-word-bytes))
  30             (vector (logior free other-pointer-lowtag)) ; in bytes, yay
  31             ;; rounded to dual word boundary
  32             (nwords (logandc2 (+ lowtag-mask (+ words vector-data-offset 1))
  33                               lowtag-mask))
  34             (new-pointer (+ *static-space-free-pointer* nwords))
  35             (new-free (* new-pointer n-word-bytes)))
  36        (when (> static-space-end new-free)
  37          (store-word widetag
  38                      vector 0 other-pointer-lowtag)
  39          (store-word (ash length word-shift)
  40                      vector vector-length-slot other-pointer-lowtag)
  41          (store-word 0 new-free)
  42          (setf *static-space-free-pointer* new-pointer)
  43          (%make-lisp-obj vector))))
  44    (error 'simple-storage-condition
  45           :format-control "Not enough memory left in static space to ~
  46                            allocate vector.")))
  47