src/compiler/ltv.lisp

   1 ;;;; This file implements LOAD-TIME-VALUE.
   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 (defknown %load-time-value (t) t (flushable movable))
  15
  16 ;;; Compile FORM and arrange for it to be called at load-time. Return
  17 ;;; the dumper handle and our best guess at the type of the object.
  18 ;;; It would be nice if L-T-V forms were generally eligible
  19 ;;; for fopcompilation, as it could eliminate special cases below.
  20 (defun compile-load-time-value (form &optional no-skip)
  21   (acond ((typecase form
  22             ;; This case is important for dumping packages as constants
  23             ;; in cold-init, but works fine in the normal target too.
  24             ((cons (eql find-package) (cons string null)) 'package)
  25             ;; Another similar case - this allows the printer to work
  26             ;; immediately in cold-init. (See SETUP-PRINTER-STATE.)
  27             ((cons (eql function)
  28                    (cons (satisfies sb!int:legal-fun-name-p) null))
  29              'function)
  30             ;; Case(s) that should only happen in the cross-compiler.
  31             #+sb-xc-host
  32             ((or (cons (eql vector) (cons (cons (eql !specifier-type))))
  33                  (cons (eql !specifier-type)))
  34              'ctype)
  35             ;; We want to construct cold classoid cells, but in general
  36             ;; FIND-CLASSOID-CELL could be called with :CREATE NIL
  37             ;; which can not be handled in cold-load.
  38             #+sb-xc-host
  39             ((cons (eql find-classoid-cell) (cons (cons (eql quote))))
  40              (aver (eq (getf (cddr form) :create) t))
  41              'sb!kernel::classoid-cell))
  42           (fopcompile form nil t)
  43           (values (sb!fasl::dump-pop *compile-object*) (specifier-type it)))
  44          (t
  45           (let ((lambda (compile-load-time-stuff form t)))
  46             (values (fasl-dump-load-time-value-lambda lambda *compile-object*
  47                                                       no-skip)
  48                     (let ((type (leaf-type lambda)))
  49                       (if (fun-type-p type)
  50                           (single-value-type (fun-type-returns type))
  51                           *wild-type*)))))))
  52
  53 (def-ir1-translator load-time-value
  54     ((form &optional read-only-p) start next result)
  55   "Arrange for FORM to be evaluated at load-time and use the value produced as
  56 if it were a constant. If READ-ONLY-P is non-NIL, then the resultant object is
  57 guaranteed to never be modified, so it can be put in read-only storage."
  58   (let ((*allow-instrumenting* nil)
  59         ;; First derive an approximate type from the source form, because it allows
  60         ;; us to use READ-ONLY-P implicitly.
  61         ;;
  62         ;; We also use this type to augment whatever COMPILE-LOAD-TIME-VALUE
  63         ;; returns -- in practice it returns *WILD-TYPE* all the time, but
  64         ;; theoretically it could return something useful for the READ-ONLY-P case.
  65         (source-type (single-value-type
  66                       (cond ((consp form)
  67                              (let ((op (car form)))
  68                                (cond ((member op '(the truly-the))
  69                                       (values-specifier-type (second form)))
  70                                      ((eq 'function op)
  71                                       (specifier-type 'function))
  72                                      ((and (legal-fun-name-p op)
  73                                            (eq :declared (info :function :where-from op)))
  74                                       (let ((ftype (proclaimed-ftype op)))
  75                                         (if (fun-type-p ftype)
  76                                             (fun-type-returns ftype)
  77                                             *wild-type*)))
  78                                      (t
  79                                       *wild-type*))))
  80                             ((and (symbolp form)
  81                                   (eq :declared (info :variable :where-from form)))
  82                              (info :variable :type form))
  83                             ((constantp form)
  84                              (ctype-of (eval form)))
  85                             (t
  86                              *universal-type*)))))
  87     ;; Implictly READ-ONLY-P for immutable objects.
  88     (when (and (not read-only-p)
  89                (csubtypep source-type (specifier-type '(or character number))))
  90       (setf read-only-p t))
  91     (if (producing-fasl-file)
  92         (multiple-value-bind (handle type)
  93             (compile-load-time-value
  94              ;; KLUDGE: purify on cheneygc moves everything in code
  95              ;; constants into read-only space, value-cell breaks the
  96              ;; chain.
  97              (cond #!-gencgc
  98                    ((not read-only-p)
  99                     `(make-value-cell ,form))
 100                    (t
 101                     form)))
 102           (unless (csubtypep type source-type)
 103             (setf type source-type))
 104           (let ((value-form
 105                   (cond #!-gencgc
 106                         ((not read-only-p)
 107                          `(value-cell-ref (%load-time-value ',handle)))
 108                         (t
 109                          `(%load-time-value ',handle)))))
 110             (the-in-policy type value-form **zero-typecheck-policy**
 111                            start next result)))
 112         (let ((value
 113                 (flet ((eval-it (operator thing)
 114                          (handler-case (funcall operator thing)
 115                            (error (condition)
 116                              (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
 117                                              condition)))))
 118                   (if (eq sb!ext:*evaluator-mode* :compile)
 119                       ;; This call to EVAL actually means compile+eval.
 120                       (eval-it 'eval form)
 121                       (eval-it 'funcall (compile nil `(lambda () ,form)))))))
 122           (if read-only-p
 123               (ir1-convert start next result `',value)
 124               #!-gencgc
 125               (the-in-policy (ctype-of value)
 126                              `(value-cell-ref ,(make-value-cell value))
 127                              **zero-typecheck-policy**
 128                              start next result)
 129               #!+gencgc
 130               ;; Avoid complaints about constant modification
 131               (ir1-convert start next result `(ltv-wrapper ',value)))))))
 132
 133 (defoptimizer (%load-time-value ir2-convert) ((handle) node block)
 134   (aver (constant-lvar-p handle))
 135   (let ((lvar (node-lvar node))
 136         (tn (make-load-time-value-tn (lvar-value handle)
 137                                      *universal-type*)))
 138     (move-lvar-result node block (list tn) lvar)))