1.0.20: release, will be tagged sbcl_1_0_20
[sbcl/eslaughter.git] / src / code / alloc.lisp
blob4bdb9fea4f26799c80a07a39c40aff672616fbc2
1 ;;;; Lisp-side allocation (used currently only for direct allocation
2 ;;;; to static space).
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.
13 (in-package "SB!VM")
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))
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 (handler-case
26 ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS
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 (unless (> static-space-end new-free)
37 (error 'simple-storage-condition
38 :format-control "Not enough memory left in static space to ~
39 allocate vector."))
40 (store-word widetag
41 vector 0 other-pointer-lowtag)
42 (store-word (ash length word-shift)
43 vector vector-length-slot other-pointer-lowtag)
44 (store-word 0 new-free)
45 (setf *static-space-free-pointer* new-pointer)
46 (%make-lisp-obj vector)))
47 (serious-condition (c)
48 ;; unwind from WITHOUT-GCING
49 (error c))))