From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 24 May 2011 11:02:33 +0000 (+0000)
Subject: 1.0.48.24: fix performance / type derivation regression from 1.0.48.14
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b16362cd2ab5d268ff161a805837aa271ef2fec2;p=sbcl.git

1.0.48.24: fix performance / type derivation regression from 1.0.48.14

  Since global/special variables are now always converted using
  SYMBOL-VALUE / SYMBOL-GLOBAL-VALUE, we temporarily lost type
  information for them.

  Remedy this by adding a DERIVE-TYPE optimizer for both.
---

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index b570192..83c40f6 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -57,6 +57,26 @@
       (give-up-ir1-transform
        "The function doesn't have a fixed argument count.")))))
 
+;;;; SYMBOL-VALUE &co
+(defun derive-symbol-value-type (lvar node)
+  (if (constant-lvar-p lvar)
+      (let* ((sym (lvar-value lvar))
+             (var (maybe-find-free-var sym))
+             (local-type (when var
+                           (let ((*lexenv* (node-lexenv node)))
+                             (lexenv-find var type-restrictions))))
+             (global-type (info :variable :type sym)))
+        (if local-type
+            (type-intersection local-type global-type)
+            global-type))
+      *universal-type*))
+
+(defoptimizer (symbol-value derive-type) ((symbol) node)
+  (derive-symbol-value-type symbol node))
+
+(defoptimizer (symbol-global-value derive-type) ((symbol) node)
+  (derive-symbol-value-type symbol node))
+
 ;;;; list hackery
 
 ;;; Translate CxR into CAR/CDR combos.
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 7793ab3..81c72bd 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2092,4 +2092,40 @@
                     (assert (equal "foobar" (type-error-datum e)))
                     :type-error))))))
 
+(declaim (unsigned-byte *symbol-value-test-var*))
+(defvar *symbol-value-test-var*)
+
+(declaim (unsigned-byte **global-symbol-value-test-var**))
+(defglobal **global-symbol-value-test-var** 0)
+
+(test-util:with-test (:name :symbol-value-type-derivation)
+  (let ((fun (compile
+              nil
+              `(lambda ()
+                 *symbol-value-test-var*))))
+    (assert (equal '(function () (values unsigned-byte &optional))
+                   (%simple-fun-type fun))))
+  (let ((fun (compile
+              nil
+              `(lambda ()
+                 **global-symbol-value-test-var**))))
+    (assert (equal '(function () (values unsigned-byte &optional))
+                   (%simple-fun-type fun))))
+  (let ((fun (compile
+              nil
+              `(lambda (*symbol-value-test-var*)
+                 (declare (fixnum *symbol-value-test-var*))
+                 (symbol-value '*symbol-value-test-var*))))
+        (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum)))))
+    (assert (equal `(function (,ufix) (values ,ufix &optional))
+                   (%simple-fun-type fun))))
+  (let ((fun (compile
+              nil
+              `(lambda ()
+                 (declare (fixnum **global-symbol-value-test-var**))
+                 (symbol-global-value '**global-symbol-value-test-var**))))
+        (ufix (type-specifier (specifier-type `(and unsigned-byte fixnum)))))
+    (assert (equal `(function () (values ,ufix &optional))
+                   (%simple-fun-type fun)))))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 990a447..5f395da 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.48.23"
+"1.0.48.24"