1 ;;;; some code pulled out of CMU CL's low.lisp to solve build order problems,
2 ;;;; and some other stuff that just plain needs to be done early
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from software originally released by Xerox
8 ;;;; Corporation. Copyright and release statements follow. Later modifications
9 ;;;; to the software are in the public domain and are provided with
10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
13 ;;;; copyright information from original PCL sources:
15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
16 ;;;; All rights reserved.
18 ;;;; Use and copying of this software and preparation of derivative works based
19 ;;;; upon this software are permitted. Any distribution of this software or
20 ;;;; derivative works must comply with all applicable United States export
23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
24 ;;;; warranty about the software, its performance or its conformity to any
29 (declaim (type (member nil early braid complete
) **boot-state
**))
30 (defglobal **boot-state
** nil
)
32 (/show0
"starting early-low.lisp")
34 ;;; The PCL package is internal and is used by code in potential
35 ;;; bottlenecks. And since it's internal, no one should be
36 ;;; doing things like deleting and recreating it in a running target Lisp.
37 ;;; By the time we get to compiling the rest of PCL,
38 ;;; the package will have been renamed,
39 ;;; so subsequently compiled code should refer to "SB-PCL", not "SB!PCL".
40 (define-symbol-macro *pcl-package
* (load-time-value (find-package "SB-PCL") t
))
42 (declaim (inline class-classoid
))
43 (defun class-classoid (class)
44 (layout-classoid (class-wrapper class
)))
46 (declaim (inline defstruct-classoid-p
))
47 (defun defstruct-classoid-p (classoid)
48 ;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't
49 ;; work instead of this. -- NS 2008-03-14
50 (typep (layout-info (classoid-layout classoid
)) 'defstruct-description
))
52 ;;; This excludes structure types created with the :TYPE option to
53 ;;; DEFSTRUCT. It also doesn't try to deal with types created by
54 ;;; hairy DEFTYPEs, e.g.
55 ;;; (DEFTYPE CACHE-STRUCTURE (SIZE)
56 ;;; (IF (> SIZE 11) 'BIG-CS 'SMALL-CS)).
57 ;;; KLUDGE: In fact, it doesn't seem to deal with DEFTYPEs at all. Perhaps
58 ;;; it needs a more mnemonic name. -- WHN 19991204
59 (defun structure-type-p (type)
61 (let ((classoid (find-classoid type nil
)))
63 (not (condition-classoid-p classoid
))
64 (defstruct-classoid-p classoid
)))))
66 ;;; Symbol contruction utilities
67 (defun format-symbol (package format-string
&rest format-arguments
)
68 (without-package-locks
69 (intern (possibly-base-stringize
70 (apply #'format nil format-string format-arguments
))
73 (defun make-class-symbol (class-name)
74 ;; Reference a package that is now SB!PCL but later SB-PCL
75 (format-symbol (load-time-value (find-package "SB!PCL") t
)
76 "*THE-CLASS-~A*" (symbol-name class-name
)))
78 (defun condition-type-p (type)
80 (condition-classoid-p (find-classoid type nil
))))
83 (declaim (global *the-class-t
*
84 *the-class-vector
* *the-class-symbol
*
85 *the-class-string
* *the-class-sequence
*
86 *the-class-rational
* *the-class-ratio
*
87 *the-class-number
* *the-class-null
* *the-class-list
*
88 *the-class-integer
* *the-class-float
* *the-class-cons
*
89 *the-class-complex
* *the-class-character
*
90 *the-class-bit-vector
* *the-class-array
*
91 *the-class-stream
* *the-class-file-stream
*
92 *the-class-string-stream
*
94 *the-class-slot-object
*
95 *the-class-structure-object
*
96 *the-class-standard-object
*
98 *the-class-funcallable-standard-object
*
100 *the-class-generic-function
*
101 *the-class-system-class
*
102 *the-class-built-in-class
*
103 *the-class-slot-class
*
104 *the-class-condition-class
*
105 *the-class-structure-class
*
106 *the-class-std-class
*
107 *the-class-standard-class
*
108 *the-class-funcallable-standard-class
*
109 *the-class-forward-referenced-class
*
111 *the-class-standard-method
*
112 *the-class-standard-reader-method
*
113 *the-class-standard-writer-method
*
114 *the-class-standard-boundp-method
*
115 *the-class-global-reader-method
*
116 *the-class-global-writer-method
*
117 *the-class-global-boundp-method
*
118 *the-class-standard-generic-function
*
119 *the-class-standard-direct-slot-definition
*
120 *the-class-standard-effective-slot-definition
*
121 *the-class-standard-specializer
*
123 *the-eslotd-standard-class-slots
*
124 *the-eslotd-funcallable-standard-class-slots
*))
127 (sb!kernel
::!defstruct-with-alternate-metaclass standard-instance
128 ;; KLUDGE: arm64 needs to have CAS-HEADER-DATA-HIGH implemented
129 :slot-names
(slots #!-
(and compact-instance-header x86-64
) hash-code
)
130 :boa-constructor %make-standard-instance
132 :metaclass-name standard-classoid
133 :metaclass-constructor make-standard-classoid
135 :runtime-type-checks-p nil
)
137 ;;; TODO: for x8-64 with #!+immobile-code, we would like 2 additional unboxed
138 ;;; words to hold the trampline instructions to avoid consing a piece of code
139 ;;; to jump to this function. It should be "as if" a simple-fun, in as much as
140 ;;; there's an address you can jump to without loading a register.
141 (sb!kernel
::!defstruct-with-alternate-metaclass standard-funcallable-instance
142 ;; KLUDGE: Note that neither of these slots is ever accessed by its
143 ;; accessor name as of sbcl-0.pre7.63. Presumably everything works
144 ;; by puns based on absolute locations. Fun fun fun.. -- WHN 2001-10-30
145 :slot-names
(clos-slots #!-compact-instance-header hash-code
)
146 :boa-constructor %make-standard-funcallable-instance
147 :superclass-name function
148 :metaclass-name standard-classoid
149 :metaclass-constructor make-standard-classoid
150 :dd-type funcallable-structure
151 ;; Only internal implementation code will access these, and these
152 ;; accesses (slot readers in particular) could easily be a
153 ;; bottleneck, so it seems reasonable to suppress runtime type
156 ;; (Except note KLUDGE above that these accessors aren't used at all
157 ;; (!) as of sbcl-0.pre7.63, so for now it's academic.)
158 :runtime-type-checks-p nil
)
160 #!+(and compact-instance-header
(not x86-64
))
161 (defconstant std-instance-hash-slot-index
1)
162 #!-compact-instance-header
164 (defconstant std-instance-hash-slot-index
2)
165 ;; The first data slot (either index 0 or 1) in the primitive funcallable
166 ;; instance is the vector of CLOS slots. Following that is the hash.
167 (defconstant fsc-instance-hash-slot-index
(1+ sb
!vm
:instance-data-start
)))
169 (/show0
"finished with early-low.lisp")