1.0.29.13: relax CAST-EXTERNALLY-CHECKABLE-P a bit
[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   (declare (ignore form))
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                    (member kind '(:special :constant :global :unknown))))))
51       (and (listp form)
52            (ignore-errors (list-length form))
53            (multiple-value-bind (macroexpansion macroexpanded-p)
54                (macroexpand form *lexenv*)
55              (if macroexpanded-p
56                  (fopcompilable-p macroexpansion)
57                  (destructuring-bind (operator &rest args) form
58                    (case operator
59                      ;; Special operators that we know how to cope with
60                      ((progn)
61                       (every #'fopcompilable-p args))
62                      ((quote)
63                       (and (= (length args) 1)
64                            (constant-fopcompilable-p (car args))))
65                      ((function)
66                       (and (= (length args) 1)
67                            ;; #'(LAMBDA ...), #'(NAMED-LAMBDA ...), etc. These
68                            ;; are not fopcompileable as such, but we can compile
69                            ;; the lambdas with the real compiler, and the rest
70                            ;; of the expression with the fop-compiler.
71                            (or (and (lambda-form-p (car args))
72                                     ;; The lambda might be closing over some
73                                     ;; variable, punt. As a further improvement,
74                                     ;; we could analyze the lambda body to
75                                     ;; see whether it really closes over any
76                                     ;; variables. One place where even simple
77                                     ;; analysis would be useful are the PCL
78                                     ;; slot-definition type-check-functions
79                                     ;;   -- JES, 2007-01-13
80                                     (notany (lambda (binding)
81                                               (lambda-var-p (cdr binding)))
82                                             (lexenv-vars *lexenv*)))
83                                ;; #'FOO, #'(SETF FOO), etc
84                                (legal-fun-name-p (car args)))))
85                      ((if)
86                       (and (<= 2 (length args) 3)
87                            (every #'fopcompilable-p args)))
88                      ;; Allow SETQ only on special variables
89                      ((setq)
90                       (loop for (name value) on args by #'cddr
91                             unless (and (symbolp name)
92                                         (let ((kind (info :variable :kind name)))
93                                           (eq kind :special))
94                                         (fopcompilable-p value))
95                             return nil
96                             finally (return t)))
97                      ;; The real toplevel form processing has already been
98                      ;; done, so EVAL-WHEN handling will be easy.
99                      ((eval-when)
100                       (and (>= (length args) 1)
101                            (eq (set-difference (car args)
102                                                '(:compile-toplevel
103                                                  compile
104                                                  :load-toplevel
105                                                  load
106                                                  :execute
107                                                  eval))
108                                nil)
109                            (every #'fopcompilable-p (cdr args))))
110                      ;; A LET or LET* that introduces only lexical
111                      ;; bindings might be fopcompilable, depending on
112                      ;; whether something closes over the bindings.
113                      ;; (And whether there are declarations in the body,
114                      ;; see below)
115                      ((let let*)
116                       (let-fopcompilable-p operator args))
117                      ((locally)
118                       (every #'fopcompilable-p args))
119                      (otherwise
120                       ;; ordinary function calls
121                       (and (symbolp operator)
122                            ;; If a LET/LOCALLY tries to introduce
123                            ;; declarations, we'll detect it here, and
124                            ;; disallow fopcompilation.  This is safe,
125                            ;; since defining a function/macro named
126                            ;; DECLARE would violate a package lock.
127                            (not (eq operator 'declare))
128                            (not (special-operator-p operator))
129                            (not (macro-function operator))
130                            ;; We can't FOP-FUNCALL with more than 255
131                            ;; parameters. (We could theoretically use
132                            ;; APPLY, but then we'd need to construct
133                            ;; the parameter list for APPLY without
134                            ;; calling LIST, which is probably more
135                            ;; trouble than it's worth).
136                            (<= (length args) 255)
137                            (every #'fopcompilable-p args))))))))))
138
139 (defun let-fopcompilable-p (operator args)
140   (when (>= (length args) 1)
141     (multiple-value-bind (body decls)
142         (parse-body (cdr args) :doc-string-allowed nil)
143       (declare (ignore body))
144       (let* ((orig-lexenv *lexenv*)
145              (*lexenv* (make-lexenv)))
146         ;; We need to check for declarations
147         ;; first. Otherwise the fake lexenv we're
148         ;; constructing might be invalid.
149         (and (null decls)
150              (loop for binding in (car args)
151                    for name = (if (consp binding)
152                                   (first binding)
153                                   binding)
154                    for value = (if (consp binding)
155                                    (second binding)
156                                    nil)
157                    ;; Only allow binding locals, since special bindings can't
158                    ;; be easily expressed with fops.
159                    always (and (eq (info :variable :kind name)
160                                    :unknown)
161                                (let ((*lexenv* (ecase operator
162                                                  (let orig-lexenv)
163                                                  (let* *lexenv*))))
164                                  (fopcompilable-p value)))
165                    do (progn
166                         (setf *lexenv* (make-lexenv))
167                         (push (cons name
168                                     (make-lambda-var :%source-name name))
169                               (lexenv-vars *lexenv*))))
170              (every #'fopcompilable-p (cdr args)))))))
171
172 (defun lambda-form-p (form)
173   (and (consp form)
174        (member (car form)
175                '(lambda named-lambda instance-lambda lambda-with-lexenv))))
176
177 ;;; Check that a literal form is fopcompilable. It would not for example
178 ;;; when the form contains structures with funny MAKE-LOAD-FORMS.
179 (defun constant-fopcompilable-p (constant)
180   (let ((xset (alloc-xset)))
181     (labels ((grovel (value)
182                ;; Unless VALUE is an object which which obviously
183                ;; can't contain other objects
184                (unless (typep value
185                               '(or unboxed-array
186                                 symbol
187                                 number
188                                 character
189                                 string))
190                  (if (xset-member-p value xset)
191                      (return-from grovel nil)
192                      (add-to-xset value xset))
193                  (typecase value
194                    (cons
195                     (grovel (car value))
196                     (grovel (cdr value)))
197                    (simple-vector
198                     (dotimes (i (length value))
199                       (grovel (svref value i))))
200                    ((vector t)
201                     (dotimes (i (length value))
202                       (grovel (aref value i))))
203                    ((simple-array t)
204                     ;; Even though the (ARRAY T) branch does the exact
205                     ;; same thing as this branch we do this separately
206                     ;; so that the compiler can use faster versions of
207                     ;; array-total-size and row-major-aref.
208                     (dotimes (i (array-total-size value))
209                       (grovel (row-major-aref value i))))
210                    ((array t)
211                     (dotimes (i (array-total-size value))
212                       (grovel (row-major-aref value i))))
213                    (instance
214                     (multiple-value-bind (creation-form init-form)
215                         (handler-case
216                             (sb!xc:make-load-form value (make-null-lexenv))
217                           (error (condition)
218                             (compiler-error condition)))
219                       (declare (ignore init-form))
220                       (case creation-form
221                         (:sb-just-dump-it-normally
222                          ;; FIXME: Why is this needed? If the constant
223                          ;; is deemed fopcompilable, then when we dump
224                          ;; it we bind *dump-only-valid-structures* to
225                          ;; NIL.
226                          (fasl-validate-structure value *compile-object*)
227                          (dotimes (i (- (%instance-length value)
228                                         (layout-n-untagged-slots
229                                          (%instance-ref value 0))))
230                            (grovel (%instance-ref value i))))
231                         (:ignore-it)
232                         (t
233                          (return-from constant-fopcompilable-p nil)))))
234                    (t
235                     (return-from constant-fopcompilable-p nil))))))
236       (grovel constant))
237     t))
238
239 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
240 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
241 ;;; has already ensured that the form can be fopcompiled.
242 (defun fopcompile (form path for-value-p)
243   (cond ((self-evaluating-p form)
244          (fopcompile-constant form for-value-p))
245         ((symbolp form)
246          (multiple-value-bind (macroexpansion macroexpanded-p)
247              (sb!xc:macroexpand form *lexenv*)
248            (if macroexpanded-p
249                ;; Symbol macro
250                (fopcompile macroexpansion path for-value-p)
251                (let ((kind (info :variable :kind form)))
252                  (if (member kind '(:special :constant))
253                      ;; Special variable
254                      (fopcompile `(symbol-value ',form) path for-value-p)
255                      ;; Lexical
256                      (let* ((lambda-var (cdr (assoc form (lexenv-vars *lexenv*))))
257                             (handle (when lambda-var
258                                       (lambda-var-fop-value lambda-var))))
259                        (if handle
260                            (when for-value-p
261                              (sb!fasl::dump-push handle *compile-object*))
262                            (progn
263                              ;; Undefined variable. Signal a warning, and
264                              ;; treat it as a special variable reference, like
265                              ;; the real compiler does -- do not elide even if
266                              ;; the value is unused.
267                              (note-undefined-reference form :variable)
268                              (fopcompile `(symbol-value ',form)
269                                          path
270                                          for-value-p)))))))))
271         ((listp form)
272          (multiple-value-bind (macroexpansion macroexpanded-p)
273              (sb!xc:macroexpand form *lexenv*)
274            (if macroexpanded-p
275                (fopcompile macroexpansion path for-value-p)
276                (destructuring-bind (operator &rest args) form
277                  (case operator
278                    ;; The QUOTE special operator is worth handling: very
279                    ;; easy and very common at toplevel.
280                    ((quote)
281                     (fopcompile-constant (second form) for-value-p))
282                    ;; A FUNCTION needs to be compiled properly, but doesn't
283                    ;; need to prevent the fopcompilation of the whole form.
284                    ;; We just compile it, and emit an instruction for pushing
285                    ;; the function handle on the FOP stack.
286                    ((function)
287                     (fopcompile-function (second form) path for-value-p))
288                    ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
289                    ;; by a compiler-macro. Doing general compiler-macro
290                    ;; expansion in the fopcompiler is probably not sensible,
291                    ;; so we'll just special-case it.
292                    ((source-location)
293                     (if (policy *policy* (and (> space 1)
294                                               (> space debug)))
295                         (fopcompile-constant nil for-value-p)
296                         (fopcompile (let ((*current-path* path))
297                                       (make-definition-source-location))
298                                     path
299                                     for-value-p)))
300                    ((if)
301                     (fopcompile-if args path for-value-p))
302                    ((progn locally)
303                     (loop for (arg . next) on args
304                           do (fopcompile arg
305                                          path (if next
306                                                   nil
307                                                   for-value-p))))
308                    ((setq)
309                     (loop for (name value . next) on args by #'cddr
310                           do (fopcompile `(set ',name ,value) path
311                                          (if next
312                                              nil
313                                              for-value-p))))
314                    ((eval-when)
315                     (destructuring-bind (situations &body body) args
316                       (if (or (member :execute situations)
317                               (member 'eval situations))
318                           (fopcompile (cons 'progn body) path for-value-p)
319                           (fopcompile nil path for-value-p))))
320                    ((let let*)
321                     (let ((orig-lexenv *lexenv*)
322                           (*lexenv* (make-lexenv :default *lexenv*)))
323                       (loop for binding in (car args)
324                             for name = (if (consp binding)
325                                            (first binding)
326                                            binding)
327                             for value = (if (consp binding)
328                                             (second binding)
329                                             nil)
330                             do (let ((*lexenv* (if (eql operator 'let)
331                                                    orig-lexenv
332                                                    *lexenv*)))
333                                  (fopcompile value path t))
334                             do (let ((obj (sb!fasl::dump-pop *compile-object*)))
335                                  (setf *lexenv*
336                                        (make-lexenv
337                                         :vars (list (cons name
338                                                           (make-lambda-var
339                                                            :%source-name name
340                                                            :fop-value obj)))))))
341                       (fopcompile (cons 'progn (cdr args)) path for-value-p)))
342                    ;; Otherwise it must be an ordinary funcall.
343                    (otherwise
344                     (cond
345                       ;; Special hack: there's already a fop for
346                       ;; find-undeleted-package-or-lose, so use it.
347                       ;; (We could theoretically do the same for
348                       ;; other operations, but I don't see any good
349                       ;; candidates in a quick read-through of
350                       ;; src/code/fop.lisp.)
351                       ((and (eq operator
352                                 'sb!int:find-undeleted-package-or-lose)
353                             (= 1 (length args))
354                             for-value-p)
355                        (fopcompile (first args) path t)
356                        (sb!fasl::dump-fop 'sb!fasl::fop-package
357                                           *compile-object*))
358                       (t
359                        (fopcompile-constant operator t)
360                        (dolist (arg args)
361                          (fopcompile arg path t))
362                        (if for-value-p
363                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall
364                                               *compile-object*)
365                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect
366                                               *compile-object*))
367                        (let ((n-args (length args)))
368                          ;; stub: FOP-FUNCALL isn't going to be usable
369                          ;; to compile more than this, since its count
370                          ;; is a single byte. Maybe we should just punt
371                          ;; to the ordinary compiler in that case?
372                          (aver (<= n-args 255))
373                          (sb!fasl::dump-byte n-args *compile-object*))))))))))
374         (t
375          (bug "looks unFOPCOMPILEable: ~S" form))))
376
377 (defun fopcompile-function (form path for-value-p)
378   (flet ((dump-fdefinition (name)
379            (fopcompile `(fdefinition ',name) path for-value-p)))
380     (if (consp form)
381         (cond
382           ;; Lambda forms are compiled with the real compiler
383           ((lambda-form-p form)
384            (let* ((handle (%compile form
385                                     *compile-object*
386                                     :path path)))
387              (when for-value-p
388                (sb!fasl::dump-push handle *compile-object*))))
389           ;; While function names are translated to a call to FDEFINITION.
390           ((legal-fun-name-p form)
391            (dump-fdefinition form))
392           (t
393            (compiler-error "~S is not a legal function name." form)))
394         (dump-fdefinition form))))
395
396 (defun fopcompile-if (args path for-value-p)
397   (destructuring-bind (condition then &optional else)
398       args
399     (let ((else-label (incf *fopcompile-label-counter*))
400           (end-label (incf *fopcompile-label-counter*)))
401       (sb!fasl::dump-integer else-label *compile-object*)
402       (fopcompile condition path t)
403       ;; If condition was false, skip to the ELSE
404       (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*)
405       (fopcompile then path for-value-p)
406       ;; The THEN branch will have produced a value even if we were
407       ;; currently skipping to the ELSE branch (or over this whole
408       ;; IF). This is done to ensure that the stack effects are
409       ;; balanced properly when dealing with operations that are
410       ;; executed even when skipping over code. But this particular
411       ;; value will be bogus, so we drop it.
412       (when for-value-p
413         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
414       ;; Now skip to the END
415       (sb!fasl::dump-integer end-label *compile-object*)
416       (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*)
417       ;; Start of the ELSE branch
418       (sb!fasl::dump-integer else-label *compile-object*)
419       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
420       (fopcompile else path for-value-p)
421       ;; As before
422       (when for-value-p
423         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
424       ;; End of IF
425       (sb!fasl::dump-integer end-label *compile-object*)
426       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
427       ;; If we're still skipping, we must've triggered both of the
428       ;; drop-if-skipping fops. To keep the stack balanced, push a
429       ;; dummy value if needed.
430       (when for-value-p
431         (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping
432                            *compile-object*)))))
433
434 (defun fopcompile-constant (form for-value-p)
435   (when for-value-p
436     ;; FIXME: Without this binding the dumper chokes on unvalidated
437     ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
438     ;; about to be dumped, not its load-form. Compare and contrast
439     ;; with EMIT-MAKE-LOAD-FORM.
440     (let ((sb!fasl::*dump-only-valid-structures* nil))
441       (dump-object form *compile-object*))))