X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltv.lisp;h=e733b154ade6c0973db147b3436a65f0ef6af31a;hb=HEAD;hp=9ed48c8743a07206013ffd7327bc954e8bb759b4;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/ltv.lisp b/src/compiler/ltv.lisp
index 9ed48c8..e733b15 100644
--- a/src/compiler/ltv.lisp
+++ b/src/compiler/ltv.lisp
@@ -16,33 +16,75 @@
 (def-ir1-translator load-time-value
     ((form &optional read-only-p) start next result)
   #!+sb-doc
-  "Arrange for FORM to be evaluated at load-time and use the value produced
-   as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant
-   object is guaranteed to never be modified, so it can be put in read-only
-   storage."
-  (if (producing-fasl-file)
-      (multiple-value-bind (handle type)
-	  (compile-load-time-value (if read-only-p
-				       form
-				       `(make-value-cell ,form)))
-	(declare (ignore type))
-	(ir1-convert start next result
-		     (if read-only-p
-			 `(%load-time-value ',handle)
-			 `(value-cell-ref (%load-time-value ',handle)))))
-      (let ((value
-	     (handler-case (eval form)
-	       (error (condition)
-		 (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
-				 condition)))))
-	(ir1-convert start next result
-		     (if read-only-p
-			 `',value
-			 `(value-cell-ref ',(make-value-cell value)))))))
+  "Arrange for FORM to be evaluated at load-time and use the value produced as
+if it were a constant. If READ-ONLY-P is non-NIL, then the resultant object is
+guaranteed to never be modified, so it can be put in read-only storage."
+  (let ((*allow-instrumenting* nil)
+        ;; First derive an approximate type from the source form, because it allows
+        ;; us to use READ-ONLY-P implicitly.
+        ;;
+        ;; We also use this type to augment whatever COMPILE-LOAD-TIME-VALUE
+        ;; returns -- in practice it returns *WILD-TYPE* all the time, but
+        ;; theoretically it could return something useful for the READ-ONLY-P case.
+        (source-type (single-value-type
+                      (cond ((consp form)
+                             (let ((op (car form)))
+                               (cond ((member op '(the truly-the))
+                                      (values-specifier-type (second form)))
+                                     ((eq 'function op)
+                                      (specifier-type 'function))
+                                     ((and (legal-fun-name-p op)
+                                           (eq :declared (info :function :where-from op)))
+                                      (let ((ftype (info :function :type op)))
+                                        (if (fun-type-p ftype)
+                                            (fun-type-returns ftype)
+                                            *wild-type*)))
+                                     (t
+                                      *wild-type*))))
+                            ((and (symbolp form)
+                                  (eq :declared (info :variable :where-from form)))
+                             (info :variable :type form))
+                            ((constantp form)
+                             (ctype-of (eval form)))
+                            (t
+                             *universal-type*)))))
+    ;; Implictly READ-ONLY-P for immutable objects.
+    (when (and (not read-only-p)
+               (csubtypep source-type (specifier-type '(or character number))))
+      (setf read-only-p t))
+    (if (producing-fasl-file)
+        (multiple-value-bind (handle type)
+            ;; Value cells are allocated for non-READ-ONLY-P stop the
+            ;; compiler from complaining about constant modification
+            ;; -- it seems that we should be able to elide them all
+            ;; the time if we had a way of telling the compiler that
+            ;; "this object isn't really a constant the way you
+            ;; think". --NS 2009-06-28
+            (compile-load-time-value (if read-only-p
+                                         form
+                                         `(make-value-cell ,form)))
+          (unless (csubtypep type source-type)
+            (setf type source-type))
+          (let ((value-form
+                  (if read-only-p
+                      `(%load-time-value ',handle)
+                      `(value-cell-ref (%load-time-value ',handle)))))
+            (the-in-policy type value-form '((type-check . 0))
+                           start next result)))
+        (let* ((value
+                 (handler-case (eval form)
+                   (error (condition)
+                     (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
+                                     condition)))))
+          (if read-only-p
+              (ir1-convert start next result `',value nil)
+              (the-in-policy (ctype-of value) `(value-cell-ref ,(make-value-cell value))
+                             '((type-check . 0))
+                             start next result))))))
 
 (defoptimizer (%load-time-value ir2-convert) ((handle) node block)
   (aver (constant-lvar-p handle))
   (let ((lvar (node-lvar node))
-	(tn (make-load-time-value-tn (lvar-value handle)
-				     *universal-type*)))
+        (tn (make-load-time-value-tn (lvar-value handle)
+                                     *universal-type*)))
     (move-lvar-result node block (list tn) lvar)))