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.
20 (defun fopcompilable-p (form)
21 ;; We'd like to be able to handle
22 ;; -- simple funcalls, nested recursively, e.g.
23 ;; (SET '*PACKAGE* (FIND-PACKAGE "CL-USER"))
24 ;; -- common self-evaluating forms like strings and keywords and
25 ;; fixnums, which are important for terminating
26 ;; the recursion of the simple funcalls above
27 ;; -- quoted lists (which are important for PROCLAIMs, which are
28 ;; common toplevel forms)
29 ;; -- fopcompilable stuff wrapped around non-fopcompilable expressions,
31 ;; (%DEFUN 'FOO (LAMBDA () ...) ...)
32 ;; -- the IF special form, to support things like (DEFVAR *X* 0)
33 ;; expanding into (UNLESS (BOUNDP '*X*) (SET '*X* 0))
35 ;; Special forms which we don't currently handle, but might consider
36 ;; supporting in the future are LOCALLY (with declarations),
37 ;; MACROLET, SYMBOL-MACROLET and THE.
41 (or (and (self-evaluating-p form
)
42 (constant-fopcompilable-p form
))
44 (multiple-value-bind (macroexpansion macroexpanded-p
)
45 (macroexpand form
*lexenv
*)
47 (fopcompilable-p macroexpansion
)
48 ;; Punt on :ALIEN variables
49 (let ((kind (info :variable
:kind form
)))
50 (or (eq kind
:special
)
51 ;; Not really a global, but a variable for
52 ;; which no information exists.
54 (eq kind
:constant
))))))
56 (ignore-errors (list-length form
))
57 (multiple-value-bind (macroexpansion macroexpanded-p
)
58 (macroexpand form
*lexenv
*)
60 (fopcompilable-p macroexpansion
)
61 (destructuring-bind (operator &rest args
) form
63 ;; Special operators that we know how to cope with
65 (every #'fopcompilable-p args
))
67 (and (= (length args
) 1)
68 (constant-fopcompilable-p (car args
))))
70 (and (= (length args
) 1)
71 ;; #'(LAMBDA ...), #'(NAMED-LAMBDA ...), etc. These
72 ;; are not fopcompileable as such, but we can compile
73 ;; the lambdas with the real compiler, and the rest
74 ;; of the expression with the fop-compiler.
75 (or (and (lambda-form-p (car args
))
76 ;; The lambda might be closing over some
77 ;; variable, punt. As a further improvement,
78 ;; we could analyze the lambda body to
79 ;; see whether it really closes over any
80 ;; variables. One place where even simple
81 ;; analysis would be useful are the PCL
82 ;; slot-definition type-check-functions
84 (notany (lambda (binding)
85 (lambda-var-p (cdr binding
)))
86 (lexenv-vars *lexenv
*)))
87 ;; #'FOO, #'(SETF FOO), etc
88 (legal-fun-name-p (car args
)))))
90 (and (<= 2 (length args
) 3)
91 (every #'fopcompilable-p args
)))
92 ;; Allow SETQ only on special variables
94 (loop for
(name value
) on args by
#'cddr
95 unless
(and (symbolp name
)
96 (let ((kind (info :variable
:kind name
)))
98 (fopcompilable-p value
))
101 ;; The real toplevel form processing has already been
102 ;; done, so EVAL-WHEN handling will be easy.
104 (and (>= (length args
) 1)
105 (eq (set-difference (car args
)
113 (every #'fopcompilable-p
(cdr args
))))
114 ;; A LET or LET* that introduces only lexical
115 ;; bindings might be fopcompilable, depending on
116 ;; whether something closes over the bindings.
117 ;; (And whether there are declarations in the body,
120 (let-fopcompilable-p operator args
))
122 (every #'fopcompilable-p args
))
124 ;; ordinary function calls
125 (and (symbolp operator
)
126 ;; If a LET/LOCALLY tries to introduce
127 ;; declarations, we'll detect it here, and
128 ;; disallow fopcompilation. This is safe,
129 ;; since defining a function/macro named
130 ;; DECLARE would violate a package lock.
131 (not (eq operator
'declare
))
132 (not (special-operator-p operator
))
133 (not (macro-function operator
))
134 ;; We can't FOP-FUNCALL with more than 255
135 ;; parameters. (We could theoretically use
136 ;; APPLY, but then we'd need to construct
137 ;; the parameter list for APPLY without
138 ;; calling LIST, which is probably more
139 ;; trouble than it's worth).
140 (<= (length args
) 255)
141 (every #'fopcompilable-p args
))))))))))
143 (defun let-fopcompilable-p (operator args
)
144 (when (>= (length args
) 1)
145 (multiple-value-bind (body decls
)
146 (parse-body (cdr args
) :doc-string-allowed nil
)
147 (declare (ignore body
))
148 (let* ((orig-lexenv *lexenv
*)
149 (*lexenv
* (make-lexenv)))
150 ;; We need to check for declarations
151 ;; first. Otherwise the fake lexenv we're
152 ;; constructing might be invalid.
154 (loop for binding in
(car args
)
155 for name
= (if (consp binding
)
158 for value
= (if (consp binding
)
161 ;; Only allow binding lexicals,
162 ;; since special bindings can't be
163 ;; easily expressed with fops.
164 always
(and (eq (info :variable
:kind name
)
166 (let ((*lexenv
* (ecase operator
169 (fopcompilable-p value
)))
171 (setf *lexenv
* (make-lexenv))
173 (make-lambda-var :%source-name name
))
174 (lexenv-vars *lexenv
*))))
175 (every #'fopcompilable-p
(cdr args
)))))))
177 (defun lambda-form-p (form)
180 '(lambda named-lambda instance-lambda lambda-with-lexenv
))))
182 ;;; Check that a literal form is fopcompilable. It would not for example
183 ;;; when the form contains structures with funny MAKE-LOAD-FORMS.
184 (defun constant-fopcompilable-p (constant)
185 (let ((xset (alloc-xset)))
186 (labels ((grovel (value)
187 ;; Unless VALUE is an object which which obviously
188 ;; can't contain other objects
195 (if (xset-member-p value xset
)
196 (return-from grovel nil
)
197 (add-to-xset value xset
))
201 (grovel (cdr value
)))
203 (dotimes (i (length value
))
204 (grovel (svref value i
))))
206 (dotimes (i (length value
))
207 (grovel (aref value i
))))
209 ;; Even though the (ARRAY T) branch does the exact
210 ;; same thing as this branch we do this separately
211 ;; so that the compiler can use faster versions of
212 ;; array-total-size and row-major-aref.
213 (dotimes (i (array-total-size value
))
214 (grovel (row-major-aref value i
))))
216 (dotimes (i (array-total-size value
))
217 (grovel (row-major-aref value i
))))
219 (multiple-value-bind (creation-form init-form
)
221 (sb!xc
:make-load-form value
(make-null-lexenv))
223 (compiler-error condition
)))
224 (declare (ignore init-form
))
226 (:sb-just-dump-it-normally
227 ;; FIXME: Why is this needed? If the constant
228 ;; is deemed fopcompilable, then when we dump
229 ;; it we bind *dump-only-valid-structures* to
231 (fasl-validate-structure value
*compile-object
*)
232 (dotimes (i (- (%instance-length value
)
233 (layout-n-untagged-slots
234 (%instance-ref value
0))))
235 (grovel (%instance-ref value i
))))
238 (return-from constant-fopcompilable-p nil
)))))
240 (return-from constant-fopcompilable-p nil
))))))
244 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
245 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
246 ;;; has already ensured that the form can be fopcompiled.
247 (defun fopcompile (form path for-value-p
)
248 (cond ((self-evaluating-p form
)
249 (fopcompile-constant form for-value-p
))
251 (multiple-value-bind (macroexpansion macroexpanded-p
)
252 (sb!xc
:macroexpand form
*lexenv
*)
255 (fopcompile macroexpansion path for-value-p
)
256 (let ((kind (info :variable
:kind form
)))
257 (if (member kind
'(:special
:constant
))
259 (fopcompile `(symbol-value ',form
) path for-value-p
)
261 (let* ((lambda-var (cdr (assoc form
(lexenv-vars *lexenv
*))))
262 (handle (when lambda-var
263 (lambda-var-fop-value lambda-var
))))
266 (sb!fasl
::dump-push handle
*compile-object
*))
268 ;; Undefined variable. Signal a warning, and
269 ;; treat it as a special variable reference, like
270 ;; the real compiler does -- do not elide even if
271 ;; the value is unused.
272 (note-undefined-reference form
:variable
)
273 (fopcompile `(symbol-value ',form
)
277 (multiple-value-bind (macroexpansion macroexpanded-p
)
278 (sb!xc
:macroexpand form
*lexenv
*)
280 (fopcompile macroexpansion path for-value-p
)
281 (destructuring-bind (operator &rest args
) form
283 ;; The QUOTE special operator is worth handling: very
284 ;; easy and very common at toplevel.
286 (fopcompile-constant (second form
) for-value-p
))
287 ;; A FUNCTION needs to be compiled properly, but doesn't
288 ;; need to prevent the fopcompilation of the whole form.
289 ;; We just compile it, and emit an instruction for pushing
290 ;; the function handle on the FOP stack.
292 (fopcompile-function (second form
) path for-value-p
))
293 ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
294 ;; by a compiler-macro. Doing general compiler-macro
295 ;; expansion in the fopcompiler is probably not sensible,
296 ;; so we'll just special-case it.
298 (if (policy *policy
* (and (> space
1)
300 (fopcompile-constant nil for-value-p
)
301 (fopcompile (let ((*current-path
* path
))
302 (make-definition-source-location))
306 (fopcompile-if args path for-value-p
))
308 (loop for
(arg . next
) on args
314 (loop for
(name value . next
) on args by
#'cddr
315 do
(fopcompile `(set ',name
,value
) path
320 (destructuring-bind (situations &body body
) args
321 (if (or (member :execute situations
)
322 (member 'eval situations
))
323 (fopcompile (cons 'progn body
) path for-value-p
)
324 (fopcompile nil path for-value-p
))))
326 (let ((orig-lexenv *lexenv
*)
327 (*lexenv
* (make-lexenv :default
*lexenv
*)))
328 (loop for binding in
(car args
)
329 for name
= (if (consp binding
)
332 for value
= (if (consp binding
)
335 do
(let ((*lexenv
* (if (eql operator
'let
)
338 (fopcompile value path t
))
339 do
(let ((obj (sb!fasl
::dump-pop
*compile-object
*)))
342 :vars
(list (cons name
345 :fop-value obj
)))))))
346 (fopcompile (cons 'progn
(cdr args
)) path for-value-p
)))
347 ;; Otherwise it must be an ordinary funcall.
350 ;; Special hack: there's already a fop for
351 ;; find-undeleted-package-or-lose, so use it.
352 ;; (We could theoretically do the same for
353 ;; other operations, but I don't see any good
354 ;; candidates in a quick read-through of
355 ;; src/code/fop.lisp.)
357 'sb
!int
:find-undeleted-package-or-lose
)
360 (fopcompile (first args
) path t
)
361 (sb!fasl
::dump-fop
'sb
!fasl
::fop-package
364 (fopcompile-constant operator t
)
366 (fopcompile arg path t
))
368 (sb!fasl
::dump-fop
'sb
!fasl
::fop-funcall
370 (sb!fasl
::dump-fop
'sb
!fasl
::fop-funcall-for-effect
372 (let ((n-args (length args
)))
373 ;; stub: FOP-FUNCALL isn't going to be usable
374 ;; to compile more than this, since its count
375 ;; is a single byte. Maybe we should just punt
376 ;; to the ordinary compiler in that case?
377 (aver (<= n-args
255))
378 (sb!fasl
::dump-byte n-args
*compile-object
*))))))))))
380 (bug "looks unFOPCOMPILEable: ~S" form
))))
382 (defun fopcompile-function (form path for-value-p
)
383 (flet ((dump-fdefinition (name)
384 (fopcompile `(fdefinition ',name
) path for-value-p
)))
387 ;; Lambda forms are compiled with the real compiler
388 ((lambda-form-p form
)
389 (let* ((handle (%compile form
393 (sb!fasl
::dump-push handle
*compile-object
*))))
394 ;; While function names are translated to a call to FDEFINITION.
395 ((legal-fun-name-p form
)
396 (dump-fdefinition form
))
398 (compiler-error "~S is not a legal function name." form
)))
399 (dump-fdefinition form
))))
401 (defun fopcompile-if (args path for-value-p
)
402 (destructuring-bind (condition then
&optional else
)
404 (let ((else-label (incf *fopcompile-label-counter
*))
405 (end-label (incf *fopcompile-label-counter
*)))
406 (sb!fasl
::dump-integer else-label
*compile-object
*)
407 (fopcompile condition path t
)
408 ;; If condition was false, skip to the ELSE
409 (sb!fasl
::dump-fop
'sb
!fasl
::fop-skip-if-false
*compile-object
*)
410 (fopcompile then path for-value-p
)
411 ;; The THEN branch will have produced a value even if we were
412 ;; currently skipping to the ELSE branch (or over this whole
413 ;; IF). This is done to ensure that the stack effects are
414 ;; balanced properly when dealing with operations that are
415 ;; executed even when skipping over code. But this particular
416 ;; value will be bogus, so we drop it.
418 (sb!fasl
::dump-fop
'sb
!fasl
::fop-drop-if-skipping
*compile-object
*))
419 ;; Now skip to the END
420 (sb!fasl
::dump-integer end-label
*compile-object
*)
421 (sb!fasl
::dump-fop
'sb
!fasl
::fop-skip
*compile-object
*)
422 ;; Start of the ELSE branch
423 (sb!fasl
::dump-integer else-label
*compile-object
*)
424 (sb!fasl
::dump-fop
'sb
!fasl
::fop-maybe-stop-skipping
*compile-object
*)
425 (fopcompile else path for-value-p
)
428 (sb!fasl
::dump-fop
'sb
!fasl
::fop-drop-if-skipping
*compile-object
*))
430 (sb!fasl
::dump-integer end-label
*compile-object
*)
431 (sb!fasl
::dump-fop
'sb
!fasl
::fop-maybe-stop-skipping
*compile-object
*)
432 ;; If we're still skipping, we must've triggered both of the
433 ;; drop-if-skipping fops. To keep the stack balanced, push a
434 ;; dummy value if needed.
436 (sb!fasl
::dump-fop
'sb
!fasl
::fop-push-nil-if-skipping
437 *compile-object
*)))))
439 (defun fopcompile-constant (form for-value-p
)
441 ;; FIXME: Without this binding the dumper chokes on unvalidated
442 ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
443 ;; about to be dumped, not its load-form. Compare and contrast
444 ;; with EMIT-MAKE-LOAD-FORM.
445 (let ((sb!fasl
::*dump-only-valid-structures
* nil
))
446 (dump-object form
*compile-object
*))))