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 (def-ir1-translator load-time-value
  17     ((form &optional read-only-p) start next result)
  18   #!+sb-doc
  19   "Arrange for FORM to be evaluated at load-time and use the value produced as
  20 if it were a constant. If READ-ONLY-P is non-NIL, then the resultant object is
  21 guaranteed to never be modified, so it can be put in read-only storage."
  22   (let ((*allow-instrumenting* nil)
  23         ;; First derive an approximate type from the source form, because it allows
  24         ;; us to use READ-ONLY-P implicitly.
  25         ;;
  26         ;; We also use this type to augment whatever COMPILE-LOAD-TIME-VALUE
  27         ;; returns -- in practice it returns *WILD-TYPE* all the time, but
  28         ;; theoretically it could return something useful for the READ-ONLY-P case.
  29         (source-type (single-value-type
  30                       (cond ((consp form)
  31                              (let ((op (car form)))
  32                                (cond ((member op '(the truly-the))
  33                                       (specifier-type (second form)))
  34                                      ((eq 'function op)
  35                                       (specifier-type 'function))
  36                                      ((and (legal-fun-name-p op)
  37                                            (eq :declared (info :function :where-from op)))
  38                                       (let ((ftype (info :function :type op)))
  39                                         (if (fun-type-p ftype)
  40                                             (fun-type-returns ftype)
  41                                             *wild-type*)))
  42                                      (t
  43                                       *wild-type*))))
  44                             ((and (symbolp form)
  45                                   (eq :declared (info :variable :where-from form)))
  46                              (info :variable :type form))
  47                             (t
  48                              *universal-type*)))))
  49     ;; Implictly READ-ONLY-P for immutable objects.
  50     (when (and (not read-only-p)
  51                (csubtypep source-type (specifier-type '(or character number))))
  52       (setf read-only-p t))
  53     (if (producing-fasl-file)
  54         (multiple-value-bind (handle type)
  55             ;; Value cells are allocated for non-READ-ONLY-P stop the compiler
  56             ;; from complaining about constant modification -- it seems that
  57             ;; we should be able to elide them all the time if we had a way
  58             ;; of telling the compiler that "this object isn't really a constant
  59             ;; the way you think". --NS 2009-06-28
  60             (compile-load-time-value (if read-only-p
  61                                          form
  62                                          `(make-value-cell ,form)))
  63           (when (eq *wild-type* type)
  64             (setf type source-type))
  65           (let ((value-form
  66                  (if read-only-p
  67                      `(%load-time-value ',handle)
  68                      `(value-cell-ref (%load-time-value ',handle)))))
  69             (ir1-convert start next result `(truly-the ,type ,value-form))))
  70         (let ((value
  71                (handler-case (eval form)
  72                  (error (condition)
  73                    (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
  74                                    condition)))))
  75           (ir1-convert start next result
  76                        (if read-only-p
  77                            `',value
  78                            `(truly-the ,(ctype-of value)
  79                                        (value-cell-ref
  80                                         ',(make-value-cell value)))))))))
  81
  82 (defoptimizer (%load-time-value ir2-convert) ((handle) node block)
  83   (aver (constant-lvar-p handle))
  84   (let ((lvar (node-lvar node))
  85         (tn (make-load-time-value-tn (lvar-value handle)
  86                                      *universal-type*)))
  87     (move-lvar-result node block (list tn) lvar)))