1 ;;;; functions from classic CMU CL src/compiler/main.lisp which are
2 ;;;; needed only (and which may make sense only) on the
3 ;;;; cross-compilation target, not the cross-compilation host
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
18 (defun ir1-toplevel-for-compile (form name
)
19 (let* ((component (make-empty-component))
20 (*current-component
* component
)
21 (debug-name-tail (or name
(name-lambdalike form
)))
22 (source-name (or name
'.anonymous.
)))
23 (setf (component-name component
) (debug-name 'initial-component debug-name-tail
)
24 (component-kind component
) :initial
)
25 (let* ((fun (let ((*allow-instrumenting
* t
))
26 (ir1-convert-lambdalike form
27 :source-name source-name
)))
28 ;; Convert the XEP using the policy of the real function. Otherwise
29 ;; the wrong policy will be used for deciding whether to type-check
30 ;; the parameters of the real function (via CONVERT-CALL /
31 ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27
32 (*lexenv
* (make-lexenv :policy
(lexenv-policy (functional-lexenv fun
))))
33 (xep (ir1-convert-lambda (make-xep-lambda-expression fun
)
34 :source-name source-name
35 :debug-name
(debug-name 'tl-xep debug-name-tail
))))
37 (assert-new-definition xep fun
))
38 (setf (functional-kind xep
) (functional-kind-attributes external
)
39 (functional-entry-fun xep
) fun
40 (functional-entry-fun fun
) xep
41 (component-reanalyze component
) t
42 (functional-has-external-references-p xep
) t
)
43 (reoptimize-component component
:maybe
)
44 (locall-analyze-xep-entry-point fun
)
45 ;; Any leftover REFs to FUN outside local calls get replaced with the
47 (substitute-leaf-if (lambda (ref)
48 (let* ((lvar (ref-lvar ref
))
49 (dest (when lvar
(lvar-dest lvar
)))
50 (kind (when (basic-combination-p dest
)
51 (basic-combination-kind dest
))))
57 ;;; Compile LAMBDA-EXPRESSION and return the compiled FUNCTION value.
59 ;;; If NAME is provided, then we try to use it as the name of the
60 ;;; function for debugging/diagnostic information.
61 (defun %compile
(form ephemeral name
)
63 (legal-fun-name-or-type-error name
))
65 (let* ((*lexenv
* (make-lexenv
67 :handled-conditions
*handled-conditions
*
68 :disabled-package-locks
*disabled-package-locks
*))
69 (*compile-object
* (make-core-object ephemeral
))
70 (lambda (ir1-toplevel-for-compile form name
)))
72 ;; FIXME: The compile-it code from here on is sort of a
73 ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be
74 ;; better to find a way to share the code there; or
75 ;; alternatively, to use this code to replace the code there.
76 ;; (The second alternative might be pretty easy if we used
77 ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the
78 ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..)
80 (locall-analyze-clambdas-until-done (list lambda
))
82 (dolist (component (find-initial-dfo (list lambda
)))
83 (compile-component component
))
85 (let ((object *compile-object
*))
86 (multiple-value-bind (res found-p
)
87 (gethash (leaf-info lambda
) (core-object-entry-table object
))
89 (fix-core-source-info *source-info
* object
90 (and (policy (lambda-bind lambda
)
91 (> store-source-form
0))
95 ;;; Handle the following:
96 ;;; - CL:COMPILE when the argument is not already a compiled function.
97 ;;; - %SIMPLE-EVAL in "pretend we don't have an interpreter" mode
98 ;;; a/k/a "compile all the things"
99 ;;; - SB-INTERPRETER::EVAL-IN-ENVIRONMENT when it can't just do that.
101 ;;; If ERORRP is true signals an error immediately -- otherwise returns
102 ;;; a function that will signal the error.
103 (defun compile-in-lexenv (form *lexenv
* name source-info tlf ephemeral errorp
)
104 (let ((source-paths (when source-info
*source-paths
*)))
105 (with-compilation-values
106 (with-compilation-unit ()
107 ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
108 ;; few changes. Once things are stable, the shared bindings
109 ;; probably be merged back together into some shared utility
110 ;; macro, or perhaps both merged into one of the existing utility
111 ;; macros SB-C::WITH-COMPILATION-VALUES or
112 ;; CL:WITH-COMPILATION-UNIT.
114 (prog* ((tlf (or tlf
0))
115 ;; If we have a source-info from LOAD, we will
116 ;; also have a source-paths already set up -- so drop
117 ;; the ones from WITH-COMPILATION-VALUES.
118 (*source-paths
* (or source-paths
*source-paths
*))
119 (*source-info
* (or source-info
120 (make-lisp-source-info
121 form
:parent
*source-info
*)))
122 (*allow-instrumenting
* nil
)
126 (and (member :msan
*features
*)
127 (find-dynamic-foreign-symbol-address "__msan_unpoison"))
129 (*last-message-count
* (list* 0 nil nil
))
130 (*last-error-context
* nil
)
132 ;; KLUDGE: This rebinding of policy is necessary so that
133 ;; forms such as LOCALLY at the REPL actually extend the
134 ;; compilation policy correctly. However, there is an
135 ;; invariant that is potentially violated: future
136 ;; refactoring must not allow this to be done in the file
137 ;; compiler. At the moment we're clearly alright, as we
138 ;; call %COMPILE with a core-object, not a fasl-stream,
139 ;; but caveat future maintainers. -- CSR, 2002-10-27
140 (*policy
* (lexenv-policy *lexenv
*))
142 (*handled-conditions
* (lexenv-handled-conditions *lexenv
*))
144 (*disabled-package-locks
* (lexenv-disabled-package-locks *lexenv
*))
145 ;; FIXME: ANSI doesn't say anything about CL:COMPILE
146 ;; interacting with these variables, so we shouldn't. As
147 ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
148 ;; binding these variables, so as a quick hack we do so
149 ;; too. But a proper implementation would have verbosity
150 ;; controlled by function arguments and lexical variables.
151 (*compile-verbose
* nil
)
152 (*compile-print
* nil
)
153 ;; in some circumstances, we can trigger execution
154 ;; of user code during optimization, which can
155 ;; re-enter the compiler through explicit calls to
156 ;; EVAL or COMPILE. Those inner evaluations
157 ;; shouldn't attempt to report any compiler problems
158 ;; using the outer compiler error context.
159 (*compiler-error-context
* nil
)
161 (handler-bind (((satisfies handle-condition-p
) 'handle-condition-handler
))
163 (find-source-paths form tlf
))
164 (let ((*current-path
* (or (get-source-path form
)
165 (cons form
(or (and (boundp '*current-path
*)
167 `(original-source-start 0 ,tlf
)))))
168 (*compiler-error-bailout
*
171 ;; Unwind the compiler frames: users want the know where
172 ;; the error came from, not how the compiler got there.
175 (%compile form ephemeral name
))))
177 ;; Either signal the error right away, or return a function that
178 ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
179 ;; that we retain our earlier behaviour when called with erronous
180 ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
181 ;; always, but right now keeping the old behaviour seems like less
182 ;; painful option: compiler.pure.lisp is full of tests that make all
183 ;; sort of assumptions about when which things are signalled. FIXME,
187 (let ((message (princ-to-string oops
))
188 (source (source-to-string form
)))
190 (lambda (&rest arguments
)
191 (declare (ignore arguments
))
192 (error 'compiled-program-error
194 :source source
)))))))))))
196 ;;; NOTE: COMPILE may be slightly nonconforming regarding generic functions,
197 ;;; but no more nonconforming than it was prior to the redefinition of
198 ;;; COMPILED-FUNCTION to exclude GENERIC-FUNCTION.
199 ;;; The concern stems from http://www.lispworks.com/documentation/HyperSpec/Issues/iss064_w.htm
200 ;;; which says "(4) Clarify that COMPILE must produce an object of type COMPILED-FUNCTION."
202 ;;; In the case where DEFINITION is given, we're fine: the compiler can only return
203 ;;; a compiled function. But if only NAME is given, and it is fboundp to a generic-function,
204 ;;; we don't do anything at all - we don't touch the GF's dispatch function (which is a closure
205 ;;; over compiled code) and we don't touch the methods. But COMPILE doesn't return a function
206 ;;; in that case, so it's not wrong that COMPILED-FUNCTION-P is false of the result,
207 ;;; because the result is a symbol, not a function.
209 ;;; Also note that we lack good regression tests setting expectations around what's supposed
210 ;;; to happen when DEFINITION is supplied as a generic function. (Does it even make sense?)
212 (defun compile (name &optional
(definition (or (and (symbolp name
)
213 (macro-function name
))
216 "Produce a compiled function from DEFINITION. If DEFINITION is a
217 lambda-expression, it is coerced to a function. If DEFINITION is an
218 interpreted function, it is compiled. If DEFINITION is already a compiled
219 function, it is used as-is. (Future versions of SBCL might try to
220 recompile the existing definition, but this is not currently supported.)
222 If NAME is NIL, the compiled function is returned as the primary value.
223 Otherwise the resulting compiled function replaces existing function
224 definition of NAME, and NAME is returned as primary value; if NAME is a symbol
225 that names a macro, its macro function is replaced and NAME is returned as
228 Also returns a secondary value which is true if any conditions of type
229 WARNING occur during the compilation, and NIL otherwise.
231 Tertiary value is true if any conditions of type ERROR, or WARNING that are
232 not STYLE-WARNINGs occur during compilation, and NIL otherwise.
235 (((start-sec start-nsec
) (get-thread-virtual-time))
236 ((compiled-definition warnings-p failure-p
)
237 (if (or (compiled-function-p definition
)
238 (sb-pcl::generic-function-p definition
))
239 ;; We're not invoking COMPILE. If NAME isn't NIL then we need to
240 ;; ensure that DEFINITION (if supplied) gets bound to NAME even if
241 ;; (COMPILED-FUNCTION-P #'NAME) => NIL afterwards.
242 ;; This is a minor bug if DEFINITION is a GENERIC-FUNCTION with
243 ;; at least one interpreted method.
244 (values (if (and name defp
) definition
(make-unbound-marker))
246 (multiple-value-bind (sexpr lexenv
)
247 (if (not (typep definition
'interpreted-function
))
248 (values (the cons definition
) (make-null-lexenv))
249 #+(or sb-eval sb-fasteval
)
250 (prepare-for-compile definition
))
251 (sb-vm:without-arena
"compile"
252 (compile-in-lexenv sexpr lexenv name nil nil nil nil
))))))
253 (accumulate-compiler-time '*compile-elapsed-time
* start-sec start-nsec
)
255 ;; Do NOT assign anything into the symbol if we did not
256 ;; actually invoke the compiler and DEFINITION was not given.
257 ;; In that case it's not observable whether NAME get reassigned,
258 ;; but since there is nonzero overhead to setting
259 ;; an fdefinition, don't do it if it has no effect.
260 (unless (unbound-marker-p compiled-definition
)
261 (if (and (symbolp name
) (macro-function name
))
262 (setf (macro-function name
) compiled-definition
)
263 (setf (fdefinition name
) compiled-definition
)))
265 ;; Didn't run the compiler
266 ((unbound-marker-p compiled-definition
) definition
)
267 (t compiled-definition
))
271 (defun make-form-tracking-stream-observer (file-info)
272 (lambda (arg1 arg2 arg3
)
273 ;; Log some kind of reader event into FILE-INFO.
275 (:reset
; a char macro returned zero values - "virtual whitespace".
276 ;; I think this would be an ideal place at which to inquire and stash
277 ;; the FILE-POSITION in bytes so that DEBUG-SOURCE-START-POSITIONS
278 ;; are obtained _after_ having skipped virtual whitespace, not before.
279 (setf (fill-pointer (file-info-subforms file-info
)) 0))
281 (let ((subforms (file-info-subforms file-info
)))
282 ;; (ARG1 ARG2 ARG3) = (start-pos end-pos form)
283 (vector-push-extend arg1 subforms
)
284 (vector-push-extend arg2 subforms
)
285 (vector-push-extend arg3 subforms
))))))
287 ;;; COMPILE-FILE-POSITION macro
289 ;; Macros and inline functions report the original-source position. e.g.:
290 ;; 01: (declaim (inline foo))
291 ;; 02: (defun foo (x) (if x (warn "fail @line ~d" (compile-file-position))))
292 ;; 03: (defun bar (y) (foo y))
293 ;; 04: (defun baz (y) (foo y))
294 ;; will cause BAR to print 3 and BAZ to print 4 in the warning message.
296 ;; For macros this seems fair enough, but for inline functions it could
297 ;; be considered undesirable on the grounds that enabling/disabling inlining
298 ;; should not change visible behavior. Other than working harder to figure
299 ;; out where we are in inlined code (which may not even be feasible),
300 ;; a viable remedy is that all inlineable functions should have their stored
301 ;; representation not contain any macros, i.e. macros could be pre-expanded,
302 ;; which in this case means stuffing in the literal integers.
303 ;; I feel that that would be a general improvement to semantics, because
304 ;; as things are, an inline function's macros are expanded at least as many
305 ;; times as there are calls to the function - not very defensible
306 ;; as a design choice, but just an accident of the particular implementation.
309 (defmacro compile-file-position
(&whole this-form
)
310 "Return character position of this macro invocation or NIL if unavailable."
311 ;; Counting characters is intuitive because the transfer element size is 1
312 ;; measurement unit. The standard allows counting in something other than
313 ;; characters (namely bytes) for character streams, which is basically
314 ;; irrelevant here, as we don't need random access to the file.
315 (values (compute-compile-file-position this-form
)))
317 (defmacro compile-file-line
(&whole this-form
)
318 "Return line# and column# of this macro invocation as multiple values."
319 (let ((start (form-source-bounds this-form
)))
320 `(values ,(or (car start
) 0) ,(or (cdr start
) -
1))))
323 (defun compute-compile-file-position (this-form)
324 (let (file-info stream start-pos end-pos
)
325 (flet ((find-form-eq (form &optional fallback-path
)
326 (when (and file-info
(file-info-subforms file-info
))
327 (with-array-data ((vect (file-info-subforms file-info
))
328 (start) (end) :check-fill-pointer t
)
329 (declare (ignore start
))
330 (do ((i (1- end
) (- i
3)))
332 (declare (index-or-minus-1 i
))
333 (when (eq form
(svref vect i
))
334 (if start-pos
; ambiguous
336 (setf (values start-pos end-pos
)
338 (compile-file-position-helper
339 file-info fallback-path
))))
340 (setq start-pos
(svref vect
(- i
2))
341 end-pos
(svref vect
(1- i
))))))))))
342 (let ((source-info *source-info
*)
344 (cond ((boundp '*current-path
*) *current-path
*)
345 ((boundp '*source-paths
*) (get-source-path this-form
)))))
346 (when (and source-info
(boundp '*current-path
*))
347 (setq file-info
(source-info-file-info source-info
)
348 stream
(source-info-stream source-info
))
351 ;; probably a read-time eval
352 (find-form-eq this-form
))
354 (let* ((original-source-path (source-path-original-source source-path
))
355 (path (reverse original-source-path
)))
356 (when (file-info-subforms file-info
)
357 (let ((form (elt (file-info-forms file-info
) (car path
))))
358 (dolist (p (cdr path
))
362 (setq form
(nth p form
)))
363 (find-form-eq form
(cdr path
))))
364 (unless (and start-pos end-pos
)
365 (let ((parent (source-info-parent *source-info
*)))
366 ;; probably in a local macro executing COMPILE-FILE-POSITION,
367 ;; not producing a sexpr containing an invocation of C-F-P.
369 (setq file-info
(source-info-file-info parent
)
370 stream
(source-info-stream parent
))
371 (find-form-eq this-form
(cdr path
)))))))))))
372 (values start-pos end-pos stream
)))
374 ;; Given the form whose source path is PATH-TO-FIND, return the values
375 ;; corresponding to FILE-POSITION of that form's first and last characters.
376 ;; (Note that thse are sometimes approximate depending on whitespace)
377 ;; The form should be the currently-being-compiled toplevel form
378 ;; or subform thereof, and findable by EQness in the FILE-INFO's forms read.
379 ;; This is done by imparting tree structure to the annotations
380 ;; more-or-less paralleling construction of the original sexpr.
381 ;; Unfortunately, though this was a nice idea, it is not terribly useful.
382 ;; FIND-SOURCE-PATHS can not supply the correct path because it assumes
383 ;; that a form determines a path, whereas the opposite is more accurate.
384 ;; e.g. below are two functions that cause misbehavior.
386 * (defun example1 (x)
388 #1=(format t
"Err#2 @~D~%" (compile-file-position))
390 * (defconstant +foo
+ '(format t
"Err#1 @~D~%" (compile-file-position))))
391 * (defun example2 (x) (if x
#.
+foo
+ (progn #.
+foo
+)))
393 ;; In each case the compiler assigns the same source path to two logically
394 ;; different paths that it takes as it IR1-translates each half of the IF
395 ;; expression, though the ELSE branch obviously has a longer path.
396 ;; However, if you _could_ supply correct paths, this would compute correct
397 ;; answers. (Modulo any bugs due to near-total lack of testing)
399 (defun compile-file-position-helper (file-info path-to-find
)
400 (let (start-char end-char
)
402 ((recurse (subpath upper-bound queue
)
404 (declare (type index-or-minus-1 index
))
406 (let* ((item (car queue
))
408 (when (> end upper-bound
)
412 (when (and (eql index
(car subpath
)) (not (cdr subpath
)))
413 ;; This does not eagerly declare victory, because we want
414 ;; to find the rightmost match. In "#1=(FOO)" there are two
415 ;; different annotations pointing to (FOO).
416 (setq start-char
(caar item
)
417 end-char
(cdar item
)))
418 (unless queue
(return))
419 (let* ((next (car queue
))
420 (next-end (cdar next
)))
421 (cond ((< next-end end
) ; could descend
422 ;; only scan children if we're on the correct path
423 (if (eql index
(car subpath
))
424 (setf queue
(recurse (cdr subpath
) end queue
))
425 ;; else skip quickly by finding the next sibling
428 (when (or (endp queue
) (>= (caaar queue
) end
))
430 (unless queue
(return)))
431 ((= next-end end
) ; probably because of "#n="
432 (decf (truly-the (integer 0) index
))))))))
435 (with-array-data ((v (file-info-subforms file-info
))
436 (start) (end) :check-fill-pointer t
)
437 (declare (ignore start
))
438 (sort (loop for i from
0 below end by
3
439 collect
(acons (aref v i
)
443 (recurse path-to-find
(cdaar list
) (cdr list
))))
444 (values start-char end-char
)))
446 ;;; Given FORM which must be the currently-being-compiled toplevel form or subform thereof,
447 ;;; return (VALUES START END) of that form where each coordinate is a cons (LINE . COLUMN).
448 (defun form-source-bounds (form)
449 (multiple-value-bind (start-pos end-pos stream
) (compute-compile-file-position form
)
450 (if (and start-pos end-pos
(form-tracking-stream-p stream
))
451 (values (line/col-from-charpos stream start-pos
)
452 (line/col-from-charpos stream end-pos
))