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                        (let ((handle (cdr (assoc form *fop-lexenv*))))
 275                          (if handle
 276                              (sb!fasl::dump-push handle
 277                                                  *compile-object*)
 278                              (progn
 279                                ;; Undefined variable. Signal a warning, and
 280                                ;; treat it as a special variable reference,
 281                                ;; like the real compiler does.
 282                                (note-undefined-reference form :variable)
 283                                (fopcompile `(symbol-value ',form)
 284                                            path
 285                                            for-value-p))))))))))
 286         ((listp form)
 287          (multiple-value-bind (macroexpansion macroexpanded-p)
 288              (macroexpand form)
 289            (if macroexpanded-p
 290                (fopcompile macroexpansion path for-value-p)
 291                (destructuring-bind (operator &rest args) form
 292                  (case operator
 293                    ;; The QUOTE special operator is worth handling: very
 294                    ;; easy and very common at toplevel.
 295                    ((quote)
 296                     (fopcompile-constant (second form) for-value-p))
 297                    ;; A FUNCTION needs to be compiled properly, but doesn't
 298                    ;; need to prevent the fopcompilation of the whole form.
 299                    ;; We just compile it, and emit an instruction for pushing
 300                    ;; the function handle on the FOP stack.
 301                    ((function)
 302                     (fopcompile-function (second form) path for-value-p))
 303                    ;; KLUDGE! SB!C:SOURCE-LOCATION calls are normally handled
 304                    ;; by a compiler-macro. Doing general compiler-macro
 305                    ;; expansion in the fopcompiler is probably not sensible,
 306                    ;; so we'll just special-case it.
 307                    ((source-location)
 308                     (if (policy *policy* (and (> space 1)
 309                                               (> space debug)))
 310                         (fopcompile-constant nil for-value-p)
 311                         (fopcompile (let ((*current-path* path))
 312                                       (make-definition-source-location))
 313                                     path
 314                                     for-value-p)))
 315                    ((if)
 316                     (fopcompile-if args path for-value-p))
 317                    ((progn)
 318                      (loop for (arg . next) on args
 319                            do (fopcompile arg
 320                                           path (if next
 321                                                    nil
 322                                                    for-value-p))))
 323                    ((setq)
 324                     (loop for (name value . next) on args by #'cddr
 325                           do (fopcompile `(set ',name ,value) path
 326                                          (if next
 327                                              nil
 328                                              for-value-p))))
 329                    ((eval-when)
 330                     (destructuring-bind (situations &body body) args
 331                       (if (or (member :execute situations)
 332                               (member 'eval situations))
 333                           (fopcompile (cons 'progn body) path for-value-p)
 334                           (fopcompile nil path for-value-p))))
 335                    ((let let*)
 336                     (let ((orig-lexenv *fop-lexenv*)
 337                           (*fop-lexenv* *fop-lexenv*))
 338                       (loop for binding in (car args)
 339                             for name = (if (consp binding)
 340                                            (first binding)
 341                                            binding)
 342                             for value = (if (consp binding)
 343                                             (second binding)
 344                                             nil)
 345                             do (let ((*fop-lexenv*
 346                                       (if (eql operator 'let)
 347                                           orig-lexenv
 348                                           *fop-lexenv*)))
 349                                  (fopcompile value path t))
 350                             do (push (cons name
 351                                            (sb!fasl::dump-pop
 352                                             *compile-object*))
 353                                      *fop-lexenv*))
 354                       (fopcompile (cons 'progn (cdr args)) path for-value-p)))
 355                    ;; Otherwise it must be an ordinary funcall.
 356                    (otherwise
 357                     (cond
 358                       ;; Special hack: there's already a fop for
 359                       ;; find-undeleted-package-or-lose, so use it.
 360                       ;; (We could theoretically do the same for
 361                       ;; other operations, but I don't see any good
 362                       ;; candidates in a quick read-through of
 363                       ;; src/code/fop.lisp.)
 364                       ((and (eq operator
 365                                 'sb!int:find-undeleted-package-or-lose)
 366                             (= 1 (length args))
 367                             for-value-p)
 368                        (fopcompile (first args) path t)
 369                        (sb!fasl::dump-fop 'sb!fasl::fop-package
 370                                           *compile-object*))
 371                       (t
 372                        (fopcompile-constant operator t)
 373                        (dolist (arg args)
 374                          (fopcompile arg path t))
 375                        (if for-value-p
 376                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall
 377                                               *compile-object*)
 378                            (sb!fasl::dump-fop 'sb!fasl::fop-funcall-for-effect
 379                                               *compile-object*))
 380                        (let ((n-args (length args)))
 381                          ;; stub: FOP-FUNCALL isn't going to be usable
 382                          ;; to compile more than this, since its count
 383                          ;; is a single byte. Maybe we should just punt
 384                          ;; to the ordinary compiler in that case?
 385                          (aver (<= n-args 255))
 386                          (sb!fasl::dump-byte n-args *compile-object*))))))))))
 387         (t
 388          (bug "looks unFOPCOMPILEable: ~S" form))))
 389
 390 (defun fopcompile-function (form path for-value-p)
 391   (flet ((dump-fdefinition (name)
 392            (fopcompile `(fdefinition ',name) path for-value-p)))
 393     (if (consp form)
 394         (cond
 395           ;; Lambda forms are compiled with the real compiler
 396           ((lambda-form-p form)
 397            (let* ((handle (%compile form
 398                                     *compile-object*
 399                                     :path path)))
 400              (when for-value-p
 401                (sb!fasl::dump-push handle *compile-object*))))
 402           ;; While function names are translated to a call to FDEFINITION.
 403           ((legal-fun-name-p form)
 404            (dump-fdefinition form))
 405           (t
 406            (compiler-error "~S is not a legal function name." form)))
 407         (dump-fdefinition form))))
 408
 409 (defun fopcompile-if (args path for-value-p)
 410   (destructuring-bind (condition then &optional else)
 411       args
 412     (let ((else-label (incf *fopcompile-label-counter*))
 413           (end-label (incf *fopcompile-label-counter*)))
 414       (sb!fasl::dump-integer else-label *compile-object*)
 415       (fopcompile condition path t)
 416       ;; If condition was false, skip to the ELSE
 417       (sb!fasl::dump-fop 'sb!fasl::fop-skip-if-false *compile-object*)
 418       (fopcompile then path for-value-p)
 419       ;; The THEN branch will have produced a value even if we were
 420       ;; currently skipping to the ELSE branch (or over this whole
 421       ;; IF). This is done to ensure that the stack effects are
 422       ;; balanced properly when dealing with operations that are
 423       ;; executed even when skipping over code. But this particular
 424       ;; value will be bogus, so we drop it.
 425       (when for-value-p
 426         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
 427       ;; Now skip to the END
 428       (sb!fasl::dump-integer end-label *compile-object*)
 429       (sb!fasl::dump-fop 'sb!fasl::fop-skip *compile-object*)
 430       ;; Start of the ELSE branch
 431       (sb!fasl::dump-integer else-label *compile-object*)
 432       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
 433       (fopcompile else path for-value-p)
 434       ;; As before
 435       (when for-value-p
 436         (sb!fasl::dump-fop 'sb!fasl::fop-drop-if-skipping *compile-object*))
 437       ;; End of IF
 438       (sb!fasl::dump-integer end-label *compile-object*)
 439       (sb!fasl::dump-fop 'sb!fasl::fop-maybe-stop-skipping *compile-object*)
 440       ;; If we're still skipping, we must've triggered both of the
 441       ;; drop-if-skipping fops. To keep the stack balanced, push a
 442       ;; dummy value if needed.
 443       (when for-value-p
 444         (sb!fasl::dump-fop 'sb!fasl::fop-push-nil-if-skipping
 445                            *compile-object*)))))
 446
 447 (defun fopcompile-constant (form for-value-p)
 448   (when for-value-p
 449     ;; FIXME: Without this binding the dumper chokes on unvalidated
 450     ;; structures: CONSTANT-FOPCOMPILABLE-P validates the structure
 451     ;; about to be dumped, not its load-form. Compare and contrast
 452     ;; with EMIT-MAKE-LOAD-FORM.
 453     (let ((sb!fasl::*dump-only-valid-structures* nil))
 454       (dump-object form *compile-object*))))