Ticket #73: cache-normalized-types.patch

File cache-normalized-types.patch, 11.2 KB (added by ehuelsmann, 9 years ago)

Normaziled types caching patch

  • boot.lisp

     
    174174(load-system-file "proclaim")
    175175(load-system-file "arrays")
    176176(load-system-file "compiler-macro")
     177
     178(%make-type-cache)
     179
    177180(load-system-file "subtypep")
    178181(load-system-file "typep")
    179182(load-system-file "signal")
  • deftype.lisp

     
    5757        (push thing new-lambda-list))
    5858      (setf lambda-list (nreverse new-lambda-list))))
    5959  `(progn
     60     (%clear-type-cache)
    6061     (setf (get ',name 'deftype-definition)
    6162           #'(lambda ,lambda-list (block ,name ,@body)))
    6263     ',name))
  • early-defuns.lisp

     
    6363             :datum arg
    6464             :expected-type type)))
    6565
    66 (defun normalize-type (type)
     66(defun %normalize-type (type)
    6767  (cond ((symbolp type)
    6868         (case type
    6969           (BIT
    70             (return-from normalize-type '(integer 0 1)))
     70            (return-from %normalize-type '(integer 0 1)))
    7171           (CONS
    72             (return-from normalize-type '(cons t t)))
     72            (return-from %normalize-type '(cons t t)))
    7373           (FIXNUM
    74             (return-from normalize-type
     74            (return-from %normalize-type
    7575                         '(integer #.most-negative-fixnum #.most-positive-fixnum)))
    7676           (SIGNED-BYTE
    77             (return-from normalize-type 'integer))
     77            (return-from %normalize-type 'integer))
    7878           (UNSIGNED-BYTE
    79             (return-from normalize-type '(integer 0 *)))
     79            (return-from %normalize-type '(integer 0 *)))
    8080           (BASE-CHAR
    81             (return-from normalize-type 'character))
     81            (return-from %normalize-type 'character))
    8282           (SHORT-FLOAT
    83             (return-from normalize-type 'single-float))
     83            (return-from %normalize-type 'single-float))
    8484           (LONG-FLOAT
    85             (return-from normalize-type 'double-float))
     85            (return-from %normalize-type 'double-float))
    8686           (COMPLEX
    87             (return-from normalize-type '(complex *)))
     87            (return-from %normalize-type '(complex *)))
    8888           (ARRAY
    89             (return-from normalize-type '(array * *)))
     89            (return-from %normalize-type '(array * *)))
    9090           (SIMPLE-ARRAY
    91             (return-from normalize-type '(simple-array * *)))
     91            (return-from %normalize-type '(simple-array * *)))
    9292           (VECTOR
    93             (return-from normalize-type '(array * (*))))
     93            (return-from %normalize-type '(array * (*))))
    9494           (SIMPLE-VECTOR
    95             (return-from normalize-type '(simple-array t (*))))
     95            (return-from %normalize-type '(simple-array t (*))))
    9696           (BIT-VECTOR
    97             (return-from normalize-type '(bit-vector *)))
     97            (return-from %normalize-type '(bit-vector *)))
    9898           (SIMPLE-BIT-VECTOR
    99             (return-from normalize-type '(simple-bit-vector *)))
     99            (return-from %normalize-type '(simple-bit-vector *)))
    100100           (BASE-STRING
    101             (return-from normalize-type '(array base-char (*))))
     101            (return-from %normalize-type '(array base-char (*))))
    102102           (SIMPLE-BASE-STRING
    103             (return-from normalize-type '(simple-array base-char (*))))
     103            (return-from %normalize-type '(simple-array base-char (*))))
    104104           (STRING
    105             (return-from normalize-type '(string *)))
     105            (return-from %normalize-type '(string *)))
    106106           (SIMPLE-STRING
    107             (return-from normalize-type '(simple-string *)))
     107            (return-from %normalize-type '(simple-string *)))
    108108           ((nil)
    109             (return-from normalize-type nil))
     109            (return-from %normalize-type nil))
    110110           (t
    111111            (unless (get type 'deftype-definition)
    112               (return-from normalize-type type)))))
     112              (return-from %normalize-type type)))))
    113113        ((classp type)
    114          (return-from normalize-type
     114         (return-from %normalize-type
    115115                      (if (eq (%class-name type) 'fixnum)
    116116                          '(integer #.most-negative-fixnum #.most-positive-fixnum)
    117117                          type)))
     
    119119              (memq (%car type) '(and or not eql member satisfies mod values)))
    120120         (cond ((or (equal type '(and fixnum unsigned-byte))
    121121                    (equal type '(and unsigned-byte fixnum)))
    122                 (return-from normalize-type '(integer 0 #.most-positive-fixnum)))
     122                (return-from %normalize-type '(integer 0 #.most-positive-fixnum)))
    123123               (t
    124                 (return-from normalize-type type)))))
     124                (return-from %normalize-type type)))))
    125125  ;; Fall through...
    126126  (let (tp i)
    127127    (loop
     
    133133          (return)))
    134134    (case tp
    135135      (INTEGER
    136        (return-from normalize-type (if i (cons tp i) tp)))
     136       (return-from %normalize-type (if i (cons tp i) tp)))
    137137      (CONS
    138138       (let* ((len (length i))
    139139              (car-typespec (if (> len 0) (car i) t))
    140140              (cdr-typespec (if (> len 1) (cadr i) t)))
    141141         (unless (and car-typespec cdr-typespec)
    142            (return-from normalize-type nil))
     142           (return-from %normalize-type nil))
    143143         (when (eq car-typespec '*)
    144144           (setf car-typespec t))
    145145         (when (eq cdr-typespec '*)
    146146           (setf cdr-typespec t))
    147          (return-from normalize-type (cons tp (list car-typespec cdr-typespec)))))
     147         (return-from %normalize-type (cons tp (list car-typespec cdr-typespec)))))
    148148      (SIGNED-BYTE
    149149       (if (or (null i) (eq (car i) '*))
    150            (return-from normalize-type 'integer)
    151            (return-from normalize-type
     150           (return-from %normalize-type 'integer)
     151           (return-from %normalize-type
    152152                        (list 'integer
    153153                              (- (expt 2 (1- (car i))))
    154154                              (1- (expt 2 (1- (car i))))))))
    155155      (UNSIGNED-BYTE
    156156       (if (or (null i) (eq (car i) '*))
    157            (return-from normalize-type '(integer 0 *)))
    158            (return-from normalize-type (list 'integer 0 (1- (expt 2 (car i))))))
     157           (return-from %normalize-type '(integer 0 *)))
     158           (return-from %normalize-type (list 'integer 0 (1- (expt 2 (car i))))))
    159159      ((ARRAY SIMPLE-ARRAY)
    160160       (unless i
    161          (return-from normalize-type (list tp '* '*)))
     161         (return-from %normalize-type (list tp '* '*)))
    162162       (when (= (length i) 1)
    163163         (setf i (append i '(*))))
    164        (setf (car i) (normalize-type (car i)))
    165        (return-from normalize-type (cons tp i)))
     164       (setf (car i) (%normalize-type (car i)))
     165       (return-from %normalize-type (cons tp i)))
    166166      (VECTOR
    167167       (case (length i)
    168168         (0
    169           (return-from normalize-type '(array * (*))))
     169          (return-from %normalize-type '(array * (*))))
    170170         (1
    171           (setf (car i) (normalize-type (car i)))
    172           (return-from normalize-type (list 'array (car i) '(*))))
     171          (setf (car i) (%normalize-type (car i)))
     172          (return-from %normalize-type (list 'array (car i) '(*))))
    173173         (2
    174           (setf (car i) (normalize-type (car i)))
    175           (return-from normalize-type (list 'array (car i) (list (cadr i)))))
     174          (setf (car i) (%normalize-type (car i)))
     175          (return-from %normalize-type (list 'array (car i) (list (cadr i)))))
    176176         (t
    177177          (error "Invalid type specifier ~S." type))))
    178178      (SIMPLE-VECTOR
    179179       (case (length i)
    180180         (0
    181           (return-from normalize-type '(simple-array t (*))))
     181          (return-from %normalize-type '(simple-array t (*))))
    182182         (1
    183           (return-from normalize-type (list 'simple-array t (list (car i)))))
     183          (return-from %normalize-type (list 'simple-array t (list (car i)))))
    184184         (t
    185185          (error "Invalid type specifier ~S." type))))
    186186      (BIT-VECTOR
    187187       (case (length i)
    188188         (0
    189           (return-from normalize-type '(bit-vector *)))
     189          (return-from %normalize-type '(bit-vector *)))
    190190         (1
    191           (return-from normalize-type (list 'bit-vector (car i))))
     191          (return-from %normalize-type (list 'bit-vector (car i))))
    192192         (t
    193193          (error "Invalid type specifier ~S." type))))
    194194      (SIMPLE-BIT-VECTOR
    195195       (case (length i)
    196196         (0
    197           (return-from normalize-type '(simple-bit-vector *)))
     197          (return-from %normalize-type '(simple-bit-vector *)))
    198198         (1
    199           (return-from normalize-type (list 'simple-bit-vector (car i))))
     199          (return-from %normalize-type (list 'simple-bit-vector (car i))))
    200200         (t
    201201          (error "Invalid type specifier ~S." type))))
    202202      (BASE-STRING
    203203       (if i
    204            (return-from normalize-type (list 'array 'base-char (list (car i))))
    205            (return-from normalize-type '(array base-char (*)))))
     204           (return-from %normalize-type (list 'array 'base-char (list (car i))))
     205           (return-from %normalize-type '(array base-char (*)))))
    206206      (SIMPLE-BASE-STRING
    207207       (if i
    208            (return-from normalize-type (list 'simple-array 'base-char (list (car i))))
    209            (return-from normalize-type '(simple-array base-char (*)))))
     208           (return-from %normalize-type (list 'simple-array 'base-char (list (car i))))
     209           (return-from %normalize-type '(simple-array base-char (*)))))
    210210      (SHORT-FLOAT
    211211       (setf tp 'single-float))
    212212      (LONG-FLOAT
    213213       (setf tp 'double-float))
    214214      (COMPLEX
    215215       (cond ((null i)
    216               (return-from normalize-type '(complex *)))
     216              (return-from %normalize-type '(complex *)))
    217217             ((eq (car i) 'short-float)
    218               (return-from normalize-type '(complex single-float)))
     218              (return-from %normalize-type '(complex single-float)))
    219219             ((eq (car i) 'long-float)
    220               (return-from normalize-type '(complex double-float))))))
     220              (return-from %normalize-type '(complex double-float))))))
    221221    (if i (cons tp i) tp)))
    222222
     223(let (type-cache
     224      (calls 0)
     225      (hits 0))
     226  (defun %type-cache-stats ()
     227    (values (hash-table-count type-cache)
     228            calls hits (ignore-errors (/ hits calls))))
     229
     230  (defun %make-type-cache ()
     231    (unless type-cache
     232      (setf type-cache
     233            (make-hash-table :test #'equal
     234                             :rehash-threshold 0.5
     235                             :rehash-size 3.0))))
     236
     237  (defun %clear-type-cache ()
     238    (when type-cache
     239      (clrhash type-cache)))
     240
     241  (defun normalize-type (type)
     242    (when type-cache
     243      (incf calls)
     244      (let ((normalized-type (gethash type type-cache)))
     245        (when normalized-type
     246          (incf hits))
     247        (return-from normalize-type
     248          (or normalized-type
     249              (setf (gethash type type-cache)
     250                    (%normalize-type type))))))
     251    (%normalize-type type)))
     252
    223253(defun caaaar (list) (car (car (car (car list)))))
    224254(defun caaadr (list) (car (car (car (cdr list)))))
    225255(defun caaddr (list) (car (car (cdr (cdr list)))))