1 ;;;; A compiler from simple top-level forms to FASL operations.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;; SBCL has no proper byte compiler (having ditched the rather
15 ;;; ambitious and slightly flaky byte compiler inherited from CMU CL)
16 ;;; but its FOPs are a sort of byte code which is expressive enough
17 ;;; that we can compile some simple toplevel forms directly to them,
18 ;;; including very common operations like the forms that DEFVARs and
19 ;;; DECLAIMs macroexpand into.
21 ;;; FIXME: The expexnasion problem.
22 ;;; FOPCOMPILE and FOPCOMPILABLE-P cause multiple expansion of macros,
23 ;;; which may be problematic with side-effecting macros. When
24 ;;; FOPCOMPILABLE-P succeeds, FOPCOMPILE is called, resulting in
25 ;;; double macroexpansion. When FOPCOMPILABLE-P fails,
26 ;;; IR1-CONVERT-FUNCTOID expands already expanded macros for a second
28 ;;; And an edge case, when the top-level call has a complier-macro
29 ;;; which returns &whole it gets expanded three times, two times by
30 ;;; FOPCOMPILABLE-P and FOPCOMPILE, and one time by
31 ;;; PROCESS-TOPLEVEL-FORM, because unlike other macros, the expanded
32 ;;; form is still a macro-form. That's what the EXPAND optional
33 ;;; parameter solves, PROCESS-TOPLEVEL-FORM passes NIL, expanding
34 ;;; compiler macros at most once.
35 ;;; The instances of double expansion still remain, e.g. (fun (macro)),
36 ;;; since PROCESS-TOPLEVEL-FORM only expands the macros at the first
39 (flet ((setq-fopcompilable-p (args)
40 (loop for
(name value
) on args by
#'cddr
41 always
(and (symbolp name
)
42 (member (info :variable
:kind name
)
44 (fopcompilable-p value
)))))
47 (defun fopcompilable-p (form &optional
(expand t
))
48 ;; We'd like to be able to handle
49 ;; -- simple funcalls, nested recursively, e.g.
50 ;; (SET '*PACKAGE* (FIND-PACKAGE "CL-USER"))
51 ;; -- common self-evaluating forms like strings and keywords and
52 ;; fixnums, which are important for terminating
53 ;; the recursion of the simple funcalls above
54 ;; -- quoted lists (which are important for PROCLAIMs, which are
55 ;; common toplevel forms)
56 ;; -- fopcompilable stuff wrapped around non-fopcompilable expressions,
58 ;; (%DEFUN 'FOO (LAMBDA () ...) ...)
59 ;; -- the IF special form, to support things like (DEFVAR *X* 0)
60 ;; expanding into (UNLESS (BOUNDP '*X*) (SET '*X* 0))
62 ;; Special forms which we don't currently handle, but might consider
63 ;; supporting in the future are LOCALLY (with declarations),
64 ;; MACROLET, SYMBOL-MACROLET and THE.
65 ;; Also, if (FLET ((F () ...)) (DEFUN A () ...) (DEFUN B () ...))
66 ;; were handled, then it would probably automatically work in
67 ;; the cold loader too, providing definitions for A and B before
68 ;; executing all other toplevel forms.
71 (%macroexpand form
*lexenv
*)
75 (expand-compiler-macro form
)
77 (or (and (self-evaluating-p form
)
78 (constant-fopcompilable-p form
))
80 (multiple-value-bind (macroexpansion macroexpanded-p
)
83 (fopcompilable-p macroexpansion
)
84 ;; Punt on :ALIEN variables
85 (let ((kind (info :variable
:kind form
)))
86 (member kind
'(:special
:constant
:global
:unknown
))))))
88 (ignore-errors (list-length form
))
89 (let ((macroexpansion (expand-cm form
)))
90 (if (neq macroexpansion form
)
91 (return-from fopcompilable-p
(fopcompilable-p macroexpansion
))
93 (multiple-value-bind (macroexpansion macroexpanded-p
)
96 (fopcompilable-p macroexpansion
)
97 (destructuring-bind (operator &rest args
) form
99 ;; Special operators that we know how to cope with
101 (every #'fopcompilable-p args
))
103 (and (= (length args
) 1)
104 (constant-fopcompilable-p (car args
))))
106 (and (= (length args
) 1)
107 ;; #'(LAMBDA ...), #'(NAMED-LAMBDA ...), etc. These
108 ;; are not fopcompileable as such, but we can compile
109 ;; the lambdas with the real compiler, and the rest
110 ;; of the expression with the fop-compiler.
111 (or (and (lambda-form-p (car args
))
112 ;; The lambda might be closing over some
113 ;; variable, punt. As a further improvement,
114 ;; we could analyze the lambda body to
115 ;; see whether it really closes over any
116 ;; variables. One place where even simple
117 ;; analysis would be useful are the PCL
118 ;; slot-definition type-check-functions
119 ;; -- JES, 2007-01-13
120 (notany (lambda (binding)
121 (lambda-var-p (cdr binding
)))
122 (lexenv-vars *lexenv
*)))
123 ;; #'FOO, #'(SETF FOO), etc
124 (legal-fun-name-p (car args
)))))
126 (and (<= 2 (length args
) 3)
127 (every #'fopcompilable-p args
)))
128 ;; Allow SETQ only on special or global variables
130 (setq-fopcompilable-p args
))
131 ;; The real toplevel form processing has already been
132 ;; done, so EVAL-WHEN handling will be easy.
134 (and (>= (length args
) 1)
135 (eq (set-difference (car args
)
143 (every #'fopcompilable-p
(cdr args
))))
144 ;; A LET or LET* that introduces only lexical
145 ;; bindings might be fopcompilable, depending on
146 ;; whether something closes over the bindings.
147 ;; (And whether there are declarations in the body,
150 (let-fopcompilable-p operator args
))
152 (every #'fopcompilable-p args
))
154 ;; ordinary function calls
155 (and (symbolp operator
)
156 ;; If a LET/LOCALLY tries to introduce
157 ;; declarations, we'll detect it here, and
158 ;; disallow fopcompilation. This is safe,
159 ;; since defining a function/macro named
160 ;; DECLARE would violate a package lock.
161 (not (eq operator
'declare
))
162 (not (special-operator-p operator
))
163 (not (macro-function operator
)) ; redundant check
164 ;; We can't FOP-FUNCALL with more than 255
165 ;; parameters. (We could theoretically use
166 ;; APPLY, but then we'd need to construct
167 ;; the parameter list for APPLY without
168 ;; calling LIST, which is probably more
169 ;; trouble than it's worth).
170 (<= (length args
) 255)
171 (every #'fopcompilable-p args
)))))))))))
173 ;; Special version of FOPCOMPILABLE-P which recognizes toplevel calls
174 ;; that the cold loader is able to perform in the host to create the
175 ;; desired effect upon the target core.
176 ;; If an effect should occur "sooner than cold-init",
177 ;; this is probably where you need to make it happen.
179 (defun fopcompilable-p (form &optional
(expand t
))
181 (or (and (self-evaluating-p form
)
182 (constant-fopcompilable-p form
))
184 (let ((function (car form
)))
185 ;; It is assumed that uses of recognized functions are
186 ;; carefully controlled, and recursion on fopcompilable-p
188 (or (member function
'(sb!impl
::%defun
189 sb
!pcl
::!trivial-defmethod
190 sb
!kernel
::%defstruct
))
191 (and (eq function
'sb
!c
::%defconstant
)
192 ;; %DEFCONSTANT is fopcompilable only if the value
193 ;; is trivially a compile-time constant,
194 ;; and not, e.g. (COMPLICATED-FOLDABLE-EXPR),
195 ;; because we can't compute that with fasl ops.
196 (let ((val (third form
)))
197 (and (typep val
'(or rational
(cons (eql quote
))))
198 (constant-fopcompilable-p
199 (constant-form-value val
)))))
200 (and (symbolp function
) ; no ((lambda ...) ...)
201 (get-properties (symbol-plist function
)
202 '(:sb-cold-funcall-handler
/for-effect
203 :sb-cold-funcall-handler
/for-value
)))
204 (and (eq function
'setf
)
205 (fopcompilable-p (%macroexpand form
*lexenv
*)))
206 (and (eq function
'sb
!kernel
:%svset
)
207 (destructuring-bind (thing index value
) (cdr form
)
210 (eq (info :variable
:kind thing
) :global
)
211 (typep value
'(cons (member lambda function
213 (and (eq function
'setq
)
214 (setq-fopcompilable-p (cdr form
)))
216 (eq function
'sb
!fasl
::setq-no-questions-asked
))))))))
218 (defun let-fopcompilable-p (operator args
)
219 (when (>= (length args
) 1)
220 (multiple-value-bind (body decls
) (parse-body (cdr args
) nil
)
221 (declare (ignore body
))
222 (let* ((orig-lexenv *lexenv
*)
223 (*lexenv
* (make-lexenv)))
224 ;; We need to check for declarations
225 ;; first. Otherwise the fake lexenv we're
226 ;; constructing might be invalid.
228 (loop for binding in
(car args
)
229 for name
= (if (consp binding
)
232 for value
= (if (consp binding
)
235 ;; Only allow binding locals, since special bindings can't
236 ;; be easily expressed with fops.
237 always
(and (eq (info :variable
:kind name
)
239 (let ((*lexenv
* (ecase operator
242 (fopcompilable-p value
)))
244 (setf *lexenv
* (make-lexenv))
246 (make-lambda-var :%source-name name
))
247 (lexenv-vars *lexenv
*))))
248 (every #'fopcompilable-p
(cdr args
)))))))
250 (defun lambda-form-p (form)
253 '(lambda named-lambda lambda-with-lexenv
))))
255 ;;; Check that a literal form is fopcompilable. It would not be, for example,
256 ;;; when the form contains structures with funny MAKE-LOAD-FORMS.
257 (defun constant-fopcompilable-p (constant)
258 (let ((xset (alloc-xset)))
259 (labels ((grovel (value)
260 ;; Unless VALUE is an object which which obviously
261 ;; can't contain other objects
262 ;; FIXME: OAOOM. See MAYBE-EMIT-MAKE-LOAD-FORMS.
264 '(or #-sb-xc-host unboxed-array
269 (if (xset-member-p value xset
)
270 (return-from grovel nil
)
271 (add-to-xset value xset
))
275 (grovel (cdr value
)))
277 (dotimes (i (length value
))
278 (grovel (svref value i
))))
280 (dotimes (i (length value
))
281 (grovel (aref value i
))))
283 ;; Even though the (ARRAY T) branch does the exact
284 ;; same thing as this branch we do this separately
285 ;; so that the compiler can use faster versions of
286 ;; array-total-size and row-major-aref.
287 (dotimes (i (array-total-size value
))
288 (grovel (row-major-aref value i
))))
290 (dotimes (i (array-total-size value
))
291 (grovel (row-major-aref value i
))))
293 (case (%make-load-form value
)
295 ;; FIXME: Why is this needed? If the constant
296 ;; is deemed fopcompilable, then when we dump
297 ;; it we bind *dump-only-valid-structures* to
299 (fasl-validate-structure value
*compile-object
*)
300 ;; The above FIXME notwithstanding,
301 ;; there's never a need to grovel a layout.
302 (do-instance-tagged-slot (i value
)
303 (grovel (%instance-ref value i
))))
305 (t (return-from constant-fopcompilable-p nil
))))
307 (return-from constant-fopcompilable-p nil
))))))
311 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
312 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
313 ;;; has already ensured that the form can be fopcompiled.
315 ;;; See the expansion problem FIXME above fopcompilable-p.
316 (defun fopcompile (form path for-value-p
&optional
(expand t
))
317 (let ((path (or (get-source-path form
) (cons form path
)))
318 (fasl *compile-object
*))
319 (flet ((expand (form)
321 (%macroexpand form
*lexenv
*)
325 (expand-compiler-macro form
)
327 (cond ((self-evaluating-p form
)
328 (fopcompile-constant fasl form for-value-p
))
330 (multiple-value-bind (macroexpansion macroexpanded-p
)
334 (fopcompile macroexpansion path for-value-p
)
335 (let ((kind (info :variable
:kind form
)))
339 (fopcompile `(symbol-value ',form
) path for-value-p
))
341 ((member kind
'(:global
:constant
))
342 ;; Global variable or constant.
343 (fopcompile `(symbol-global-value ',form
) path for-value-p
))
346 (let* ((lambda-var (cdr (assoc form
(lexenv-vars *lexenv
*))))
347 (handle (when lambda-var
348 (lambda-var-fop-value lambda-var
))))
350 (setf (lambda-var-ever-used lambda-var
) t
)
352 (sb!fasl
::dump-push handle fasl
)))
354 ;; Undefined variable. Signal a warning, and
355 ;; treat it as a special variable reference, like
356 ;; the real compiler does -- do not elide even if
357 ;; the value is unused.
358 (note-undefined-reference form
:variable
)
359 (fopcompile `(symbol-value ',form
)
361 for-value-p
))))))))))
363 (let ((macroexpansion (expand-cm form
)))
364 (if (neq macroexpansion form
)
365 ;; could expand into an atom, so start from the top
366 (return-from fopcompile
367 (fopcompile macroexpansion path for-value-p
))))
368 (multiple-value-bind (macroexpansion macroexpanded-p
)
371 (fopcompile macroexpansion path for-value-p
)
372 (destructuring-bind (operator &rest args
) form
374 ;; The QUOTE special operator is worth handling: very
375 ;; easy and very common at toplevel.
377 (fopcompile-constant fasl
(second form
) for-value-p
))
378 ;; A FUNCTION needs to be compiled properly, but doesn't
379 ;; need to prevent the fopcompilation of the whole form.
380 ;; We just compile it, and emit an instruction for pushing
381 ;; the function handle on the FOP stack.
383 (fopcompile-function fasl
(second form
) path for-value-p
))
384 ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
385 ;; by a compiler-macro. But if SPACE > DEBUG we choose not
386 ;; to record locations, which is strange because the main
387 ;; compiler does not have similar logic afaict.
389 ;; FIXME: since the fopcompiler expands compiler-macros,
390 ;; this case should probably be killed. It can't execute.
391 (if (policy *policy
* (and (> space
1)
393 (fopcompile-constant fasl nil for-value-p
)
394 (fopcompile (let ((*current-path
* path
))
395 (make-definition-source-location))
399 (fopcompile-if fasl args path for-value-p
))
401 (if (and for-value-p
(endp args
))
402 (fopcompile nil path t
)
403 (loop for
(arg . next
) on args
404 do
(fopcompile arg path
405 (if next nil for-value-p
)))))
406 ((setq #+sb-xc-host sb
!fasl
::setq-no-questions-asked
)
407 (if (and for-value-p
(endp args
))
408 (fopcompile nil path t
)
409 (loop for
(name value . next
) on args by
#'cddr
410 do
(fopcompile `(set ',name
,value
) path
411 (if next nil for-value-p
)))))
413 (destructuring-bind (situations &body body
) args
414 (if (or (member :execute situations
)
415 (member 'eval situations
))
416 (fopcompile (cons 'progn body
) path for-value-p
)
417 (fopcompile nil path for-value-p
))))
419 (let ((orig-lexenv *lexenv
*)
420 (*lexenv
* (make-lexenv :default
*lexenv
*))
422 (loop for binding in
(car args
)
423 for name
= (if (consp binding
)
426 for value
= (if (consp binding
)
430 (let ((*lexenv
* (if (eql operator
'let
)
433 (fopcompile value path t
))
434 (let* ((obj (sb!fasl
::dump-pop fasl
))
435 (var (make-lambda-var
441 :vars
(list (cons name var
))))))
442 (fopcompile (cons 'progn
(cdr args
)) path for-value-p
)
444 (and *source-info
* path
))
445 (let* ((tlf (source-path-tlf-number path
))
446 (file-info (source-info-file-info *source-info
*))
447 (*compiler-error-context
*
448 (make-compiler-error-context
449 :original-source
(stringify-form form
)
450 :file-name
(file-info-name file-info
)
452 (nth-value 1 (find-source-root tlf
*source-info
*))
453 :original-source-path
(source-path-original-source path
)
455 (note-unreferenced-vars vars
*policy
*)))))
456 ;; Otherwise it must be an ordinary funcall.
459 ;; Special hack: there's already a fop for
460 ;; find-undeleted-package-or-lose, so use it.
461 ;; (We could theoretically do the same for
462 ;; other operations, but I don't see any good
463 ;; candidates in a quick read-through of
464 ;; src/code/fop.lisp.)
466 'sb
!int
:find-undeleted-package-or-lose
)
469 (fopcompile (first args
) path t
)
470 (dump-fop 'sb
!fasl
::fop-package fasl
))
472 (when (eq (info :function
:where-from operator
) :assumed
)
473 (note-undefined-reference operator
:function
))
474 (fopcompile-constant fasl operator t
)
476 (fopcompile arg path t
))
478 (dump-fop 'sb
!fasl
::fop-funcall fasl
)
479 (dump-fop 'sb
!fasl
::fop-funcall-for-effect fasl
))
480 (let ((n-args (length args
)))
481 ;; stub: FOP-FUNCALL isn't going to be usable
482 ;; to compile more than this, since its count
483 ;; is a single byte. Maybe we should just punt
484 ;; to the ordinary compiler in that case?
485 (aver (<= n-args
255))
486 (sb!fasl
::dump-byte n-args fasl
))))))))))
488 (bug "looks unFOPCOMPILEable: ~S" form
))))))
490 (defun fopcompile-function (fasl form path for-value-p
)
491 (cond ((lambda-form-p form
)
492 ;; Lambda forms are compiled with the real compiler
493 (let ((handle (%compile form fasl
:path path
)))
495 (sb!fasl
::dump-push handle fasl
))))
496 ;; While function names are translated to a call to FDEFINITION.
497 ((legal-fun-name-p form
)
498 (fopcompile `(fdefinition ',form
) path for-value-p
))
500 (compiler-error "~S is not a legal function name." form
))))
502 (defun fopcompile-if (fasl args path for-value-p
)
503 (destructuring-bind (condition then
&optional else
)
505 (let ((else-label (incf *fopcompile-label-counter
*))
506 (end-label (incf *fopcompile-label-counter
*)))
507 (sb!fasl
::dump-integer else-label fasl
)
508 (fopcompile condition path t
)
509 ;; If condition was false, skip to the ELSE
510 (dump-fop 'sb
!fasl
::fop-skip-if-false fasl
)
511 (fopcompile then path for-value-p
)
512 ;; The THEN branch will have produced a value even if we were
513 ;; currently skipping to the ELSE branch (or over this whole
514 ;; IF). This is done to ensure that the stack effects are
515 ;; balanced properly when dealing with operations that are
516 ;; executed even when skipping over code. But this particular
517 ;; value will be bogus, so we drop it.
519 (dump-fop 'sb
!fasl
::fop-drop-if-skipping fasl
))
520 ;; Now skip to the END
521 (sb!fasl
::dump-integer end-label fasl
)
522 (dump-fop 'sb
!fasl
::fop-skip fasl
)
523 ;; Start of the ELSE branch
524 (sb!fasl
::dump-integer else-label fasl
)
525 (dump-fop 'sb
!fasl
::fop-maybe-stop-skipping fasl
)
526 (fopcompile else path for-value-p
)
529 (dump-fop 'sb
!fasl
::fop-drop-if-skipping fasl
))
531 (sb!fasl
::dump-integer end-label fasl
)
532 (dump-fop 'sb
!fasl
::fop-maybe-stop-skipping fasl
)
533 ;; If we're still skipping, we must've triggered both of the
534 ;; drop-if-skipping fops. To keep the stack balanced, push a
535 ;; dummy value if needed.
537 (dump-fop 'sb
!fasl
::fop-push-nil-if-skipping fasl
)))))
539 (defun fopcompile-constant (fasl form for-value-p
)
541 ;; FIXME: Without this binding the dumper chokes on unvalidated
542 ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
543 ;; about to be dumped, not its load-form. Compare and contrast
544 ;; with EMIT-MAKE-LOAD-FORM.
545 (let ((sb!fasl
::*dump-only-valid-structures
* nil
))
546 (dump-object form fasl
))))