1.0.12.4: delete bad ROOM test
[sbcl.git] / src / compiler / fopcompile.lisp
1 ;;;; A compiler from simple top-level forms to FASL operations.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!C")
13
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,
30   ;;      e.g.
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))
34   ;;
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.
38   #+sb-xc-host
39   nil
40   #-sb-xc-host
41   (or (and (self-evaluating-p form)
42            (constant-fopcompilable-p form))
43       (and (symbolp form)
44            (multiple-value-bind (macroexpansion macroexpanded-p)
45                (macroexpand form *lexenv*)
46              (if macroexpanded-p
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.
53                        (eq kind :global)
54                        (eq kind :constant))))))
55       (and (listp form)
56            (ignore-errors (list-length form))
57            (multiple-value-bind (macroexpansion macroexpanded-p)
58                (macroexpand form *lexenv*)
59              (if macroexpanded-p
60                  (fopcompilable-p macroexpansion)
61                  (destructuring-bind (operator &rest args) form
62                    (case operator
63                      ;; Special operators that we know how to cope with
64                      ((progn)
65                       (every #'fopcompilable-p args))
66                      ((quote)
67                       (and (= (length args) 1)
68                            (constant-fopcompilable-p (car args))))
69                      ((function)
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
83                                     ;;   -- JES, 2007-01-13
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)))))
89                      ((if)
90                       (and (<= 2 (length args) 3)
91                            (every #'fopcompilable-p args)))
92                      ;; Allow SETQ only on special variables
93                      ((setq)
94                       (loop for (name value) on args by #'cddr
95                             unless (and (symbolp name)
96                                         (let ((kind (info :variable :kind name)))
97                                           (eq kind :special))
98                                         (fopcompilable-p value))
99                             return nil
100                             finally (return t)))
101                      ;; The real toplevel form processing has already been
102                      ;; done, so EVAL-WHEN handling will be easy.
103                      ((eval-when)
104                       (and (>= (length args) 1)
105                            (eq (set-difference (car args)
106                                                '(:compile-toplevel
107                                                  compile
108                                                  :load-toplevel
109                                                  load
110                                                  :execute
111                                                  eval))
112                                nil)
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,
118                      ;; see below)
119                      ((let let*)
120                       (let-fopcompilable-p operator args))
121                      ((locally)
122                       (every #'fopcompilable-p args))
123                      (otherwise
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))))))))))
142
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.
153         (and (null decls)
154              (loop for binding in (car args)
155                    for name = (if (consp binding)
156                                   (first binding)
157                                   binding)
158                    for value = (if (consp binding)
159                                    (second binding)
160                                    nil)
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)
165                                    :global)
166                                (let ((*lexenv* (ecase operator
167                                                  (let orig-lexenv)
168                                                  (let* *lexenv*))))
169                                  (fopcompilable-p value)))
170                    do (progn
171                         (setf *lexenv* (make-lexenv))
172                         (push (cons name
173                                     (make-lambda-var :%source-name name))
174                               (lexenv-vars *lexenv*))))
175              (every #'fopcompilable-p (cdr args)))))))
176
177 (defun lambda-form-p (form)
178   (and (consp form)
179        (member (car form)
180                '(lambda named-lambda instance-lambda lambda-with-lexenv))))
181
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 ((things-processed nil)
186         (count 0))
187     (declare (type (or list hash-table) things-processed)
188              (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
189              (inline member))
190     (labels ((grovel (value)
191                ;; Unless VALUE is an object which which obviously
192                ;; can't contain other objects
193                (unless (typep value
194                               '(or unboxed-array
195                                 symbol
196                                 number
197                                 character
198                                 string))
199                  (etypecase things-processed
200                    (list
201                     (when (member value things-processed :test #'eq)
202                       (return-from grovel nil))
203                     (push value things-processed)
204                     (incf count)
205                     (when (> count list-to-hash-table-threshold)
206                       (let ((things things-processed))
207                         (setf things-processed
208                               (make-hash-table :test 'eq))
209                         (dolist (thing things)
210                           (setf (gethash thing things-processed) t)))))
211                    (hash-table
212                     (when (gethash value things-processed)
213                       (return-from grovel nil))
214                     (setf (gethash value things-processed) t)))
215                  (typecase value
216                    (cons
217                     (grovel (car value))
218                     (grovel (cdr value)))
219                    (simple-vector
220                     (dotimes (i (length value))
221                       (grovel (svref value i))))
222                    ((vector t)
223                     (dotimes (i (length value))
224                       (grovel (aref value i))))
225                    ((simple-array t)
226                     ;; Even though the (ARRAY T) branch does the exact
227                     ;; same thing as this branch we do this separately
228                     ;; so that the compiler can use faster versions of
229                     ;; array-total-size and row-major-aref.
230                     (dotimes (i (array-total-size value))
231                       (grovel (row-major-aref value i))))
232                    ((array t)
233                     (dotimes (i (array-total-size value))
234                       (grovel (row-major-aref value i))))
235                    (instance
236                     (multiple-value-bind (creation-form init-form)
237                         (handler-case
238                             (sb!xc:make-load-form value (make-null-lexenv))
239                           (error (condition)
240                             (compiler-error condition)))
241                       (declare (ignore init-form))
242                       (case creation-form
243                         (:sb-just-dump-it-normally
244                          ;; FIXME: Why is this needed? If the constant
245                          ;; is deemed fopcompilable, then when we dump
246                          ;; it we bind *dump-only-valid-structures* to
247                          ;; NIL.
248                          (fasl-validate-structure value *compile-object*)
249                          (dotimes (i (- (%instance-length value)
250                                         (layout-n-untagged-slots
251                                          (%instance-ref value 0))))
252                            (grovel (%instance-ref value i))))
253                         (:ignore-it)
254                         (t
255                          (return-from constant-fopcompilable-p nil)))))
256                    (t
257                     (return-from constant-fopcompilable-p nil))))))
258       (grovel constant))
259     t))
260
261 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
262 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
263 ;;; has already ensured that the form can be fopcompiled.
264 (defun fopcompile (form path for-value-p)
265   (cond ((self-evaluating-p form)
266          (fopcompile-constant form for-value-p))
267         ((symbolp form)
268          (multiple-value-bind (macroexpansion macroexpanded-p)
269              (sb!xc:macroexpand form *lexenv*)
270            (if macroexpanded-p
271                ;; Symbol macro
272                (fopcompile macroexpansion path for-value-p)
273                (let ((kind (info :variable :kind form)))
274                  (if (member kind '(:special :constant))
275                      ;; Special variable
276                      (fopcompile `(symbol-value ',form) path for-value-p)
277                      ;; Lexical
278                      (when for-value-p
279                        (let* ((lambda-var (cdr (assoc form (lexenv-vars *lexenv*))))
280                               (handle (when lambda-var
281                                         (lambda-var-fop-value lambda-var))))
282                          (if handle
283                              (sb!fasl::dump-push handle
284                                                  *compile-object*)
285                              (progn
286                                ;; Undefined variable. Signal a warning, and
287                                ;; treat it as a special variable reference,
288                                ;; like the real compiler does.
289                                (note-undefined-reference form :variable)
290                                (fopcompile `(symbol-value ',form)
291                                            path
292                                            for-value-p))))))))))
293         ((listp form)
294          (multiple-value-bind (macroexpansion macroexpanded-p)
295              (sb!xc:macroexpand form *lexenv*)
296            (if macroexpanded-p
297                (fopcompile macroexpansion path for-value-p)
298                (destructuring-bind (operator &rest args) form
299                  (case operator
300                    ;; The QUOTE special operator is worth handling: very
301                    ;; easy and very common at toplevel.
302                    ((quote)
303                     (fopcompile-constant (second form) for-value-p))
304                    ;; A FUNCTION needs to be compiled properly, but doesn't
305                    ;; need to prevent the fopcompilation of the whole form.
306                    ;; We just compile it, and emit an instruction for pushing
307                    ;; the function handle on the FOP stack.
308                    ((function)
309                     (fopcompile-function (second form) path for-value-p))
310                    ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
311                    ;; by a compiler-macro. Doing general compiler-macro
312                    ;; expansion in the fopcompiler is probably not sensible,
313                    ;; so we'll just special-case it.
314                    ((source-location)
315                     (if (policy *policy* (and (> space 1)
316                                               (> space debug)))
317                         (fopcompile-constant nil for-value-p)
318                         (fopcompile (let ((*current-path* path))
319                                       (make-definition-source-location))
320                                     path
321                                     for-value-p)))
322                    ((if)
323                     (fopcompile-if args path for-value-p))
324                    ((progn)
325                     (loop for (arg . next) on args
326                           do (fopcompile arg
327                                          path (if next
328                                                   nil
329                                                   for-value-p))))
330                    ((setq)
331                     (loop for (name value . next) on args by #'cddr
332                           do (fopcompile `(set ',name ,value) path
333                                          (if next
334                                              nil
335                                              for-value-p))))
336                    ((eval-when)
337                     (destructuring-bind (situations &body body) args
338                       (if (or (member :execute situations)
339                               (member 'eval situations))
340                           (fopcompile (cons 'progn body) path for-value-p)
341                           (fopcompile nil path for-value-p))))
342                    ((let let*)
343                     (let ((orig-lexenv *lexenv*)
344                           (*lexenv* (make-lexenv :default *lexenv*)))
345                       (loop for binding in (car args)
346                             for name = (if (consp binding)
347                                            (first binding)
348                                            binding)
349                             for value = (if (consp binding)
350                                             (second binding)
351                                             nil)
352                             do (let ((*lexenv* (if (eql operator 'let)
353                                                    orig-lexenv
354                                                    *lexenv*)))
355                                  (fopcompile value path t))
356                             do (let ((obj (sb!fasl::dump-pop *compile-object*)))
357                                  (setf *lexenv*
358                                        (make-lexenv
359                                         :vars (list (cons name
360                                                           (make-lambda-var
361                                                            :%source-name name
362                                                            :fop-value obj)))))))
363                       (fopcompile (cons 'progn (cdr args)) path for-value-p)))
364                    ;; Otherwise it must be an ordinary funcall.
365                    (otherwise
366                     (cond
367                       ;; Special hack: there's already a fop for
368                       ;; find-undeleted-package-or-lose, so use it.
369                       ;; (We could theoretically do the same for
370                       ;; other operations, but I don't see any good
371                       ;; candidates in a quick read-through of
372                       ;; src/code/fop.lisp.)
373                       ((and (eq operator
374                                 'sb!int:find-undeleted-package-or-lose)
375                             (= 1 (length args))
376                             for-value-p)
377                        (fopcompile (first args) path t)
378                        (sb!fasl::dump-fop 'sb!fasl::fop-package
379                                           *compile-object*))
380                       (t
381                        (fopcompile-constant operator t)
382                        (dolist (arg args)
383                          (fopcompile arg path t))
384                        (if for-value-p
385                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall
386                                               *compile-object*)
387                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect
388                                               *compile-object*))
389                        (let ((n-args (length args)))
390                          ;; stub: FOP-FUNCALL isn't going to be usable
391                          ;; to compile more than this, since its count
392                          ;; is a single byte. Maybe we should just punt
393                          ;; to the ordinary compiler in that case?
394                          (aver (<= n-args 255))
395                          (sb!fasl::dump-byte n-args *compile-object*))))))))))
396         (t
397          (bug "looks unFOPCOMPILEable: ~S" form))))
398
399 (defun fopcompile-function (form path for-value-p)
400   (flet ((dump-fdefinition (name)
401            (fopcompile `(fdefinition ',name) path for-value-p)))
402     (if (consp form)
403         (cond
404           ;; Lambda forms are compiled with the real compiler
405           ((lambda-form-p form)
406            (let* ((handle (%compile form
407                                     *compile-object*
408                                     :path path)))
409              (when for-value-p
410                (sb!fasl::dump-push handle *compile-object*))))
411           ;; While function names are translated to a call to FDEFINITION.
412           ((legal-fun-name-p form)
413            (dump-fdefinition form))
414           (t
415            (compiler-error "~S is not a legal function name." form)))
416         (dump-fdefinition form))))
417
418 (defun fopcompile-if (args path for-value-p)
419   (destructuring-bind (condition then &optional else)
420       args
421     (let ((else-label (incf *fopcompile-label-counter*))
422           (end-label (incf *fopcompile-label-counter*)))
423       (sb!fasl::dump-integer else-label *compile-object*)
424       (fopcompile condition path t)
425       ;; If condition was false, skip to the ELSE
426       (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*)
427       (fopcompile then path for-value-p)
428       ;; The THEN branch will have produced a value even if we were
429       ;; currently skipping to the ELSE branch (or over this whole
430       ;; IF). This is done to ensure that the stack effects are
431       ;; balanced properly when dealing with operations that are
432       ;; executed even when skipping over code. But this particular
433       ;; value will be bogus, so we drop it.
434       (when for-value-p
435         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
436       ;; Now skip to the END
437       (sb!fasl::dump-integer end-label *compile-object*)
438       (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*)
439       ;; Start of the ELSE branch
440       (sb!fasl::dump-integer else-label *compile-object*)
441       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
442       (fopcompile else path for-value-p)
443       ;; As before
444       (when for-value-p
445         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
446       ;; End of IF
447       (sb!fasl::dump-integer end-label *compile-object*)
448       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
449       ;; If we're still skipping, we must've triggered both of the
450       ;; drop-if-skipping fops. To keep the stack balanced, push a
451       ;; dummy value if needed.
452       (when for-value-p
453         (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping
454                            *compile-object*)))))
455
456 (defun fopcompile-constant (form for-value-p)
457   (when for-value-p
458     ;; FIXME: Without this binding the dumper chokes on unvalidated
459     ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
460     ;; about to be dumped, not its load-form. Compare and contrast
461     ;; with EMIT-MAKE-LOAD-FORM.
462     (let ((sb!fasl::*dump-only-valid-structures* nil))
463       (dump-object form *compile-object*))))