Ticket #73: cachenormalizedtypes.patch
File cachenormalizedtypes.patch, 11.2 KB (added by , 9 years ago) 


boot.lisp
174 174 (loadsystemfile "proclaim") 175 175 (loadsystemfile "arrays") 176 176 (loadsystemfile "compilermacro") 177 178 (%maketypecache) 179 177 180 (loadsystemfile "subtypep") 178 181 (loadsystemfile "typep") 179 182 (loadsystemfile "signal") 
deftype.lisp
57 57 (push thing newlambdalist)) 58 58 (setf lambdalist (nreverse newlambdalist)))) 59 59 `(progn 60 (%cleartypecache) 60 61 (setf (get ',name 'deftypedefinition) 61 62 #'(lambda ,lambdalist (block ,name ,@body))) 62 63 ',name)) 
earlydefuns.lisp
63 63 :datum arg 64 64 :expectedtype type))) 65 65 66 (defun normalizetype (type)66 (defun %normalizetype (type) 67 67 (cond ((symbolp type) 68 68 (case type 69 69 (BIT 70 (returnfrom normalizetype '(integer 0 1)))70 (returnfrom %normalizetype '(integer 0 1))) 71 71 (CONS 72 (returnfrom normalizetype '(cons t t)))72 (returnfrom %normalizetype '(cons t t))) 73 73 (FIXNUM 74 (returnfrom normalizetype74 (returnfrom %normalizetype 75 75 '(integer #.mostnegativefixnum #.mostpositivefixnum))) 76 76 (SIGNEDBYTE 77 (returnfrom normalizetype 'integer))77 (returnfrom %normalizetype 'integer)) 78 78 (UNSIGNEDBYTE 79 (returnfrom normalizetype '(integer 0 *)))79 (returnfrom %normalizetype '(integer 0 *))) 80 80 (BASECHAR 81 (returnfrom normalizetype 'character))81 (returnfrom %normalizetype 'character)) 82 82 (SHORTFLOAT 83 (returnfrom normalizetype 'singlefloat))83 (returnfrom %normalizetype 'singlefloat)) 84 84 (LONGFLOAT 85 (returnfrom normalizetype 'doublefloat))85 (returnfrom %normalizetype 'doublefloat)) 86 86 (COMPLEX 87 (returnfrom normalizetype '(complex *)))87 (returnfrom %normalizetype '(complex *))) 88 88 (ARRAY 89 (returnfrom normalizetype '(array * *)))89 (returnfrom %normalizetype '(array * *))) 90 90 (SIMPLEARRAY 91 (returnfrom normalizetype '(simplearray * *)))91 (returnfrom %normalizetype '(simplearray * *))) 92 92 (VECTOR 93 (returnfrom normalizetype '(array * (*))))93 (returnfrom %normalizetype '(array * (*)))) 94 94 (SIMPLEVECTOR 95 (returnfrom normalizetype '(simplearray t (*))))95 (returnfrom %normalizetype '(simplearray t (*)))) 96 96 (BITVECTOR 97 (returnfrom normalizetype '(bitvector *)))97 (returnfrom %normalizetype '(bitvector *))) 98 98 (SIMPLEBITVECTOR 99 (returnfrom normalizetype '(simplebitvector *)))99 (returnfrom %normalizetype '(simplebitvector *))) 100 100 (BASESTRING 101 (returnfrom normalizetype '(array basechar (*))))101 (returnfrom %normalizetype '(array basechar (*)))) 102 102 (SIMPLEBASESTRING 103 (returnfrom normalizetype '(simplearray basechar (*))))103 (returnfrom %normalizetype '(simplearray basechar (*)))) 104 104 (STRING 105 (returnfrom normalizetype '(string *)))105 (returnfrom %normalizetype '(string *))) 106 106 (SIMPLESTRING 107 (returnfrom normalizetype '(simplestring *)))107 (returnfrom %normalizetype '(simplestring *))) 108 108 ((nil) 109 (returnfrom normalizetype nil))109 (returnfrom %normalizetype nil)) 110 110 (t 111 111 (unless (get type 'deftypedefinition) 112 (returnfrom normalizetype type)))))112 (returnfrom %normalizetype type))))) 113 113 ((classp type) 114 (returnfrom normalizetype114 (returnfrom %normalizetype 115 115 (if (eq (%classname type) 'fixnum) 116 116 '(integer #.mostnegativefixnum #.mostpositivefixnum) 117 117 type))) … … 119 119 (memq (%car type) '(and or not eql member satisfies mod values))) 120 120 (cond ((or (equal type '(and fixnum unsignedbyte)) 121 121 (equal type '(and unsignedbyte fixnum))) 122 (returnfrom normalizetype '(integer 0 #.mostpositivefixnum)))122 (returnfrom %normalizetype '(integer 0 #.mostpositivefixnum))) 123 123 (t 124 (returnfrom normalizetype type)))))124 (returnfrom %normalizetype type))))) 125 125 ;; Fall through... 126 126 (let (tp i) 127 127 (loop … … 133 133 (return))) 134 134 (case tp 135 135 (INTEGER 136 (returnfrom normalizetype (if i (cons tp i) tp)))136 (returnfrom %normalizetype (if i (cons tp i) tp))) 137 137 (CONS 138 138 (let* ((len (length i)) 139 139 (cartypespec (if (> len 0) (car i) t)) 140 140 (cdrtypespec (if (> len 1) (cadr i) t))) 141 141 (unless (and cartypespec cdrtypespec) 142 (returnfrom normalizetype nil))142 (returnfrom %normalizetype nil)) 143 143 (when (eq cartypespec '*) 144 144 (setf cartypespec t)) 145 145 (when (eq cdrtypespec '*) 146 146 (setf cdrtypespec t)) 147 (returnfrom normalizetype (cons tp (list cartypespec cdrtypespec)))))147 (returnfrom %normalizetype (cons tp (list cartypespec cdrtypespec))))) 148 148 (SIGNEDBYTE 149 149 (if (or (null i) (eq (car i) '*)) 150 (returnfrom normalizetype 'integer)151 (returnfrom normalizetype150 (returnfrom %normalizetype 'integer) 151 (returnfrom %normalizetype 152 152 (list 'integer 153 153 ( (expt 2 (1 (car i)))) 154 154 (1 (expt 2 (1 (car i)))))))) 155 155 (UNSIGNEDBYTE 156 156 (if (or (null i) (eq (car i) '*)) 157 (returnfrom normalizetype '(integer 0 *)))158 (returnfrom normalizetype (list 'integer 0 (1 (expt 2 (car i))))))157 (returnfrom %normalizetype '(integer 0 *))) 158 (returnfrom %normalizetype (list 'integer 0 (1 (expt 2 (car i)))))) 159 159 ((ARRAY SIMPLEARRAY) 160 160 (unless i 161 (returnfrom normalizetype (list tp '* '*)))161 (returnfrom %normalizetype (list tp '* '*))) 162 162 (when (= (length i) 1) 163 163 (setf i (append i '(*)))) 164 (setf (car i) ( normalizetype (car i)))165 (returnfrom normalizetype (cons tp i)))164 (setf (car i) (%normalizetype (car i))) 165 (returnfrom %normalizetype (cons tp i))) 166 166 (VECTOR 167 167 (case (length i) 168 168 (0 169 (returnfrom normalizetype '(array * (*))))169 (returnfrom %normalizetype '(array * (*)))) 170 170 (1 171 (setf (car i) ( normalizetype (car i)))172 (returnfrom normalizetype (list 'array (car i) '(*))))171 (setf (car i) (%normalizetype (car i))) 172 (returnfrom %normalizetype (list 'array (car i) '(*)))) 173 173 (2 174 (setf (car i) ( normalizetype (car i)))175 (returnfrom normalizetype (list 'array (car i) (list (cadr i)))))174 (setf (car i) (%normalizetype (car i))) 175 (returnfrom %normalizetype (list 'array (car i) (list (cadr i))))) 176 176 (t 177 177 (error "Invalid type specifier ~S." type)))) 178 178 (SIMPLEVECTOR 179 179 (case (length i) 180 180 (0 181 (returnfrom normalizetype '(simplearray t (*))))181 (returnfrom %normalizetype '(simplearray t (*)))) 182 182 (1 183 (returnfrom normalizetype (list 'simplearray t (list (car i)))))183 (returnfrom %normalizetype (list 'simplearray t (list (car i))))) 184 184 (t 185 185 (error "Invalid type specifier ~S." type)))) 186 186 (BITVECTOR 187 187 (case (length i) 188 188 (0 189 (returnfrom normalizetype '(bitvector *)))189 (returnfrom %normalizetype '(bitvector *))) 190 190 (1 191 (returnfrom normalizetype (list 'bitvector (car i))))191 (returnfrom %normalizetype (list 'bitvector (car i)))) 192 192 (t 193 193 (error "Invalid type specifier ~S." type)))) 194 194 (SIMPLEBITVECTOR 195 195 (case (length i) 196 196 (0 197 (returnfrom normalizetype '(simplebitvector *)))197 (returnfrom %normalizetype '(simplebitvector *))) 198 198 (1 199 (returnfrom normalizetype (list 'simplebitvector (car i))))199 (returnfrom %normalizetype (list 'simplebitvector (car i)))) 200 200 (t 201 201 (error "Invalid type specifier ~S." type)))) 202 202 (BASESTRING 203 203 (if i 204 (returnfrom normalizetype (list 'array 'basechar (list (car i))))205 (returnfrom normalizetype '(array basechar (*)))))204 (returnfrom %normalizetype (list 'array 'basechar (list (car i)))) 205 (returnfrom %normalizetype '(array basechar (*))))) 206 206 (SIMPLEBASESTRING 207 207 (if i 208 (returnfrom normalizetype (list 'simplearray 'basechar (list (car i))))209 (returnfrom normalizetype '(simplearray basechar (*)))))208 (returnfrom %normalizetype (list 'simplearray 'basechar (list (car i)))) 209 (returnfrom %normalizetype '(simplearray basechar (*))))) 210 210 (SHORTFLOAT 211 211 (setf tp 'singlefloat)) 212 212 (LONGFLOAT 213 213 (setf tp 'doublefloat)) 214 214 (COMPLEX 215 215 (cond ((null i) 216 (returnfrom normalizetype '(complex *)))216 (returnfrom %normalizetype '(complex *))) 217 217 ((eq (car i) 'shortfloat) 218 (returnfrom normalizetype '(complex singlefloat)))218 (returnfrom %normalizetype '(complex singlefloat))) 219 219 ((eq (car i) 'longfloat) 220 (returnfrom normalizetype '(complex doublefloat))))))220 (returnfrom %normalizetype '(complex doublefloat)))))) 221 221 (if i (cons tp i) tp))) 222 222 223 (let (typecache 224 (calls 0) 225 (hits 0)) 226 (defun %typecachestats () 227 (values (hashtablecount typecache) 228 calls hits (ignoreerrors (/ hits calls)))) 229 230 (defun %maketypecache () 231 (unless typecache 232 (setf typecache 233 (makehashtable :test #'equal 234 :rehashthreshold 0.5 235 :rehashsize 3.0)))) 236 237 (defun %cleartypecache () 238 (when typecache 239 (clrhash typecache))) 240 241 (defun normalizetype (type) 242 (when typecache 243 (incf calls) 244 (let ((normalizedtype (gethash type typecache))) 245 (when normalizedtype 246 (incf hits)) 247 (returnfrom normalizetype 248 (or normalizedtype 249 (setf (gethash type typecache) 250 (%normalizetype type)))))) 251 (%normalizetype type))) 252 223 253 (defun caaaar (list) (car (car (car (car list))))) 224 254 (defun caaadr (list) (car (car (car (cdr list))))) 225 255 (defun caaddr (list) (car (car (cdr (cdr list)))))