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 (file-comment
  15   "$Header$")
  16
  17 (defknown %load-time-value (t) t (flushable movable))
  18
  19 (def-ir1-translator load-time-value ((form &optional read-only-p) start cont)
  20   #!+sb-doc
  21   "Arrange for FORM to be evaluated at load-time and use the value produced
  22    as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant
  23    object is guaranteed to never be modified, so it can be put in read-only
  24    storage."
  25   (if (producing-fasl-file)
  26       (multiple-value-bind (handle type)
  27           (compile-load-time-value (if read-only-p
  28                                        form
  29                                        `(make-value-cell ,form)))
  30         (declare (ignore type))
  31         (ir1-convert start cont
  32                      (if read-only-p
  33                          `(%load-time-value ',handle)
  34                          `(value-cell-ref (%load-time-value ',handle)))))
  35       (let ((value
  36              (handler-case (eval form)
  37                (error (condition)
  38                  (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
  39                                  condition)))))
  40         (ir1-convert start cont
  41                      (if read-only-p
  42                          `',value
  43                          `(value-cell-ref ',(make-value-cell value)))))))
  44
  45 (defoptimizer (%load-time-value ir2-convert) ((handle) node block)
  46   (assert (constant-continuation-p handle))
  47   (let ((cont (node-cont node))
  48         (tn (make-load-time-value-tn (continuation-value handle)
  49                                      *universal-type*)))
  50     (move-continuation-result node block (list tn) cont)))