1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / 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
20    as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant
21    object is guaranteed to never be modified, so it can be put in read-only
22    storage."
23   (let ((*allow-instrumenting* nil))
24     (if (producing-fasl-file)
25         (multiple-value-bind (handle type)
26             (compile-load-time-value (if read-only-p
27                                          form
28                                          `(make-value-cell ,form)))
29           (declare (ignore type))
30           (ir1-convert start next result
31                        (if read-only-p
32                            `(%load-time-value ',handle)
33                            `(value-cell-ref (%load-time-value ',handle)))))
34         (let ((value
35                (handler-case (eval form)
36                  (error (condition)
37                    (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
38                                    condition)))))
39           (ir1-convert start next result
40                        (if read-only-p
41                            `',value
42                            `(value-cell-ref ',(make-value-cell value))))))))
43
44 (defoptimizer (%load-time-value ir2-convert) ((handle) node block)
45   (aver (constant-lvar-p handle))
46   (let ((lvar (node-lvar node))
47         (tn (make-load-time-value-tn (lvar-value handle)
48                                      *universal-type*)))
49     (move-lvar-result node block (list tn) lvar)))