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 (cdr 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                          (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))))
 204                         (:ignore-it)
 205                         (t
 206                          (return-from constant-fopcompilable-p nil)))))
 207                    (t
 208                     (return-from constant-fopcompilable-p nil))))))
 209       (grovel constant))
 210     t))
 211
 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))
 218         ((symbolp form)
 219          (multiple-value-bind (macroexpansion macroexpanded-p)
 220              (macroexpand form)
 221            (if macroexpanded-p
 222                ;; Symbol macro
 223                (fopcompile macroexpansion path for-value-p)
 224                ;; Special variable
 225                (fopcompile `(symbol-value ',form) path for-value-p))))
 226         ((listp form)
 227          (multiple-value-bind (macroexpansion macroexpanded-p)
 228              (macroexpand form)
 229            (if macroexpanded-p
 230                (fopcompile macroexpansion path for-value-p)
 231                (destructuring-bind (operator &rest args) form
 232                  (case operator
 233                    ;; The QUOTE special operator is worth handling: very
 234                    ;; easy and very common at toplevel.
 235                    ((quote)
 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.
 241                    ((function)
 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.
 247                    ((source-location)
 248                     (if (policy *policy* (and (> space 1)
 249                                               (> space debug)))
 250                         (fopcompile-constant nil for-value-p)
 251                         (fopcompile (let ((*current-path* path))
 252                                       (make-definition-source-location))
 253                                     path
 254                                     for-value-p)))
 255                    ((if)
 256                     (fopcompile-if args path for-value-p))
 257                    ((progn)
 258                      (loop for (arg . next) on args
 259                            do (fopcompile arg
 260                                           path (if next
 261                                                    nil
 262                                                    for-value-p))))
 263                    ((setq)
 264                     (loop for (name value . next) on args by #'cddr
 265                           do (fopcompile `(set ',name ,value) path
 266                                          (if next
 267                                              nil
 268                                              for-value-p))))
 269                    ((eval-when)
 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))))
 275                    ((let let*)
 276                      (fopcompile (cons 'progn (cdr args)) path for-value-p))
 277                    ;; Otherwise it must be an ordinary funcall.
 278                    (otherwise
 279                     (fopcompile-constant operator t)
 280                     (dolist (arg args)
 281                       (fopcompile arg path t))
 282                     (if for-value-p
 283                         (sb!fasl::dump-fop 'sb!fasl::fop-funcall
 284                                            *compile-object*)
 285                         (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect
 286                                            *compile-object*))
 287                     (let ((n-args (length args)))
 288                       ;; stub: FOP-FUNCALL isn't going to be usable
 289                       ;; to compile more than this, since its count
 290                       ;; is a single byte. Maybe we should just punt
 291                       ;; to the ordinary compiler in that case?
 292                       (aver (<= n-args 255))
 293                       (sb!fasl::dump-byte n-args *compile-object*))))))))
 294         (t
 295          (bug "looks unFOPCOMPILEable: ~S" form))))
 296
 297 (defun fopcompile-function (form path for-value-p)
 298   (flet ((dump-fdefinition (name)
 299            (fopcompile `(fdefinition ',name) path for-value-p)))
 300     (if (consp form)
 301         (cond
 302           ;; Lambda forms are compiled with the real compiler
 303           ((lambda-form-p form)
 304            ;; We wrap the real lambda inside another one to ensure
 305            ;; that the compiler doesn't e.g. let convert it, thinking
 306            ;; that there are no external references.
 307            (let* ((handle (%compile `(lambda () ,form)
 308                                     *compile-object*
 309                                     :path path)))
 310              (when for-value-p
 311                (sb!fasl::dump-push handle *compile-object*)
 312                ;; And then call the wrapper function when loading the FASL
 313                (sb!fasl::dump-fop 'sb!fasl::fop-funcall *compile-object*)
 314                (sb!fasl::dump-byte 0 *compile-object*))))
 315           ;; While function names are translated to a call to FDEFINITION.
 316           ((legal-fun-name-p form)
 317            (dump-fdefinition form))
 318           (t
 319            (compiler-error "~S is not a legal function name." form)))
 320         (dump-fdefinition form))))
 321
 322 (defun fopcompile-if (args path for-value-p)
 323   (destructuring-bind (condition then &optional else)
 324       args
 325     (let ((else-label (incf *fopcompile-label-counter*))
 326           (end-label (incf *fopcompile-label-counter*)))
 327       (sb!fasl::dump-integer else-label *compile-object*)
 328       (fopcompile condition path t)
 329       ;; If condition was false, skip to the ELSE
 330       (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*)
 331       (fopcompile then path for-value-p)
 332       ;; The THEN branch will have produced a value even if we were
 333       ;; currently skipping to the ELSE branch (or over this whole
 334       ;; IF). This is done to ensure that the stack effects are
 335       ;; balanced properly when dealing with operations that are
 336       ;; executed even when skipping over code. But this particular
 337       ;; value will be bogus, so we drop it.
 338       (when for-value-p
 339         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
 340       ;; Now skip to the END
 341       (sb!fasl::dump-integer end-label *compile-object*)
 342       (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*)
 343       ;; Start of the ELSE branch
 344       (sb!fasl::dump-integer else-label *compile-object*)
 345       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
 346       (fopcompile else path for-value-p)
 347       ;; As before
 348       (when for-value-p
 349         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
 350       ;; End of IF
 351       (sb!fasl::dump-integer end-label *compile-object*)
 352       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
 353       ;; If we're still skipping, we must've triggered both of the
 354       ;; drop-if-skipping fops. To keep the stack balanced, push a
 355       ;; dummy value if needed.
 356       (when for-value-p
 357         (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping
 358                            *compile-object*)))))
 359
 360 (defun fopcompile-constant (form for-value-p)
 361   (when for-value-p
 362     (let ((sb!fasl::*dump-only-valid-structures* nil))
 363       (dump-object form *compile-object*))))