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 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 most-positive-fixnum
25 "The exclusive upper bound on the number of parameters which may be specifed
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 most-positive-fixnum
30 "The exclusive upper bound on the number of multiple VALUES that you can
33 (defconstant-eqx sb!xc:lambda-list-keywords
45 "symbols which are magical in a lambda list")
47 ;;;; cross-compiler-only versions of CL special variables, so that we
48 ;;;; don't have weird interactions with the host compiler
50 (defvar sb!xc:*compile-file-pathname*)
51 (defvar sb!xc:*compile-file-truename*)
52 (defvar sb!xc:*compile-print*)
53 (defvar sb!xc:*compile-verbose*)
55 ;;;; miscellaneous types used both in the cross-compiler and on the target
57 ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
58 ;;;; somewhere else, not "early-c", since they're after all not part
61 ;;; the type of LAYOUT-DEPTHOID slot values
62 (def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
64 ;;; possible values for the INLINE-ness of a function.
66 '(member :inline :maybe-inline :notinline nil))
67 (defparameter *inlinep-translations*
69 (notinline . :notinline)
70 (maybe-inline . :maybe-inline)))
72 ;;; the lexical environment we are currently converting in
74 (declaim (type lexenv *lexenv*))
76 ;;; *FREE-VARS* translates from the names of variables referenced
77 ;;; globally to the LEAF structures for them. *FREE-FUNS* is like
78 ;;; *FREE-VARS*, only it deals with function names.
81 (declaim (type hash-table *free-vars* *free-funs*))
83 ;;; We use the same CONSTANT structure to represent all equal anonymous
84 ;;; constants. This hashtable translates from constants to the LEAFs that
87 (declaim (type hash-table *constants*))
89 ;;; miscellaneous forward declarations
90 (defvar *code-segment*)
91 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
92 (defvar *component-being-compiled*)
93 (defvar *compiler-error-context*)
94 (defvar *compiler-error-count*)
95 (defvar *compiler-warning-count*)
96 (defvar *compiler-style-warning-count*)
97 (defvar *compiler-note-count*)
98 (defvar *compiler-trace-output*)
99 (defvar *constraint-number*)
100 (defvar *count-vop-usages*)
101 (defvar *current-path*)
102 (defvar *current-component*)
103 (defvar *delayed-ir1-transforms*)
104 (defvar *handled-conditions*)
106 (defvar *dynamic-counts-tn*)
108 (defvar *event-info*)
109 (defvar *event-note-threshold*)
111 (defvar *fixup-notes*)
113 (defvar *info-environment*)
115 (defvar *source-info*)
116 (defvar *trace-table*)
117 (defvar *undefined-warnings*)
118 (defvar *warnings-p*)
120 ;;; This lock is seized in the compiler, and related areas: the
121 ;;; compiler is not presently thread-safe
122 (defvar *big-compiler-lock*
123 (sb!thread:make-mutex :name "big compiler lock"))
125 ;;; unique ID for the next object created (to let us track object
126 ;;; identity even across GC, useful for understanding weird compiler
127 ;;; bugs where something is supposed to be unique but is instead
128 ;;; exists as duplicate objects)
131 (defvar *object-id-counter* 0)
132 (defun new-object-id ()
135 (incf *object-id-counter*))))
137 ;;;; miscellaneous utilities
139 ;;; Delete any undefined warnings for NAME and KIND. This is for the
140 ;;; benefit of the compiler, but it's sometimes called from stuff like
141 ;;; type-defining code which isn't logically part of the compiler.
142 (declaim (ftype (function ((or symbol cons) keyword) (values))
144 (defun note-name-defined (name kind)
145 ;; We do this BOUNDP check because this function can be called when
146 ;; not in a compilation unit (as when loading top level forms).
147 (when (boundp '*undefined-warnings*)
148 (setq *undefined-warnings*
149 (delete-if (lambda (x)
150 (and (equal (undefined-warning-name x) name)
151 (eq (undefined-warning-kind x) kind)))
152 *undefined-warnings*)))
155 ;;; to be called when a variable is lexically bound
156 (declaim (ftype (function (symbol) (values)) note-lexical-binding))
157 (defun note-lexical-binding (symbol)
158 ;; This check is intended to protect us from getting silently
159 ;; burned when we define
162 ;; (DEFUN FOO (X) (+ X *FOO*))
167 ;; and then we happen to compile bar.lisp before foo.lisp.
168 (when (looks-like-name-of-special-var-p symbol)
169 ;; FIXME: should be COMPILER-STYLE-WARNING?
170 (style-warn "using the lexical binding of the symbol ~S, not the~@
171 dynamic binding, even though the symbol name follows the usual naming~@
172 convention (names like *FOO*) for special variables" symbol))
175 ;;; Hacky (duplicating machinery found elsewhere because this function
176 ;;; turns out to be on a critical path in the compiler) shorthand for
177 ;;; creating debug names from source names or other stems, e.g.
179 ;;; (DEBUG-NAMIFY "FLET " SOURCE-NAME) -> "FLET FOO:BAR"
180 ;;; (DEBUG-NAMIFY "top level form " FORM) -> "top level form (QUUX :FOO)"
182 ;;; If ALT is given it must be a string -- it is then used in place of
183 ;;; either HEAD or TAIL if either of them is EQ to SB-C::.ANONYMOUS.
185 (declaim (inline debug-namify))
186 (defun debug-namify (head tail &optional alt)
187 (declare (type (or null string) alt))
188 (flet ((symbol-debug-name (symbol)
189 ;; KLUDGE: (OAOOM warning) very much akin to OUTPUT-SYMBOL.
190 (if (and alt (eq '.anonymous. symbol))
192 (let ((package (symbol-package symbol))
193 (name (symbol-name symbol)))
195 ((eq package *keyword-package*)
196 (concatenate 'string ":" name))
197 ((eq package *cl-package*)
200 (concatenate 'string "#:" name))
202 (multiple-value-bind (symbol status)
203 (find-symbol name package)
204 (declare (ignore symbol))
206 (package-name package)
207 (if (eq status :external) ":" "::")
209 (cond ((and (stringp head) (stringp tail))
210 (concatenate 'string head tail))
211 ((and (stringp head) (symbolp tail))
212 (concatenate 'string head (symbol-debug-name tail)))
213 ((and (symbolp head) (stringp tail))
214 (concatenate 'string (symbol-debug-name head) tail))
216 (macrolet ((out (obj s)
218 (string (write-string ,obj ,s))
219 (symbol (write-string (symbol-debug-name ,obj) ,s))
220 (t (prin1 ,obj ,s)))))
221 (with-standard-io-syntax
222 (let ((*print-readably* nil)
224 (*package* *cl-package*)
227 (with-output-to-string (s)