protect against read-time package-lock circumvention from LOCKED::(BAR)
[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 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                                       (values-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                             ((constantp form)
48                              (ctype-of (eval form)))
49                             (t
50                              *universal-type*)))))
51     ;; Implictly READ-ONLY-P for immutable objects.
52     (when (and (not read-only-p)
53                (csubtypep source-type (specifier-type '(or character number))))
54       (setf read-only-p t))
55     (if (producing-fasl-file)
56         (multiple-value-bind (handle type)
57             ;; Value cells are allocated for non-READ-ONLY-P stop the
58             ;; compiler from complaining about constant modification
59             ;; -- it seems that we should be able to elide them all
60             ;; the time if we had a way of telling the compiler that
61             ;; "this object isn't really a constant the way you
62             ;; think". --NS 2009-06-28
63             (compile-load-time-value (if read-only-p
64                                          form
65                                          `(make-value-cell ,form)))
66           (unless (csubtypep type source-type)
67             (setf type source-type))
68           (let ((value-form
69                   (if read-only-p
70                       `(%load-time-value ',handle)
71                       `(value-cell-ref (%load-time-value ',handle)))))
72             (the-in-policy type value-form '((type-check . 0))
73                            start next result)))
74         (let* ((value
75                  (handler-case (eval form)
76                    (error (condition)
77                      (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
78                                      condition)))))
79           (if read-only-p
80               (ir1-convert start next result `',value nil)
81               (the-in-policy (ctype-of value) `(value-cell-ref ,(make-value-cell value))
82                              '((type-check . 0))
83                              start next result))))))
84
85 (defoptimizer (%load-time-value ir2-convert) ((handle) node block)
86   (aver (constant-lvar-p handle))
87   (let ((lvar (node-lvar node))
88         (tn (make-load-time-value-tn (lvar-value handle)
89                                      *universal-type*)))
90     (move-lvar-result node block (list tn) lvar)))