Ticket #73: cache-normalized-types.patch

boot.lisp

@@ -174 +174 @@
 (load-system-file "proclaim")
 (load-system-file "arrays")
 (load-system-file "compiler-macro")
+
+(%make-type-cache)
+
 (load-system-file "subtypep")
 (load-system-file "typep")
 (load-system-file "signal")

deftype.lisp

@@ -57 +57 @@
         (push thing new-lambda-list))
       (setf lambda-list (nreverse new-lambda-list))))
   `(progn
+     (%clear-type-cache)
      (setf (get ',name 'deftype-definition)
            #'(lambda ,lambda-list (block ,name ,@body)))
      ',name))

early-defuns.lisp

@@ -63 +63 @@
              :datum arg
              :expected-type type)))
 
-(defun normalize-type (type)
+(defun %normalize-type (type)
   (cond ((symbolp type)
          (case type
            (BIT
-            (return-from normalize-type '(integer 0 1)))
+            (return-from %normalize-type '(integer 0 1)))
            (CONS
-            (return-from normalize-type '(cons t t)))
+            (return-from %normalize-type '(cons t t)))
            (FIXNUM
-            (return-from normalize-type
+            (return-from %normalize-type
                          '(integer #.most-negative-fixnum #.most-positive-fixnum)))
            (SIGNED-BYTE
-            (return-from normalize-type 'integer))
+            (return-from %normalize-type 'integer))
            (UNSIGNED-BYTE
-            (return-from normalize-type '(integer 0 *)))
+            (return-from %normalize-type '(integer 0 *)))
            (BASE-CHAR
-            (return-from normalize-type 'character))
+            (return-from %normalize-type 'character))
            (SHORT-FLOAT
-            (return-from normalize-type 'single-float))
+            (return-from %normalize-type 'single-float))
            (LONG-FLOAT
-            (return-from normalize-type 'double-float))
+            (return-from %normalize-type 'double-float))
            (COMPLEX
-            (return-from normalize-type '(complex *)))
+            (return-from %normalize-type '(complex *)))
            (ARRAY
-            (return-from normalize-type '(array * *)))
+            (return-from %normalize-type '(array * *)))
            (SIMPLE-ARRAY
-            (return-from normalize-type '(simple-array * *)))
+            (return-from %normalize-type '(simple-array * *)))
            (VECTOR
-            (return-from normalize-type '(array * (*))))
+            (return-from %normalize-type '(array * (*))))
            (SIMPLE-VECTOR
-            (return-from normalize-type '(simple-array t (*))))
+            (return-from %normalize-type '(simple-array t (*))))
            (BIT-VECTOR
-            (return-from normalize-type '(bit-vector *)))
+            (return-from %normalize-type '(bit-vector *)))
            (SIMPLE-BIT-VECTOR
-            (return-from normalize-type '(simple-bit-vector *)))
+            (return-from %normalize-type '(simple-bit-vector *)))
            (BASE-STRING
-            (return-from normalize-type '(array base-char (*))))
+            (return-from %normalize-type '(array base-char (*))))
            (SIMPLE-BASE-STRING
-            (return-from normalize-type '(simple-array base-char (*))))
+            (return-from %normalize-type '(simple-array base-char (*))))
            (STRING
-            (return-from normalize-type '(string *)))
+            (return-from %normalize-type '(string *)))
            (SIMPLE-STRING
-            (return-from normalize-type '(simple-string *)))
+            (return-from %normalize-type '(simple-string *)))
            ((nil)
-            (return-from normalize-type nil))
+            (return-from %normalize-type nil))
            (t
             (unless (get type 'deftype-definition)
-              (return-from normalize-type type)))))
+              (return-from %normalize-type type)))))
         ((classp type)
-         (return-from normalize-type
+         (return-from %normalize-type
                       (if (eq (%class-name type) 'fixnum)
                           '(integer #.most-negative-fixnum #.most-positive-fixnum)
                           type)))
@@ -119 +119 @@
               (memq (%car type) '(and or not eql member satisfies mod values)))
          (cond ((or (equal type '(and fixnum unsigned-byte))
                     (equal type '(and unsigned-byte fixnum)))
-                (return-from normalize-type '(integer 0 #.most-positive-fixnum)))
+                (return-from %normalize-type '(integer 0 #.most-positive-fixnum)))
                (t
-                (return-from normalize-type type)))))
+                (return-from %normalize-type type)))))
   ;; Fall through...
   (let (tp i)
     (loop
@@ -133 +133 @@
           (return)))
     (case tp
       (INTEGER
-       (return-from normalize-type (if i (cons tp i) tp)))
+       (return-from %normalize-type (if i (cons tp i) tp)))
       (CONS
        (let* ((len (length i))
               (car-typespec (if (> len 0) (car i) t))
               (cdr-typespec (if (> len 1) (cadr i) t)))
          (unless (and car-typespec cdr-typespec)
-           (return-from normalize-type nil))
+           (return-from %normalize-type nil))
          (when (eq car-typespec '*)
            (setf car-typespec t))
          (when (eq cdr-typespec '*)
            (setf cdr-typespec t))
-         (return-from normalize-type (cons tp (list car-typespec cdr-typespec)))))
+         (return-from %normalize-type (cons tp (list car-typespec cdr-typespec)))))
       (SIGNED-BYTE
        (if (or (null i) (eq (car i) '*))
-           (return-from normalize-type 'integer)
-           (return-from normalize-type
+           (return-from %normalize-type 'integer)
+           (return-from %normalize-type
                         (list 'integer
                               (- (expt 2 (1- (car i))))
                               (1- (expt 2 (1- (car i))))))))
       (UNSIGNED-BYTE
        (if (or (null i) (eq (car i) '*))
-           (return-from normalize-type '(integer 0 *)))
-           (return-from normalize-type (list 'integer 0 (1- (expt 2 (car i))))))
+           (return-from %normalize-type '(integer 0 *)))
+           (return-from %normalize-type (list 'integer 0 (1- (expt 2 (car i))))))
       ((ARRAY SIMPLE-ARRAY)
        (unless i
-         (return-from normalize-type (list tp '* '*)))
+         (return-from %normalize-type (list tp '* '*)))
        (when (= (length i) 1)
          (setf i (append i '(*))))
-       (setf (car i) (normalize-type (car i)))
-       (return-from normalize-type (cons tp i)))
+       (setf (car i) (%normalize-type (car i)))
+       (return-from %normalize-type (cons tp i)))
       (VECTOR
        (case (length i)
          (0
-          (return-from normalize-type '(array * (*))))
+          (return-from %normalize-type '(array * (*))))
          (1
-          (setf (car i) (normalize-type (car i)))
-          (return-from normalize-type (list 'array (car i) '(*))))
+          (setf (car i) (%normalize-type (car i)))
+          (return-from %normalize-type (list 'array (car i) '(*))))
          (2
-          (setf (car i) (normalize-type (car i)))
-          (return-from normalize-type (list 'array (car i) (list (cadr i)))))
+          (setf (car i) (%normalize-type (car i)))
+          (return-from %normalize-type (list 'array (car i) (list (cadr i)))))
          (t
           (error "Invalid type specifier ~S." type))))
       (SIMPLE-VECTOR
        (case (length i)
          (0
-          (return-from normalize-type '(simple-array t (*))))
+          (return-from %normalize-type '(simple-array t (*))))
          (1
-          (return-from normalize-type (list 'simple-array t (list (car i)))))
+          (return-from %normalize-type (list 'simple-array t (list (car i)))))
          (t
           (error "Invalid type specifier ~S." type))))
       (BIT-VECTOR
        (case (length i)
          (0
-          (return-from normalize-type '(bit-vector *)))
+          (return-from %normalize-type '(bit-vector *)))
          (1
-          (return-from normalize-type (list 'bit-vector (car i))))
+          (return-from %normalize-type (list 'bit-vector (car i))))
          (t
           (error "Invalid type specifier ~S." type))))
       (SIMPLE-BIT-VECTOR
        (case (length i)
          (0
-          (return-from normalize-type '(simple-bit-vector *)))
+          (return-from %normalize-type '(simple-bit-vector *)))
          (1
-          (return-from normalize-type (list 'simple-bit-vector (car i))))
+          (return-from %normalize-type (list 'simple-bit-vector (car i))))
          (t
           (error "Invalid type specifier ~S." type))))
       (BASE-STRING
        (if i
-           (return-from normalize-type (list 'array 'base-char (list (car i))))
-           (return-from normalize-type '(array base-char (*)))))
+           (return-from %normalize-type (list 'array 'base-char (list (car i))))
+           (return-from %normalize-type '(array base-char (*)))))
       (SIMPLE-BASE-STRING
        (if i
-           (return-from normalize-type (list 'simple-array 'base-char (list (car i))))
-           (return-from normalize-type '(simple-array base-char (*)))))
+           (return-from %normalize-type (list 'simple-array 'base-char (list (car i))))
+           (return-from %normalize-type '(simple-array base-char (*)))))
       (SHORT-FLOAT
        (setf tp 'single-float))
       (LONG-FLOAT
        (setf tp 'double-float))
       (COMPLEX
        (cond ((null i)
-              (return-from normalize-type '(complex *)))
+              (return-from %normalize-type '(complex *)))
              ((eq (car i) 'short-float)
-              (return-from normalize-type '(complex single-float)))
+              (return-from %normalize-type '(complex single-float)))
              ((eq (car i) 'long-float)
-              (return-from normalize-type '(complex double-float))))))
+              (return-from %normalize-type '(complex double-float))))))
     (if i (cons tp i) tp)))
 
+(let (type-cache
+      (calls 0)
+      (hits 0))
+  (defun %type-cache-stats ()
+    (values (hash-table-count type-cache)
+            calls hits (ignore-errors (/ hits calls))))
+
+  (defun %make-type-cache ()
+    (unless type-cache
+      (setf type-cache
+            (make-hash-table :test #'equal
+                             :rehash-threshold 0.5
+                             :rehash-size 3.0))))
+
+  (defun %clear-type-cache ()
+    (when type-cache
+      (clrhash type-cache)))
+
+  (defun normalize-type (type)
+    (when type-cache
+      (incf calls)
+      (let ((normalized-type (gethash type type-cache)))
+        (when normalized-type
+          (incf hits))
+        (return-from normalize-type
+          (or normalized-type
+              (setf (gethash type type-cache)
+                    (%normalize-type type))))))
+    (%normalize-type type)))
+
 (defun caaaar (list) (car (car (car (car list)))))
 (defun caaadr (list) (car (car (car (cdr list)))))
 (defun caaddr (list) (car (car (cdr (cdr list)))))