src/compiler/fopcompile.lisp

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