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 ;;; Handle the nontrivial case of CL:COMPILE.
20 ;;; If ERRORP is true signals an error immediately -- otherwise returns
21 ;;; a function that will signal the error.
22 (defun actually-compile (name form
*lexenv
* source-info tlf errorp
)
23 (let ((source-paths (when source-info
*source-paths
*)))
24 (with-compilation-values
25 (sb!xc
:with-compilation-unit
()
26 ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
27 ;; few changes. Once things are stable, the shared bindings
28 ;; probably be merged back together into some shared utility
29 ;; macro, or perhaps both merged into one of the existing utility
30 ;; macros SB-C::WITH-COMPILATION-VALUES or
31 ;; CL:WITH-COMPILATION-UNIT.
33 (prog* ((tlf (or tlf
0))
34 ;; If we have a source-info from LOAD, we will
35 ;; also have a source-paths already set up -- so drop
36 ;; the ones from WITH-COMPILATION-VALUES.
37 (*source-paths
* (or source-paths
*source-paths
*))
38 (*source-info
* (or source-info
39 (make-lisp-source-info
40 form
:parent
*source-info
*)))
41 (*toplevel-lambdas
* ())
43 (*allow-instrumenting
* nil
)
44 (*compiler-coverage-metadata
* nil
)
45 (*msan-compatible-stack-unpoison
*
46 (and (member :msan
*features
*)
47 (find-dynamic-foreign-symbol-address "__msan_unpoison")))
49 (*last-format-string
* nil
)
50 (*last-format-args
* nil
)
51 (*last-message-count
* 0)
52 (*last-error-context
* nil
)
54 ;; KLUDGE: This rebinding of policy is necessary so that
55 ;; forms such as LOCALLY at the REPL actually extend the
56 ;; compilation policy correctly. However, there is an
57 ;; invariant that is potentially violated: future
58 ;; refactoring must not allow this to be done in the file
59 ;; compiler. At the moment we're clearly alright, as we
60 ;; call %COMPILE with a core-object, not a fasl-stream,
61 ;; but caveat future maintainers. -- CSR, 2002-10-27
62 (*policy
* (lexenv-policy *lexenv
*))
64 (*handled-conditions
* (lexenv-handled-conditions *lexenv
*))
66 (*disabled-package-locks
* (lexenv-disabled-package-locks *lexenv
*))
67 ;; FIXME: ANSI doesn't say anything about CL:COMPILE
68 ;; interacting with these variables, so we shouldn't. As
69 ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
70 ;; binding these variables, so as a quick hack we do so
71 ;; too. But a proper implementation would have verbosity
72 ;; controlled by function arguments and lexical variables.
73 (*compile-verbose
* nil
)
76 (handler-bind (((satisfies handle-condition-p
) #'handle-condition-handler
))
78 (find-source-paths form tlf
))
79 (let ((*compiler-error-bailout
*
82 ;; Unwind the compiler frames: users want the know where
83 ;; the error came from, not how the compiler got there.
87 (%compile form
(make-core-object)
89 :path
`(original-source-start 0 ,tlf
))))))
91 ;; Either signal the error right away, or return a function that
92 ;; will signal the corresponding COMPILED-PROGRAM-ERROR. This is so
93 ;; that we retain our earlier behaviour when called with erronous
94 ;; lambdas via %SIMPLE-EVAL. We could legally do just either one
95 ;; always, but right now keeping the old behaviour seems like less
96 ;; painful option: compiler.pure.lisp is full of tests that make all
97 ;; sort of assumptions about when which things are signalled. FIXME,
101 (let ((message (princ-to-string oops
))
102 (source (source-to-string form
)))
104 (lambda (&rest arguments
)
105 (declare (ignore arguments
))
106 (error 'compiled-program-error
108 :source source
)))))))))))
110 (defun compile-in-lexenv (definition lexenv
&optional name source-info tlf errorp
)
111 (multiple-value-bind (sexpr lexenv
)
114 (sb!interpreter
:interpreted-function
115 (sb!interpreter
:prepare-for-compile definition
))
117 (sb!eval
:interpreted-function
118 (sb!eval
:prepare-for-compile definition
))
120 (values definition lexenv
)))
121 (multiple-value-bind (compiled-definition warnings-p failure-p
)
122 (actually-compile name
(the cons sexpr
) lexenv source-info tlf errorp
)
123 (aver (typep compiled-definition
'compiled-function
))
124 (values compiled-definition warnings-p failure-p
))))
126 (defun compile (name &optional
(definition (or (and (symbolp name
)
127 (macro-function name
))
128 (fdefinition name
))))
129 "Produce a compiled function from DEFINITION. If DEFINITION is a
130 lambda-expression, it is coerced to a function. If DEFINITION is an
131 interpreted function, it is compiled. If DEFINITION is already a compiled
132 function, it is used as-is. (Future versions of SBCL might try to
133 recompile the existing definition, but this is not currently supported.)
135 If NAME is NIL, the compiled function is returned as the primary value.
136 Otherwise the resulting compiled function replaces existing function
137 definition of NAME, and NAME is returned as primary value; if NAME is a symbol
138 that names a macro, its macro function is replaced and NAME is returned as
141 Also returns a secondary value which is true if any conditions of type
142 WARNING occur during the compilation, and NIL otherwise.
144 Tertiary value is true if any conditions of type ERROR, or WARNING that are
145 not STYLE-WARNINGs occur during compilation, and NIL otherwise.
147 (multiple-value-bind (compiled-definition warnings-p failure-p
)
148 (if (compiled-function-p definition
)
149 (values definition nil nil
)
150 (compile-in-lexenv definition
(make-null-lexenv) name
))
152 (if (and (symbolp name
) (macro-function name
))
153 (setf (macro-function name
) compiled-definition
)
154 (setf (fdefinition name
) compiled-definition
))
157 compiled-definition
))
161 (defun make-form-tracking-stream-observer (file-info)
162 (lambda (arg1 arg2 arg3
)
163 ;; Log some kind of reader event into FILE-INFO.
165 (:reset
; a char macro returned zero values - "virtual whitespace".
166 ;; I think this would be an ideal place at which to inquire and stash
167 ;; the FILE-POSITION in bytes so that DEBUG-SOURCE-START-POSITIONS
168 ;; are obtained _after_ having skipped virtual whitespace, not before.
169 (setf (fill-pointer (file-info-subforms file-info
)) 0))
171 (let ((subforms (file-info-subforms file-info
)))
172 ;; (ARG1 ARG2 ARG3) = (start-pos end-pos form)
173 (vector-push-extend arg1 subforms
)
174 (vector-push-extend arg2 subforms
)
175 (vector-push-extend arg3 subforms
))))))
177 ;;; COMPILE-FILE-POSITION macro
179 ;; Macros and inline functions report the original-source position. e.g.:
180 ;; 01: (declaim (inline foo))
181 ;; 02: (defun foo (x) (if x (warn "fail @line ~d" (compile-file-position))))
182 ;; 03: (defun bar (y) (foo y))
183 ;; 04: (defun baz (y) (foo y))
184 ;; will cause BAR to print 3 and BAZ to print 4 in the warning message.
186 ;; For macros this seems fair enough, but for inline functions it could
187 ;; be considered undesirable on the grounds that enabling/disabling inlining
188 ;; should not change visible behavior. Other than working harder to figure
189 ;; out where we are in inlined code (which may not even be feasible),
190 ;; a viable remedy is that all inlineable functions should have their stored
191 ;; representation not contain any macros, i.e. macros could be pre-expanded,
192 ;; which in this case means stuffing in the literal integers.
193 ;; I feel that that would be a general improvement to semantics, because
194 ;; as things are, an inline function's macros are expanded at least as many
195 ;; times as there are calls to the function - not very defensible
196 ;; as a design choice, but just an accident of the particular implementation.
199 (defmacro compile-file-position
(&whole this-form
)
200 "Return character position of this macro invocation or NIL if unavailable."
201 ;; Counting characters is intuitive because the transfer element size is 1
202 ;; measurement unit. The standard allows counting in something other than
203 ;; characters (namely bytes) for character streams, which is basically
204 ;; irrelevant here, as we don't need random access to the file.
205 (compute-compile-file-position this-form nil
))
207 (defmacro compile-file-line
(&whole this-form
)
208 "Return line# and column# of this macro invocation as multiple values."
209 (compute-compile-file-position this-form t
))
212 (defun compute-compile-file-position (this-form as-line
/col-p
)
213 (let (file-info stream charpos
)
214 (flet ((find-form-eq (form &optional fallback-path
)
215 (with-array-data ((vect (file-info-subforms file-info
))
216 (start) (end) :check-fill-pointer t
)
217 (declare (ignore start
))
218 (do ((i (1- end
) (- i
3)))
220 (declare (index-or-minus-1 i
))
221 (when (eq form
(svref vect i
))
222 (if charpos
; ambiguous
226 (compile-file-position-helper
227 file-info fallback-path
))))
228 (setq charpos
(svref vect
(- i
2)))))))))
229 (let ((source-info *source-info
*))
230 (when (and source-info
(boundp '*current-path
*))
231 (setq file-info
(source-info-file-info source-info
)
232 stream
(source-info-stream source-info
))
234 ((not *current-path
*)
235 ;; probably a read-time eval
236 (find-form-eq this-form
))
237 ;; Hmm, would a &WHOLE argument would work better or worse in general?
239 (let* ((original-source-path (source-path-original-source *current-path
*))
240 (path (reverse original-source-path
)))
241 (when (file-info-subforms file-info
)
242 (let ((form (elt (file-info-forms file-info
) (car path
))))
243 (dolist (p (cdr path
))
244 (setq form
(nth p form
)))
245 (find-form-eq form
(cdr path
))))
247 (let ((parent (source-info-parent *source-info
*)))
248 ;; probably in a local macro executing COMPILE-FILE-POSITION,
249 ;; not producing a sexpr containing an invocation of C-F-P.
251 (setq file-info
(source-info-file-info parent
)
252 stream
(source-info-stream parent
))
253 (find-form-eq this-form
))))))))))
255 (if (and charpos
(form-tracking-stream-p stream
))
256 (let ((line/col
(line/col-from-charpos stream charpos
)))
257 `(values ,(car line
/col
) ,(cdr line
/col
)))
261 ;; Find FORM's character position in FILE-INFO by looking for PATH-TO-FIND.
262 ;; This is done by imparting tree structure to the annotations
263 ;; more-or-less paralleling construction of the original sexpr.
264 ;; Unfortunately, though this was a nice idea, it is not terribly useful.
265 ;; FIND-SOURCE-PATHS can not supply the correct path because it assumes
266 ;; that a form determines a path, whereas the opposite is more accurate.
267 ;; e.g. below are two functions that cause misbehavior.
269 * (defun example1 (x)
271 #1=(format t
"Err#2 @~D~%" (compile-file-position))
273 * (defconstant +foo
+ '(format t
"Err#1 @~D~%" (compile-file-position))))
274 * (defun example2 (x) (if x
#.
+foo
+ (progn #.
+foo
+)))
276 ;; In each case the compiler assigns the same source path to two logically
277 ;; different paths that it takes as it IR1-translates each half of the IF
278 ;; expression, though the ELSE branch obviously has a longer path.
279 ;; However, if you _could_ supply correct paths, this would compute correct
280 ;; answers. (Modulo any bugs due to near-total lack of testing)
282 (defun compile-file-position-helper (file-info path-to-find
)
283 (let (found-form start-char
)
285 ((recurse (subpath upper-bound queue
)
287 (declare (type index-or-minus-1 index
))
289 (let* ((item (car queue
))
291 (when (> end upper-bound
)
295 (when (and (eql index
(car subpath
)) (not (cdr subpath
)))
296 ;; This does not eagerly declare victory, because we want
297 ;; to find the rightmost match. In "#1=(FOO)" there are two
298 ;; different annotations pointing to (FOO).
299 (setq found-form
(cdr item
)
300 start-char
(caar item
)))
301 (unless queue
(return))
302 (let* ((next (car queue
))
303 (next-end (cdar next
)))
304 (cond ((< next-end end
) ; could descend
305 ;; only scan children if we're on the correct path
306 (if (eql index
(car subpath
))
307 (setf queue
(recurse (cdr subpath
) end queue
))
308 ;; else skip quickly by finding the next sibling
311 (when (or (endp queue
) (>= (caaar queue
) end
))
313 (unless queue
(return)))
314 ((= next-end end
) ; probably because of "#n="
315 (decf (truly-the (integer 0) index
))))))))
318 (with-array-data ((v (file-info-subforms file-info
))
319 (start) (end) :check-fill-pointer t
)
320 (declare (ignore start
))
321 (sort (loop for i from
0 below end by
3
322 collect
(acons (aref v i
)
326 (recurse path-to-find
(cdaar list
) (cdr list
))))