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)
  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                        (eq kind :constant))))))
  52       (and (listp form)
  53            (ignore-errors (list-length form))
  54            (multiple-value-bind (macroexpansion macroexpanded-p)
  55                (macroexpand form)
  56              (if macroexpanded-p
  57                  (fopcompilable-p macroexpansion)
  58                  (destructuring-bind (operator &rest args) form
  59                    (case operator
  60                      ;; Special operators that we know how to cope with
  61                      ((progn)
  62                       (every #'fopcompilable-p args))
  63                      ((quote)
  64                       (and (= (length args) 1)
  65                            (constant-fopcompilable-p (car args))))
  66                      ((function)
  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)))))
  75                      ((if)
  76                       (and (<= 2 (length args) 3)
  77                            (every #'fopcompilable-p args)))
  78                      ;; Allow SETQ only on special variables
  79                      ((setq)
  80                       (loop for (name value) on args by #'cddr
  81                             unless (and (symbolp name)
  82                                         (let ((kind (info :variable :kind name)))
  83                                           (eq kind :special))
  84                                         (fopcompilable-p value))
  85                             return nil
  86                             finally (return t)))
  87                      ;; The real toplevel form processing has already been
  88                      ;; done, so EVAL-WHEN handling will be easy.
  89                      ((eval-when)
  90                       (and (>= (length args) 1)
  91                            (eq (set-difference (car args)
  92                                                '(:compile-toplevel
  93                                                  compile
  94                                                  :load-toplevel
  95                                                  load
  96                                                  :execute
  97                                                  eval))
  98                                nil)
  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.
 105                      ((let let*)
 106                       (and (>= (length args) 1)
 107                            (null (car args))
 108                            (every #'fopcompilable-p (cdr args))))
 109                      ;; Likewise for LOCALLY
 110                      ((locally)
 111                       (every #'fopcompilable-p args))
 112                      (otherwise
 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))))))))))
 131
 132 (defun lambda-form-p (form)
 133   (and (consp form)
 134        (member (car form)
 135                '(lambda named-lambda instance-lambda lambda-with-lexenv))))
 136
 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)
 141         (count 0))
 142     (declare (type (or list hash-table) things-processed)
 143              (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
 144              (inline member))
 145     (labels ((grovel (value)
 146                ;; Unless VALUE is an object which which obviously
 147                ;; can't contain other objects
 148                (unless (typep value
 149                               '(or unboxed-array
 150                                 symbol
 151                                 number
 152                                 character
 153                                 string))
 154                  (etypecase things-processed
 155                    (list
 156                     (when (member value things-processed :test #'eq)
 157                       (return-from grovel nil))
 158                     (push value things-processed)
 159                     (incf count)
 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)))))
 166                    (hash-table
 167                     (when (gethash value things-processed)
 168                       (return-from grovel nil))
 169                     (setf (gethash value things-processed) t)))
 170                  (typecase value
 171                    (cons
 172                     (grovel (car value))
 173                     (grovel (cdr value)))
 174                    (simple-vector
 175                     (dotimes (i (length value))
 176                       (grovel (svref value i))))
 177                    ((vector t)
 178                     (dotimes (i (length value))
 179                       (grovel (aref value i))))
 180                    ((simple-array t)
 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))))
 187                    ((array t)
 188                     (dotimes (i (array-total-size value))
 189                       (grovel (row-major-aref value i))))
 190                    (instance
 191                     (multiple-value-bind (creation-form init-form)
 192                         (handler-case
 193                             (sb!xc:make-load-form value (make-null-lexenv))
 194                           (error (condition)
 195                             (compiler-error condition)))
 196                       (declare (ignore init-form))
 197                       (case creation-form
 198                         (:sb-just-dump-it-normally
 199                          ;; FIXME: Why is this needed? If the constant
 200                          ;; is deemed fopcompilable, then when we dump
 201                          ;; it we bind *dump-only-valid-structures* to
 202                          ;; NIL.
 203                          (fasl-validate-structure value *compile-object*)
 204                          (dotimes (i (- (%instance-length value)
 205                                         (layout-n-untagged-slots
 206                                          (%instance-ref value 0))))
 207                            (grovel (%instance-ref value i))))
 208                         (:ignore-it)
 209                         (t
 210                          (return-from constant-fopcompilable-p nil)))))
 211                    (t
 212                     (return-from constant-fopcompilable-p nil))))))
 213       (grovel constant))
 214     t))
 215
 216 ;;; FOR-VALUE-P is true if the value will be used (i.e., pushed onto
 217 ;;; FOP stack), or NIL if any value will be discarded. FOPCOMPILABLE-P
 218 ;;; has already ensured that the form can be fopcompiled.
 219 (defun fopcompile (form path for-value-p)
 220   (cond ((self-evaluating-p form)
 221          (fopcompile-constant form for-value-p))
 222         ((symbolp form)
 223          (multiple-value-bind (macroexpansion macroexpanded-p)
 224              (macroexpand form)
 225            (if macroexpanded-p
 226                ;; Symbol macro
 227                (fopcompile macroexpansion path for-value-p)
 228                ;; Special variable
 229                (fopcompile `(symbol-value ',form) path for-value-p))))
 230         ((listp form)
 231          (multiple-value-bind (macroexpansion macroexpanded-p)
 232              (macroexpand form)
 233            (if macroexpanded-p
 234                (fopcompile macroexpansion path for-value-p)
 235                (destructuring-bind (operator &rest args) form
 236                  (case operator
 237                    ;; The QUOTE special operator is worth handling: very
 238                    ;; easy and very common at toplevel.
 239                    ((quote)
 240                     (fopcompile-constant (second form) for-value-p))
 241                    ;; A FUNCTION needs to be compiled properly, but doesn't
 242                    ;; need to prevent the fopcompilation of the whole form.
 243                    ;; We just compile it, and emit an instruction for pushing
 244                    ;; the function handle on the FOP stack.
 245                    ((function)
 246                     (fopcompile-function (second form) path for-value-p))
 247                    ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
 248                    ;; by a compiler-macro. Doing general compiler-macro
 249                    ;; expansion in the fopcompiler is probably not sensible,
 250                    ;; so we'll just special-case it.
 251                    ((source-location)
 252                     (if (policy *policy* (and (> space 1)
 253                                               (> space debug)))
 254                         (fopcompile-constant nil for-value-p)
 255                         (fopcompile (let ((*current-path* path))
 256                                       (make-definition-source-location))
 257                                     path
 258                                     for-value-p)))
 259                    ((if)
 260                     (fopcompile-if args path for-value-p))
 261                    ((progn)
 262                      (loop for (arg . next) on args
 263                            do (fopcompile arg
 264                                           path (if next
 265                                                    nil
 266                                                    for-value-p))))
 267                    ((setq)
 268                     (loop for (name value . next) on args by #'cddr
 269                           do (fopcompile `(set ',name ,value) path
 270                                          (if next
 271                                              nil
 272                                              for-value-p))))
 273                    ((eval-when)
 274                     (destructuring-bind (situations &body body) args
 275                       (if (or (member :execute situations)
 276                               (member 'eval situations))
 277                           (fopcompile (cons 'progn body) path for-value-p)
 278                           (fopcompile nil path for-value-p))))
 279                    ((let let*)
 280                      (fopcompile (cons 'progn (cdr args)) path for-value-p))
 281                    ;; Otherwise it must be an ordinary funcall.
 282                    (otherwise
 283                     (cond
 284                       ;; Special hack: there's already a fop for
 285                       ;; find-undeleted-package-or-lose, so use it.
 286                       ;; (We could theoretically do the same for
 287                       ;; other operations, but I don't see any good
 288                       ;; candidates in a quick read-through of
 289                       ;; src/code/fop.lisp.)
 290                       ((and (eq operator
 291                                 'sb!int:find-undeleted-package-or-lose)
 292                             (= 1 (length args))
 293                             for-value-p)
 294                        (fopcompile (first args) path t)
 295                        (sb!fasl::dump-fop 'sb!fasl::fop-package
 296                                           *compile-object*))
 297                       (t
 298                        (fopcompile-constant operator t)
 299                        (dolist (arg args)
 300                          (fopcompile arg path t))
 301                        (if for-value-p
 302                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall
 303                                               *compile-object*)
 304                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect
 305                                               *compile-object*))
 306                        (let ((n-args (length args)))
 307                          ;; stub: FOP-FUNCALL isn't going to be usable
 308                          ;; to compile more than this, since its count
 309                          ;; is a single byte. Maybe we should just punt
 310                          ;; to the ordinary compiler in that case?
 311                          (aver (<= n-args 255))
 312                          (sb!fasl::dump-byte n-args *compile-object*))))))))))
 313         (t
 314          (bug "looks unFOPCOMPILEable: ~S" form))))
 315
 316 (defun fopcompile-function (form path for-value-p)
 317   (flet ((dump-fdefinition (name)
 318            (fopcompile `(fdefinition ',name) path for-value-p)))
 319     (if (consp form)
 320         (cond
 321           ;; Lambda forms are compiled with the real compiler
 322           ((lambda-form-p form)
 323            ;; We wrap the real lambda inside another one to ensure
 324            ;; that the compiler doesn't e.g. let convert it, thinking
 325            ;; that there are no external references.
 326            (let* ((handle (%compile `(lambda () ,form)
 327                                     *compile-object*
 328                                     :path path)))
 329              (when for-value-p
 330                (sb!fasl::dump-push handle *compile-object*)
 331                ;; And then call the wrapper function when loading the FASL
 332                (sb!fasl::dump-fop 'sb!fasl::fop-funcall *compile-object*)
 333                (sb!fasl::dump-byte 0 *compile-object*))))
 334           ;; While function names are translated to a call to FDEFINITION.
 335           ((legal-fun-name-p form)
 336            (dump-fdefinition form))
 337           (t
 338            (compiler-error "~S is not a legal function name." form)))
 339         (dump-fdefinition form))))
 340
 341 (defun fopcompile-if (args path for-value-p)
 342   (destructuring-bind (condition then &optional else)
 343       args
 344     (let ((else-label (incf *fopcompile-label-counter*))
 345           (end-label (incf *fopcompile-label-counter*)))
 346       (sb!fasl::dump-integer else-label *compile-object*)
 347       (fopcompile condition path t)
 348       ;; If condition was false, skip to the ELSE
 349       (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*)
 350       (fopcompile then path for-value-p)
 351       ;; The THEN branch will have produced a value even if we were
 352       ;; currently skipping to the ELSE branch (or over this whole
 353       ;; IF). This is done to ensure that the stack effects are
 354       ;; balanced properly when dealing with operations that are
 355       ;; executed even when skipping over code. But this particular
 356       ;; value will be bogus, so we drop it.
 357       (when for-value-p
 358         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
 359       ;; Now skip to the END
 360       (sb!fasl::dump-integer end-label *compile-object*)
 361       (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*)
 362       ;; Start of the ELSE branch
 363       (sb!fasl::dump-integer else-label *compile-object*)
 364       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
 365       (fopcompile else path for-value-p)
 366       ;; As before
 367       (when for-value-p
 368         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
 369       ;; End of IF
 370       (sb!fasl::dump-integer end-label *compile-object*)
 371       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
 372       ;; If we're still skipping, we must've triggered both of the
 373       ;; drop-if-skipping fops. To keep the stack balanced, push a
 374       ;; dummy value if needed.
 375       (when for-value-p
 376         (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping
 377                            *compile-object*)))))
 378
 379 (defun fopcompile-constant (form for-value-p)
 380   (when for-value-p
 381     ;; FIXME: Without this binding the dumper chokes on unvalidated
 382     ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
 383     ;; about to be dumped, not its load-form. Compare and contrast
 384     ;; with EMIT-MAKE-LOAD-FORM.
 385     (let ((sb!fasl::*dump-only-valid-structures* nil))
 386       (dump-object form *compile-object*))))