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
))))
45 (cold-svset-fopcompilable-p (args)
46 (destructuring-bind (thing index value
) args
49 (eq (info :variable
:kind thing
) :global
)
50 (typep value
'(cons (member lambda named-lambda function
)))))))
51 (defun fopcompilable-p (form &optional
(expand t
))
52 ;; We'd like to be able to handle
53 ;; -- simple funcalls, nested recursively, e.g.
54 ;; (SET '*PACKAGE* (FIND-PACKAGE "CL-USER"))
55 ;; -- common self-evaluating forms like strings and keywords and
56 ;; fixnums, which are important for terminating
57 ;; the recursion of the simple funcalls above
58 ;; -- quoted lists (which are important for PROCLAIMs, which are
59 ;; common toplevel forms)
60 ;; -- fopcompilable stuff wrapped around non-fopcompilable expressions,
62 ;; (%DEFUN 'FOO (LAMBDA () ...) ...)
63 ;; -- the IF special form, to support things like (DEFVAR *X* 0)
64 ;; expanding into (UNLESS (BOUNDP '*X*) (SET '*X* 0))
66 ;; Special forms which we don't currently handle, but might consider
67 ;; supporting in the future are LOCALLY (with declarations),
68 ;; MACROLET, SYMBOL-MACROLET and THE.
69 ;; Also, if (FLET ((F () ...)) (DEFUN A () ...) (DEFUN B () ...))
70 ;; were handled, then it would probably automatically work in
71 ;; the cold loader too, providing definitions for A and B before
72 ;; executing all other toplevel forms.
75 (or (and (self-evaluating-p form
)
76 (constant-fopcompilable-p form
))
78 (let ((function (car form
)))
79 ;; It is assumed that uses of recognized functions are
80 ;; carefully controlled, and recursion on fopcompilable-p
82 (or (member function
'(sb!impl
::%defun
83 sb
!kernel
::%defstruct
))
84 (and (eq function
'sb
!c
::%defconstant
)
85 ;; %DEFCONSTANT is fopcompilable only if the value
86 ;; is trivially a compile-time constant,
87 ;; and not, e.g. (COMPLICATED-FOLDABLE-EXPR),
88 ;; because we can't compute that with fasl ops.
89 (let ((val (third form
)))
90 (and (typep val
'(or rational
(cons (eql quote
))))
91 (constant-fopcompilable-p
92 (constant-form-value val
)))))
93 (and (symbolp function
) ; no ((lambda ...) ...)
94 (get-properties (symbol-plist function
)
95 '(:sb-cold-funcall-handler
/for-effect
96 :sb-cold-funcall-handler
/for-value
)))
97 (and (eq function
'setf
)
98 (fopcompilable-p (%macroexpand form
*lexenv
*)))
99 (and (eq function
'sb
!kernel
:%svset
)
100 (cold-svset-fopcompilable-p (cdr form
)))
101 (and (eq function
'setq
)
102 (setq-fopcompilable-p (cdr form
))))))))
104 (flet ((expand (form)
106 (%macroexpand form
*lexenv
*)
110 (expand-compiler-macro form
)
112 (or (and (self-evaluating-p form
)
113 (constant-fopcompilable-p form
))
115 (multiple-value-bind (macroexpansion macroexpanded-p
)
118 (fopcompilable-p macroexpansion
)
119 ;; Punt on :ALIEN variables
120 (let ((kind (info :variable
:kind form
)))
121 (member kind
'(:special
:constant
:global
:unknown
))))))
123 (ignore-errors (list-length form
))
124 (let ((macroexpansion (expand-cm form
)))
125 (if (neq macroexpansion form
)
126 (return-from fopcompilable-p
(fopcompilable-p macroexpansion
))
128 (multiple-value-bind (macroexpansion macroexpanded-p
)
131 (fopcompilable-p macroexpansion
)
132 (destructuring-bind (operator &rest args
) form
134 ;; Special operators that we know how to cope with
136 (every #'fopcompilable-p args
))
138 (and (= (length args
) 1)
139 (constant-fopcompilable-p (car args
))))
141 (and (= (length args
) 1)
142 ;; #'(LAMBDA ...), #'(NAMED-LAMBDA ...), etc. These
143 ;; are not fopcompileable as such, but we can compile
144 ;; the lambdas with the real compiler, and the rest
145 ;; of the expression with the fop-compiler.
146 (or (and (lambda-form-p (car args
))
147 ;; The lambda might be closing over some
148 ;; variable, punt. As a further improvement,
149 ;; we could analyze the lambda body to
150 ;; see whether it really closes over any
151 ;; variables. One place where even simple
152 ;; analysis would be useful are the PCL
153 ;; slot-definition type-check-functions
154 ;; -- JES, 2007-01-13
155 (notany (lambda (binding)
156 (lambda-var-p (cdr binding
)))
157 (lexenv-vars *lexenv
*)))
158 ;; #'FOO, #'(SETF FOO), etc
159 (legal-fun-name-p (car args
)))))
161 (and (<= 2 (length args
) 3)
162 (every #'fopcompilable-p args
)))
163 ;; Allow SETQ only on special or global variables
165 (setq-fopcompilable-p args
))
166 ;; The real toplevel form processing has already been
167 ;; done, so EVAL-WHEN handling will be easy.
169 (and (>= (length args
) 1)
170 (eq (set-difference (car args
)
178 (every #'fopcompilable-p
(cdr args
))))
179 ;; A LET or LET* that introduces only lexical
180 ;; bindings might be fopcompilable, depending on
181 ;; whether something closes over the bindings.
182 ;; (And whether there are declarations in the body,
185 (let-fopcompilable-p operator args
))
187 (every #'fopcompilable-p args
))
189 ;; ordinary function calls
190 (and (symbolp operator
)
191 ;; If a LET/LOCALLY tries to introduce
192 ;; declarations, we'll detect it here, and
193 ;; disallow fopcompilation. This is safe,
194 ;; since defining a function/macro named
195 ;; DECLARE would violate a package lock.
196 (not (eq operator
'declare
))
197 (not (special-operator-p operator
))
198 (not (macro-function operator
)) ; redundant check
199 ;; We can't FOP-FUNCALL with more than 255
200 ;; parameters. (We could theoretically use
201 ;; APPLY, but then we'd need to construct
202 ;; the parameter list for APPLY without
203 ;; calling LIST, which is probably more
204 ;; trouble than it's worth).
205 (<= (length args
) 255)
206 (every #'fopcompilable-p args
))))))))))))
208 (defun let-fopcompilable-p (operator args
)
209 (when (>= (length args
) 1)
210 (multiple-value-bind (body decls
) (parse-body (cdr args
) nil
)
211 (declare (ignore body
))
212 (let* ((orig-lexenv *lexenv
*)
213 (*lexenv
* (make-lexenv)))
214 ;; We need to check for declarations
215 ;; first. Otherwise the fake lexenv we're
216 ;; constructing might be invalid.
218 (loop for binding in
(car args
)
219 for name
= (if (consp binding
)
222 for value
= (if (consp binding
)
225 ;; Only allow binding locals, since special bindings can't
226 ;; be easily expressed with fops.
227 always
(and (eq (info :variable
:kind name
)
229 (let ((*lexenv
* (ecase operator
232 (fopcompilable-p value
)))
234 (setf *lexenv
* (make-lexenv))
236 (make-lambda-var :%source-name name
))
237 (lexenv-vars *lexenv
*))))
238 (every #'fopcompilable-p
(cdr args
)))))))
240 (defun lambda-form-p (form)
243 '(lambda named-lambda lambda-with-lexenv
))))
245 ;;; Check that a literal form is fopcompilable. It would not be, for example,
246 ;;; when the form contains structures with funny MAKE-LOAD-FORMS.
247 (defun constant-fopcompilable-p (constant)
248 (let ((xset (alloc-xset)))
249 (labels ((grovel (value)
250 ;; Unless VALUE is an object which which obviously
251 ;; can't contain other objects
252 ;; FIXME: OAOOM. See MAYBE-EMIT-MAKE-LOAD-FORMS.
254 '(or #-sb-xc-host unboxed-array
259 (if (xset-member-p value xset
)
260 (return-from grovel nil
)
261 (add-to-xset value xset
))
265 (grovel (cdr value
)))
267 (dotimes (i (length value
))
268 (grovel (svref value i
))))
270 (dotimes (i (length value
))
271 (grovel (aref value i
))))
273 ;; Even though the (ARRAY T) branch does the exact
274 ;; same thing as this branch we do this separately
275 ;; so that the compiler can use faster versions of
276 ;; array-total-size and row-major-aref.
277 (dotimes (i (array-total-size value
))
278 (grovel (row-major-aref value i
))))
280 (dotimes (i (array-total-size value
))
281 (grovel (row-major-aref value i
))))
283 (case (%make-load-form value
)
285 ;; FIXME: Why is this needed? If the constant
286 ;; is deemed fopcompilable, then when we dump
287 ;; it we bind *dump-only-valid-structures* to
289 (fasl-validate-structure value
*compile-object
*)
290 ;; The above FIXME notwithstanding,
291 ;; there's never a need to grovel a layout.
292 (do-instance-tagged-slot (i value
)
293 (grovel (%instance-ref value i
))))
295 (t (return-from constant-fopcompilable-p nil
))))
297 (return-from constant-fopcompilable-p nil
))))))
301 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
302 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
303 ;;; has already ensured that the form can be fopcompiled.
305 ;;; See the expansion problem FIXME above fopcompilable-p.
306 (defun fopcompile (form path for-value-p
&optional
(expand t
))
307 (let ((path (or (get-source-path form
) (cons form path
)))
308 (fasl *compile-object
*))
309 (flet ((expand (form)
311 (%macroexpand form
*lexenv
*)
315 (expand-compiler-macro form
)
317 (cond ((self-evaluating-p form
)
318 (fopcompile-constant fasl form for-value-p
))
320 (multiple-value-bind (macroexpansion macroexpanded-p
)
324 (fopcompile macroexpansion path for-value-p
)
325 (let ((kind (info :variable
:kind form
)))
329 (fopcompile `(symbol-value ',form
) path for-value-p
))
331 ((member kind
'(:global
:constant
))
332 ;; Global variable or constant.
333 (fopcompile `(symbol-global-value ',form
) path for-value-p
))
336 (let* ((lambda-var (cdr (assoc form
(lexenv-vars *lexenv
*))))
337 (handle (when lambda-var
338 (lambda-var-fop-value lambda-var
))))
340 (setf (lambda-var-ever-used lambda-var
) t
)
342 (sb!fasl
::dump-push handle fasl
)))
344 ;; Undefined variable. Signal a warning, and
345 ;; treat it as a special variable reference, like
346 ;; the real compiler does -- do not elide even if
347 ;; the value is unused.
348 (note-undefined-reference form
:variable
)
349 (fopcompile `(symbol-value ',form
)
351 for-value-p
))))))))))
353 (let ((macroexpansion (expand-cm form
)))
354 (if (neq macroexpansion form
)
355 ;; could expand into an atom, so start from the top
356 (return-from fopcompile
357 (fopcompile macroexpansion path for-value-p
))))
358 (multiple-value-bind (macroexpansion macroexpanded-p
)
361 (fopcompile macroexpansion path for-value-p
)
362 (destructuring-bind (operator &rest args
) form
364 ;; The QUOTE special operator is worth handling: very
365 ;; easy and very common at toplevel.
367 (fopcompile-constant fasl
(second form
) for-value-p
))
368 ;; A FUNCTION needs to be compiled properly, but doesn't
369 ;; need to prevent the fopcompilation of the whole form.
370 ;; We just compile it, and emit an instruction for pushing
371 ;; the function handle on the FOP stack.
373 (fopcompile-function fasl
(second form
) path for-value-p
))
374 ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
375 ;; by a compiler-macro. But if SPACE > DEBUG we choose not
376 ;; to record locations, which is strange because the main
377 ;; compiler does not have similar logic afaict.
379 ;; FIXME: since the fopcompiler expands compiler-macros,
380 ;; this case should probably be killed. It can't execute.
381 (if (policy *policy
* (and (> space
1)
383 (fopcompile-constant fasl nil for-value-p
)
384 (fopcompile (let ((*current-path
* path
))
385 (make-definition-source-location))
389 (fopcompile-if fasl args path for-value-p
))
391 (if (and for-value-p
(endp args
))
392 (fopcompile nil path t
)
393 (loop for
(arg . next
) on args
394 do
(fopcompile arg path
395 (if next nil for-value-p
)))))
397 (if (and for-value-p
(endp args
))
398 (fopcompile nil path t
)
399 (loop for
(name value . next
) on args by
#'cddr
400 do
(fopcompile `(set ',name
,value
) path
401 (if next nil for-value-p
)))))
403 (destructuring-bind (situations &body body
) args
404 (if (or (member :execute situations
)
405 (member 'eval situations
))
406 (fopcompile (cons 'progn body
) path for-value-p
)
407 (fopcompile nil path for-value-p
))))
409 (let ((orig-lexenv *lexenv
*)
410 (*lexenv
* (make-lexenv :default
*lexenv
*))
412 (loop for binding in
(car args
)
413 for name
= (if (consp binding
)
416 for value
= (if (consp binding
)
420 (let ((*lexenv
* (if (eql operator
'let
)
423 (fopcompile value path t
))
424 (let* ((obj (sb!fasl
::dump-pop fasl
))
425 (var (make-lambda-var
431 :vars
(list (cons name var
))))))
432 (fopcompile (cons 'progn
(cdr args
)) path for-value-p
)
434 (and *source-info
* path
))
435 (let* ((tlf (source-path-tlf-number path
))
436 (file-info (source-info-file-info *source-info
*))
437 (*compiler-error-context
*
438 (make-compiler-error-context
439 :original-source
(stringify-form form
)
440 :file-name
(file-info-name file-info
)
442 (nth-value 1 (find-source-root tlf
*source-info
*))
443 :original-source-path
(source-path-original-source path
)
445 (note-unreferenced-vars vars
*policy
*)))))
446 ;; Otherwise it must be an ordinary funcall.
449 ;; Special hack: there's already a fop for
450 ;; find-undeleted-package-or-lose, so use it.
451 ;; (We could theoretically do the same for
452 ;; other operations, but I don't see any good
453 ;; candidates in a quick read-through of
454 ;; src/code/fop.lisp.)
456 'sb
!int
:find-undeleted-package-or-lose
)
459 (fopcompile (first args
) path t
)
460 (dump-fop 'sb
!fasl
::fop-package fasl
))
462 (when (eq (info :function
:where-from operator
) :assumed
)
463 (note-undefined-reference operator
:function
))
464 (fopcompile-constant fasl operator t
)
466 (fopcompile arg path t
))
468 (dump-fop 'sb
!fasl
::fop-funcall fasl
)
469 (dump-fop 'sb
!fasl
::fop-funcall-for-effect fasl
))
470 (let ((n-args (length args
)))
471 ;; stub: FOP-FUNCALL isn't going to be usable
472 ;; to compile more than this, since its count
473 ;; is a single byte. Maybe we should just punt
474 ;; to the ordinary compiler in that case?
475 (aver (<= n-args
255))
476 (sb!fasl
::dump-byte n-args fasl
))))))))))
478 (bug "looks unFOPCOMPILEable: ~S" form
))))))
480 (defun fopcompile-function (fasl form path for-value-p
)
481 (cond ((lambda-form-p form
)
482 ;; Lambda forms are compiled with the real compiler
483 (let ((handle (%compile form fasl
:path path
)))
485 (sb!fasl
::dump-push handle fasl
))))
486 ;; While function names are translated to a call to FDEFINITION.
487 ((legal-fun-name-p form
)
488 (fopcompile `(fdefinition ',form
) path for-value-p
))
490 (compiler-error "~S is not a legal function name." form
))))
492 (defun fopcompile-if (fasl args path for-value-p
)
493 (destructuring-bind (condition then
&optional else
)
495 (let ((else-label (incf *fopcompile-label-counter
*))
496 (end-label (incf *fopcompile-label-counter
*)))
497 (sb!fasl
::dump-integer else-label fasl
)
498 (fopcompile condition path t
)
499 ;; If condition was false, skip to the ELSE
500 (dump-fop 'sb
!fasl
::fop-skip-if-false fasl
)
501 (fopcompile then path for-value-p
)
502 ;; The THEN branch will have produced a value even if we were
503 ;; currently skipping to the ELSE branch (or over this whole
504 ;; IF). This is done to ensure that the stack effects are
505 ;; balanced properly when dealing with operations that are
506 ;; executed even when skipping over code. But this particular
507 ;; value will be bogus, so we drop it.
509 (dump-fop 'sb
!fasl
::fop-drop-if-skipping fasl
))
510 ;; Now skip to the END
511 (sb!fasl
::dump-integer end-label fasl
)
512 (dump-fop 'sb
!fasl
::fop-skip fasl
)
513 ;; Start of the ELSE branch
514 (sb!fasl
::dump-integer else-label fasl
)
515 (dump-fop 'sb
!fasl
::fop-maybe-stop-skipping fasl
)
516 (fopcompile else path for-value-p
)
519 (dump-fop 'sb
!fasl
::fop-drop-if-skipping fasl
))
521 (sb!fasl
::dump-integer end-label fasl
)
522 (dump-fop 'sb
!fasl
::fop-maybe-stop-skipping fasl
)
523 ;; If we're still skipping, we must've triggered both of the
524 ;; drop-if-skipping fops. To keep the stack balanced, push a
525 ;; dummy value if needed.
527 (dump-fop 'sb
!fasl
::fop-push-nil-if-skipping fasl
)))))
529 (defun fopcompile-constant (fasl form for-value-p
)
531 ;; FIXME: Without this binding the dumper chokes on unvalidated
532 ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
533 ;; about to be dumped, not its load-form. Compare and contrast
534 ;; with EMIT-MAKE-LOAD-FORM.
535 (let ((sb!fasl
::*dump-only-valid-structures
* nil
))
536 (dump-object form fasl
))))