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)
47 (fopcompilable-p macroexpansion)
48 ;; Punt on :ALIEN variables
49 (let ((kind (info :variable :kind form)))
50 (or (eq kind :special)
51 (eq kind :constant))))))
53 (ignore-errors (list-length form))
54 (multiple-value-bind (macroexpansion macroexpanded-p)
57 (fopcompilable-p macroexpansion)
58 (destructuring-bind (operator &rest args) form
60 ;; Special operators that we know how to cope with
62 (every #'fopcompilable-p args))
64 (and (= (length args) 1)
65 (constant-fopcompilable-p (car args))))
67 (and (= (length args) 1)
68 ;; #'(LAMBDA ...), #'(NAMED-LAMBDA ...), etc. These
69 ;; are not fopcompileable as such, but we can compile
70 ;; the lambdas with the real compiler, and the rest
71 ;; of the expression with the fop-compiler.
72 (or (lambda-form-p (car args))
73 ;; #'FOO, #'(SETF FOO), etc
74 (legal-fun-name-p (car args)))))
76 (and (<= 2 (length args) 3)
77 (every #'fopcompilable-p args)))
78 ;; Allow SETQ only on special variables
80 (loop for (name value) on args by #'cddr
81 unless (and (symbolp name)
82 (let ((kind (info :variable :kind name)))
84 (fopcompilable-p value))
87 ;; The real toplevel form processing has already been
88 ;; done, so EVAL-WHEN handling will be easy.
90 (and (>= (length args) 1)
91 (eq (set-difference (car args)
99 (every #'fopcompilable-p (cdr args))))
100 ;; A LET or LET* that introduces no bindings or
101 ;; declarations is trivially fopcompilable. Forms
102 ;; with no bindings but with declarations could also
103 ;; be handled, but we're currently punting on any
104 ;; lexenv manipulation.
106 (and (>= (length args) 1)
108 (every #'fopcompilable-p (cdr args))))
109 ;; Likewise for LOCALLY
111 (every #'fopcompilable-p args))
113 ;; ordinary function calls
114 (and (symbolp operator)
115 ;; If a LET/LOCALLY tries to introduce
116 ;; declarations, we'll detect it here, and
117 ;; disallow fopcompilation. This is safe,
118 ;; since defining a function/macro named
119 ;; DECLARE would violate a package lock.
120 (not (eq operator 'declare))
121 (not (special-operator-p operator))
122 (not (macro-function operator))
123 ;; We can't FOP-FUNCALL with more than 255
124 ;; parameters. (We could theoretically use
125 ;; APPLY, but then we'd need to construct
126 ;; the parameter list for APPLY without
127 ;; calling LIST, which is probably more
128 ;; trouble than it's worth).
129 (<= (length args) 255)
130 (every #'fopcompilable-p args))))))))))
132 (defun lambda-form-p (form)
135 '(lambda named-lambda instance-lambda lambda-with-lexenv))))
137 ;;; Check that a literal form is fopcompilable. It would not for example
138 ;;; when the form contains structures with funny MAKE-LOAD-FORMS.
139 (defun constant-fopcompilable-p (constant)
140 (let ((things-processed nil)
142 (declare (type (or list hash-table) things-processed)
143 (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
145 (labels ((grovel (value)
146 ;; Unless VALUE is an object which which obviously
147 ;; can't contain other objects
154 (etypecase things-processed
156 (when (member value things-processed :test #'eq)
157 (return-from grovel nil))
158 (push value things-processed)
160 (when (> count list-to-hash-table-threshold)
161 (let ((things things-processed))
162 (setf things-processed
163 (make-hash-table :test 'eq))
164 (dolist (thing things)
165 (setf (gethash thing things-processed) t)))))
167 (when (gethash value things-processed)
168 (return-from grovel nil))
169 (setf (gethash value things-processed) t)))
173 (grovel (cdr value)))
175 (dotimes (i (length value))
176 (grovel (svref value i))))
178 (dotimes (i (length value))
179 (grovel (aref value i))))
181 ;; Even though the (ARRAY T) branch does the exact
182 ;; same thing as this branch we do this separately
183 ;; so that the compiler can use faster versions of
184 ;; array-total-size and row-major-aref.
185 (dotimes (i (array-total-size value))
186 (grovel (row-major-aref value i))))
188 (dotimes (i (array-total-size value))
189 (grovel (row-major-aref value i))))
191 (multiple-value-bind (creation-form init-form)
193 (sb!xc:make-load-form value (make-null-lexenv))
195 (compiler-error condition)))
196 (declare (ignore init-form))
198 (:sb-just-dump-it-normally
199 (fasl-validate-structure constant *compile-object*)
200 (dotimes (i (- (%instance-length value)
201 (layout-n-untagged-slots
202 (%instance-ref value 0))))
203 (grovel (%instance-ref value i))))
206 (return-from constant-fopcompilable-p nil)))))
208 (return-from constant-fopcompilable-p nil))))))
212 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
213 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
214 ;;; has already ensured that the form can be fopcompiled.
215 (defun fopcompile (form path for-value-p)
216 (cond ((self-evaluating-p form)
217 (fopcompile-constant form for-value-p))
219 (multiple-value-bind (macroexpansion macroexpanded-p)
223 (fopcompile macroexpansion path for-value-p)
225 (fopcompile `(symbol-value ',form) path for-value-p))))
227 (multiple-value-bind (macroexpansion macroexpanded-p)
230 (fopcompile macroexpansion path for-value-p)
231 (destructuring-bind (operator &rest args) form
233 ;; The QUOTE special operator is worth handling: very
234 ;; easy and very common at toplevel.
236 (fopcompile-constant (second form) for-value-p))
237 ;; A FUNCTION needs to be compiled properly, but doesn't
238 ;; need to prevent the fopcompilation of the whole form.
239 ;; We just compile it, and emit an instruction for pushing
240 ;; the function handle on the FOP stack.
242 (fopcompile-function (second form) path for-value-p))
243 ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
244 ;; by a compiler-macro. Doing general compiler-macro
245 ;; expansion in the fopcompiler is probably not sensible,
246 ;; so we'll just special-case it.
248 (if (policy *policy* (and (> space 1)
250 (fopcompile-constant nil for-value-p)
251 (fopcompile (let ((*current-path* path))
252 (make-definition-source-location))
256 (fopcompile-if args path for-value-p))
258 (loop for (arg . next) on args
264 (loop for (name value . next) on args by #'cddr
265 do (fopcompile `(set ',name ,value) path
270 (destructuring-bind (situations &body body) args
271 (if (or (member :execute situations)
272 (member 'eval situations))
273 (fopcompile (cons 'progn body) path for-value-p)
274 (fopcompile nil path for-value-p))))
276 (fopcompile (cons 'progn (cdr args)) path for-value-p))
277 ;; Otherwise it must be an ordinary funcall.
280 ;; Special hack: there's already a fop for
281 ;; find-undeleted-package-or-lose, so use it.
282 ;; (We could theoretically do the same for
283 ;; other operations, but I don't see any good
284 ;; candidates in a quick read-through of
285 ;; src/code/fop.lisp.)
287 'sb!int:find-undeleted-package-or-lose)
290 (fopcompile (first args) path t)
291 (sb!fasl::dump-fop 'sb!fasl::fop-package
294 (fopcompile-constant operator t)
296 (fopcompile arg path t))
298 (sb!fasl::dump-fop 'sb!fasl::fop-funcall
300 (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect
302 (let ((n-args (length args)))
303 ;; stub: FOP-FUNCALL isn't going to be usable
304 ;; to compile more than this, since its count
305 ;; is a single byte. Maybe we should just punt
306 ;; to the ordinary compiler in that case?
307 (aver (<= n-args 255))
308 (sb!fasl::dump-byte n-args *compile-object*))))))))))
310 (bug "looks unFOPCOMPILEable: ~S" form))))
312 (defun fopcompile-function (form path for-value-p)
313 (flet ((dump-fdefinition (name)
314 (fopcompile `(fdefinition ',name) path for-value-p)))
317 ;; Lambda forms are compiled with the real compiler
318 ((lambda-form-p form)
319 ;; We wrap the real lambda inside another one to ensure
320 ;; that the compiler doesn't e.g. let convert it, thinking
321 ;; that there are no external references.
322 (let* ((handle (%compile `(lambda () ,form)
326 (sb!fasl::dump-push handle *compile-object*)
327 ;; And then call the wrapper function when loading the FASL
328 (sb!fasl::dump-fop 'sb!fasl::fop-funcall *compile-object*)
329 (sb!fasl::dump-byte 0 *compile-object*))))
330 ;; While function names are translated to a call to FDEFINITION.
331 ((legal-fun-name-p form)
332 (dump-fdefinition form))
334 (compiler-error "~S is not a legal function name." form)))
335 (dump-fdefinition form))))
337 (defun fopcompile-if (args path for-value-p)
338 (destructuring-bind (condition then &optional else)
340 (let ((else-label (incf *fopcompile-label-counter*))
341 (end-label (incf *fopcompile-label-counter*)))
342 (sb!fasl::dump-integer else-label *compile-object*)
343 (fopcompile condition path t)
344 ;; If condition was false, skip to the ELSE
345 (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*)
346 (fopcompile then path for-value-p)
347 ;; The THEN branch will have produced a value even if we were
348 ;; currently skipping to the ELSE branch (or over this whole
349 ;; IF). This is done to ensure that the stack effects are
350 ;; balanced properly when dealing with operations that are
351 ;; executed even when skipping over code. But this particular
352 ;; value will be bogus, so we drop it.
354 (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
355 ;; Now skip to the END
356 (sb!fasl::dump-integer end-label *compile-object*)
357 (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*)
358 ;; Start of the ELSE branch
359 (sb!fasl::dump-integer else-label *compile-object*)
360 (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
361 (fopcompile else path for-value-p)
364 (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
366 (sb!fasl::dump-integer end-label *compile-object*)
367 (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
368 ;; If we're still skipping, we must've triggered both of the
369 ;; drop-if-skipping fops. To keep the stack balanced, push a
370 ;; dummy value if needed.
372 (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping
373 *compile-object*)))))
375 (defun fopcompile-constant (form for-value-p)
377 (let ((sb!fasl::*dump-only-valid-structures* nil))
378 (dump-object form *compile-object*))))