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 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 sb
!xc
: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 ;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
90 ;;; insertion of instrumenting code (like a (CATCH ...)) around code
91 ;;; to allow the debugger RETURN and STEP commands to function (we
92 ;;; disallow it for internal stuff).
93 (defvar *allow-instrumenting
*)
95 ;;; miscellaneous forward declarations
96 (defvar *code-segment
*)
97 #!+sb-dyncount
(defvar *collect-dynamic-statistics
*)
98 (defvar *component-being-compiled
*)
99 (defvar *compiler-error-context
*)
100 (defvar *compiler-error-count
*)
101 (defvar *compiler-warning-count
*)
102 (defvar *compiler-style-warning-count
*)
103 (defvar *compiler-note-count
*)
104 (defvar *compiler-trace-output
*)
105 (defvar *constraint-number
*)
106 (defvar *count-vop-usages
*)
107 (defvar *current-path
*)
108 (defvar *current-component
*)
109 (defvar *delayed-ir1-transforms
*)
110 (defvar *handled-conditions
*)
111 (defvar *disabled-package-locks
*)
113 (defvar *dynamic-counts-tn
*)
115 (defvar *event-info
*)
116 (defvar *event-note-threshold
*)
118 (defvar *fixup-notes
*)
120 (defvar *info-environment
*)
122 (defvar *source-info
*)
123 (defvar *trace-table
*)
124 (defvar *undefined-warnings
*)
125 (defvar *warnings-p
*)
126 (defvar *lambda-conversions
*)
128 ;;; This lock is seized in the compiler, and related areas: the
129 ;;; compiler is not presently thread-safe
130 (defvar *big-compiler-lock
*
131 (sb!thread
:make-mutex
:name
"big compiler lock"))
133 (declaim (type fixnum
*compiler-sset-counter
*))
134 (defvar *compiler-sset-counter
* 0)
136 ;;; unique ID for the next object created (to let us track object
137 ;;; identity even across GC, useful for understanding weird compiler
138 ;;; bugs where something is supposed to be unique but is instead
139 ;;; exists as duplicate objects)
142 (defvar *object-id-counter
* 0)
143 (defun new-object-id ()
146 (incf *object-id-counter
*))))
148 ;;;; miscellaneous utilities
150 ;;; Delete any undefined warnings for NAME and KIND. This is for the
151 ;;; benefit of the compiler, but it's sometimes called from stuff like
152 ;;; type-defining code which isn't logically part of the compiler.
153 (declaim (ftype (function ((or symbol cons
) keyword
) (values))
155 (defun note-name-defined (name kind
)
156 ;; We do this BOUNDP check because this function can be called when
157 ;; not in a compilation unit (as when loading top level forms).
158 (when (boundp '*undefined-warnings
*)
159 (setq *undefined-warnings
*
160 (delete-if (lambda (x)
161 (and (equal (undefined-warning-name x
) name
)
162 (eq (undefined-warning-kind x
) kind
)))
163 *undefined-warnings
*)))
166 ;;; to be called when a variable is lexically bound
167 (declaim (ftype (function (symbol) (values)) note-lexical-binding
))
168 (defun note-lexical-binding (symbol)
169 ;; This check is intended to protect us from getting silently
170 ;; burned when we define
173 ;; (DEFUN FOO (X) (+ X *FOO*))
178 ;; and then we happen to compile bar.lisp before foo.lisp.
179 (when (looks-like-name-of-special-var-p symbol
)
180 ;; FIXME: should be COMPILER-STYLE-WARNING?
181 (style-warn "using the lexical binding of the symbol ~S, not the~@
182 dynamic binding, even though the symbol name follows the usual naming~@
183 convention (names like *FOO*) for special variables" symbol
))
186 (def!struct
(debug-name-marker (:make-load-form-fun dump-debug-name-marker
)
187 (:print-function print-debug-name-marker
)))
189 (defvar *debug-name-level
* 4)
190 (defvar *debug-name-length
* 12)
191 (defvar *debug-name-punt
*)
192 (defvar *debug-name-sharp
*)
193 (defvar *debug-name-ellipsis
*)
195 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
196 (defun dump-debug-name-marker (marker &optional env
)
197 (declare (ignore env
))
198 (cond ((eq marker
*debug-name-sharp
*)
199 `(if (boundp '*debug-name-sharp
*)
201 (make-debug-name-marker)))
202 ((eq marker
*debug-name-ellipsis
*)
203 `(if (boundp '*debug-name-ellipsis
*)
204 *debug-name-ellipsis
*
205 (make-debug-name-marker)))
207 (warn "Dumping unknown debug-name marker.")
208 '(make-debug-name-marker)))))
210 (defun print-debug-name-marker (marker stream level
)
211 (declare (ignore level
))
212 (cond ((eq marker
*debug-name-sharp
*)
213 (write-char #\
# stream
))
214 ((eq marker
*debug-name-ellipsis
*)
215 (write-string "..." stream
))
217 (write-string "???" stream
))))
219 (setf *debug-name-sharp
* (make-debug-name-marker)
220 *debug-name-ellipsis
* (make-debug-name-marker))
222 (defun debug-name (type thing
)
223 ;; We can _always_ do better thing NIL for this.
225 (let ((*debug-name-punt
* nil
))
229 (if (plusp *debug-name-level
*)
230 (let ((*debug-name-level
* (1- *debug-name-level
*)))
231 (do ((tail (cdr x
) (cdr tail
))
232 (name (cons (walk (car x
)) nil
)
233 (cons (walk (car tail
)) name
))
234 (n (1- *debug-name-length
*) (1- n
)))
235 ((or (not (consp tail
))
238 (cond (*debug-name-punt
*
239 (setf *debug-name-punt
* nil
)
242 (nconc (nreverse name
) (walk tail
)))
244 (setf *debug-name-punt
* t
)
245 (nconc (nreverse name
) (list *debug-name-ellipsis
*)))))))
247 ((or symbol number string
)
251 (let ((name (list type
(walk thing
))))
252 (when (legal-fun-name-p name
)
253 (bug "~S is a legal function name, and cannot be used as a ~