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