1 ;;;; This file contains compiler code and compiler-related stuff which
2 ;;;; can be built early on. Some of the stuff may be here because it's
3 ;;;; needed early on, some other stuff (e.g. constants) just because
4 ;;;; it might as well be done early so we don't have to think about
5 ;;;; whether it's done early enough.
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
18 ;;; ANSI limits on compilation
19 (def!constant sb
!xc
:call-arguments-limit sb
!xc
:most-positive-fixnum
21 "The exclusive upper bound on the number of arguments which may be passed
22 to a function, including &REST args.")
23 (def!constant sb
!xc
:lambda-parameters-limit sb
!xc
:most-positive-fixnum
25 "The exclusive upper bound on the number of parameters which may be specified
26 in a given lambda list. This is actually the limit on required and &OPTIONAL
27 parameters. With &KEY and &AUX you can get more.")
28 (def!constant sb
!xc
:multiple-values-limit sb
!xc
:most-positive-fixnum
30 "The exclusive upper bound on the number of multiple VALUES that you can
33 ;;;; cross-compiler-only versions of CL special variables, so that we
34 ;;;; don't have weird interactions with the host compiler
36 (defvar sb
!xc
:*compile-file-pathname
*)
37 (defvar sb
!xc
:*compile-file-truename
*)
38 (defvar sb
!xc
:*compile-print
*)
39 (defvar sb
!xc
:*compile-verbose
*)
41 ;;;; miscellaneous types used both in the cross-compiler and on the target
43 ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
44 ;;;; somewhere else, not "early-c", since they're after all not part
47 ;;; the type of LAYOUT-DEPTHOID slot values
48 (def!type layout-depthoid
() '(or index
(integer -
1 -
1)))
49 (def!type layout-bitmap
()
50 ;; FIXME: Probably should exclude negative bignum
51 #!+compact-instance-header
'integer
52 #!-compact-instance-header
'(and integer
(not (eql 0))))
54 ;;; An INLINEP value describes how a function is called. The values
55 ;;; have these meanings:
56 ;;; NIL No declaration seen: do whatever you feel like, but don't
57 ;;; dump an inline expansion.
58 ;;; :NOTINLINE NOTINLINE declaration seen: always do full function call.
59 ;;; :INLINE INLINE declaration seen: save expansion, expanding to it
62 ;;; Retain expansion, but only use it opportunistically.
63 ;;; :MAYBE-INLINE is quite different from :INLINE. As explained
64 ;;; by APD on #lisp 2005-11-26: "MAYBE-INLINE lambda is
65 ;;; instantiated once per component, INLINE - for all
66 ;;; references (even under #'without FUNCALL)."
68 '(member :inline
:maybe-inline
:notinline nil
))
69 (defparameter *inlinep-translations
*
71 (notinline .
:notinline
)
72 (maybe-inline .
:maybe-inline
)))
74 ;;; *FREE-VARS* translates from the names of variables referenced
75 ;;; globally to the LEAF structures for them. *FREE-FUNS* is like
76 ;;; *FREE-VARS*, only it deals with function names.
79 (declaim (type hash-table
*free-vars
* *free-funs
*))
81 ;;; We use the same CONSTANT structure to represent all equal anonymous
82 ;;; constants. This hashtable translates from constants to the LEAFs that
85 (declaim (type hash-table
*constants
*))
87 ;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
88 ;;; insertion of instrumenting code (like a (CATCH ...)) around code
89 ;;; to allow the debugger RETURN and STEP commands to function (we
90 ;;; disallow it for internal stuff).
91 (defvar *allow-instrumenting
*)
93 ;;; miscellaneous forward declarations
94 (defvar *code-segment
*)
95 #!+sb-dyncount
(defvar *collect-dynamic-statistics
*)
96 (defvar *component-being-compiled
*)
97 (defvar *compiler-error-context
*)
98 (defvar *compiler-error-count
*)
99 (defvar *compiler-warning-count
*)
100 (defvar *compiler-style-warning-count
*)
101 (defvar *compiler-note-count
*)
102 (defvar *compiler-trace-output
*)
103 (defvar *constraint-universe
*)
104 (defvar *current-path
*)
105 (defvar *current-component
*)
106 (defvar *delayed-ir1-transforms
*)
107 (defvar *eval-tlf-index
*)
108 (defvar *dynamic-counts-tn
*)
110 (defvar *event-info
*)
111 (defvar *event-note-threshold
*)
113 (defvar *fixup-notes
*)
116 (defvar *unboxed-constants
*)
117 (defstruct (unboxed-constants (:conc-name constant-
)
118 (:predicate nil
) (:copier nil
))
119 (table (make-hash-table :test
#'equal
) :read-only t
)
121 (sb!assem
:make-segment
:type
:elsewhere
123 :inst-hook
(default-segment-inst-hook)
124 :alignment
0) :read-only t
)
125 (vector (make-array 16 :adjustable t
:fill-pointer
0) :read-only t
))
126 (declaim (freeze-type unboxed-constants
)))
127 (defvar *source-info
*)
128 (defvar *source-plist
*)
129 (defvar *source-namestring
*)
130 (defvar *undefined-warnings
*)
131 (defvar *warnings-p
*)
132 (defvar *lambda-conversions
*)
134 (defvar *stack-allocate-dynamic-extent
* t
136 "If true (the default), the compiler respects DYNAMIC-EXTENT declarations
137 and stack allocates otherwise inaccessible parts of the object whenever
138 possible. Potentially long (over one page in size) vectors are, however, not
139 stack allocated except in zero SAFETY code, as such a vector could overflow
140 the stack without triggering overflow protection.")
142 (!begin-collecting-cold-init-forms
)
143 ;;; This lock is seized in the compiler, and related areas -- like the
144 ;;; classoid/layout/class system.
145 (defglobal **world-lock
** nil
)
147 (setf **world-lock
** (sb!thread
:make-mutex
:name
"World Lock")))
148 (!defun-from-collected-cold-init-forms
!world-lock-cold-init
)
150 (defmacro with-world-lock
(() &body body
)
151 `(sb!thread
:with-recursive-lock
(**world-lock
**)
154 (declaim (type fixnum
*compiler-sset-counter
*))
155 (defvar *compiler-sset-counter
* 0)
157 ;;; unique ID for the next object created (to let us track object
158 ;;; identity even across GC, useful for understanding weird compiler
159 ;;; bugs where something is supposed to be unique but is instead
160 ;;; exists as duplicate objects)
163 (defvar *object-id-counter
* 0)
164 (defun new-object-id ()
167 (incf *object-id-counter
*))))
169 ;;;; miscellaneous utilities
171 ;;; This is for "observers" who want to know if type names have been added.
172 ;;; Rather than registering listeners, they can detect changes by comparing
173 ;;; their stored nonce to the current nonce. Additionally the observers
174 ;;; can detect whether function definitions have occurred.
175 (declaim (fixnum *type-cache-nonce
*))
176 (!defglobal
*type-cache-nonce
* 0)
178 (def!struct
(undefined-warning
179 #-no-ansi-print-object
180 (:print-object
(lambda (x s
)
181 (print-unreadable-object (x s
:type t
)
182 (prin1 (undefined-warning-name x
) s
))))
184 ;; the name of the unknown thing
185 (name nil
:type
(or symbol list
))
186 ;; the kind of reference to NAME
187 (kind (missing-arg) :type
(member :function
:type
:variable
))
188 ;; the number of times this thing was used
189 (count 0 :type unsigned-byte
)
190 ;; a list of COMPILER-ERROR-CONTEXT structures describing places
191 ;; where this thing was used. Note that we only record the first
192 ;; *UNDEFINED-WARNING-LIMIT* calls.
193 (warnings () :type list
))
195 ;;; Delete any undefined warnings for NAME and KIND. This is for the
196 ;;; benefit of the compiler, but it's sometimes called from stuff like
197 ;;; type-defining code which isn't logically part of the compiler.
198 (declaim (ftype (function ((or symbol cons
) keyword
) (values))
200 (defun note-name-defined (name kind
)
201 #-sb-xc-host
(atomic-incf *type-cache-nonce
*)
202 ;; We do this BOUNDP check because this function can be called when
203 ;; not in a compilation unit (as when loading top level forms).
204 (when (boundp '*undefined-warnings
*)
205 (let ((name (uncross name
)))
206 (setq *undefined-warnings
*
207 (delete-if (lambda (x)
208 (and (equal (undefined-warning-name x
) name
)
209 (eq (undefined-warning-kind x
) kind
)))
210 *undefined-warnings
*))))
213 ;;; to be called when a variable is lexically bound
214 (declaim (ftype (function (symbol) (values)) note-lexical-binding
))
215 (defun note-lexical-binding (symbol)
216 ;; This check is intended to protect us from getting silently
217 ;; burned when we define
220 ;; (DEFUN FOO (X) (+ X *FOO*))
225 ;; and then we happen to compile bar.lisp before foo.lisp.
226 (when (looks-like-name-of-special-var-p symbol
)
227 ;; FIXME: should be COMPILER-STYLE-WARNING?
228 (style-warn 'asterisks-around-lexical-variable-name
230 "using the lexical binding of the symbol ~
231 ~/sb-impl::print-symbol-with-prefix/, not the~@
233 :format-arguments
(list symbol
)))
236 (def!struct
(debug-name-marker (:print-function print-debug-name-marker
)))
238 (defvar *debug-name-level
* 4)
239 (defvar *debug-name-length
* 12)
240 (defvar *debug-name-punt
*)
241 (defvar *debug-name-sharp
*)
242 (defvar *debug-name-ellipsis
*)
244 (defmethod make-load-form ((marker debug-name-marker
) &optional env
)
245 (declare (ignore env
))
246 (cond ((eq marker
*debug-name-sharp
*)
247 `(if (boundp '*debug-name-sharp
*)
249 (make-debug-name-marker)))
250 ((eq marker
*debug-name-ellipsis
*)
251 `(if (boundp '*debug-name-ellipsis
*)
252 *debug-name-ellipsis
*
253 (make-debug-name-marker)))
255 (warn "Dumping unknown debug-name marker.")
256 '(make-debug-name-marker))))
258 (defun print-debug-name-marker (marker stream level
)
259 (declare (ignore level
))
260 (cond ((eq marker
*debug-name-sharp
*)
261 (write-char #\
# stream
))
262 ((eq marker
*debug-name-ellipsis
*)
263 (write-string "..." stream
))
265 (write-string "???" stream
))))
267 (setf *debug-name-sharp
* (make-debug-name-marker)
268 *debug-name-ellipsis
* (make-debug-name-marker))
270 (declaim (ftype (sfunction () list
) name-context
))
271 (defun debug-name (type thing
&optional context
)
272 (let ((*debug-name-punt
* nil
))
276 (if (plusp *debug-name-level
*)
277 (let ((*debug-name-level
* (1- *debug-name-level
*)))
278 (do ((tail (cdr x
) (cdr tail
))
279 (name (cons (walk (car x
)) nil
)
280 (cons (walk (car tail
)) name
))
281 (n (1- *debug-name-length
*) (1- n
)))
282 ((or (not (consp tail
))
285 (cond (*debug-name-punt
*
286 (setf *debug-name-punt
* nil
)
289 (nconc (nreverse name
) (walk tail
)))
291 (setf *debug-name-punt
* t
)
292 (nconc (nreverse name
) (list *debug-name-ellipsis
*)))))))
294 ((or symbol number string
)
298 (let ((name (list* type
(walk thing
) (when context
(name-context)))))
299 (when (legal-fun-name-p name
)
300 (bug "~S is a legal function name, and cannot be used as a ~
304 ;;; Set this to NIL to inhibit assembly-level optimization. (For
305 ;;; compiler debugging, rather than policy control.)
306 (defvar *assembly-optimize
* t
)
308 (in-package "SB!ALIEN")
310 ;;; Information describing a heap-allocated alien.
311 (def!struct
(heap-alien-info)
312 ;; The type of this alien.
313 (type (missing-arg) :type alien-type
)
315 (alien-name (missing-arg) :type simple-string
)
317 (datap (missing-arg) :type boolean
))
318 (!set-load-form-method heap-alien-info
(:xc
:target
))