mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-05 00:40:48 -08:00
Code Issues Projects Releases Packages Wiki Activity

Cache results from upgraded-array-element-type

Browse source
This commit is contained in:
jjgarcia 2008-05-29 06:49:28 +00:00
parent 2aa5b07910
commit d03680f014
1 changed files with 19 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

27
src/lsp/predlib.lsp
View file

@ -16,9 +16,12 @@
(defvar *subtypep-cache* (si:make-vector t 256 nil nil nil 0))
(defvar *upgraded-array-element-type-cache* (si:make-vector t 128 nil nil nil 0))
(defun subtypep-clear-cache ()
(and (fboundp 'fill)
(fill *subtypep-cache* nil)))
(when (fboundp 'fill)
(fill *subtypep-cache* nil)
(fill *upgraded-array-element-type-cache* nil)))
(defun create-type-name (name)
(when (member name *alien-declarations*)
@ -263,11 +266,19 @@ has no fill-pointer, and is not adjustable."
'(NIL BASE-CHAR #+unicode CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
(defun upgraded-array-element-type (element-type &optional env)
(if (member element-type +upgraded-array-element-types+ :test #'eq)
element-type
(dolist (v +upgraded-array-element-types+ 'T)
(when (subtypep element-type v)
(return v)))))
(let* ((hash (logand 127 (si:hash-eql element-type)))
(record (aref *upgraded-array-element-type-cache* hash)))
(declare (type (integer 0 127) hash))
(if (and record (eq (car record) element-type))
(cdr record)
(let ((answer (or (member element-type +upgraded-array-element-types+
:test #'eq)
(dolist (v +upgraded-array-element-types+ 'T)
(when (subtypep element-type v)
(return v))))))
(setf (aref *upgraded-array-element-type-cache* hash)
(cons element-type answer))
answer))))
(defun upgraded-complex-part-type (real-type &optional env)
;; ECL does not have specialized complex types. If we had them, the
@ -1235,7 +1246,7 @@ if not possible."
;; Another easy case: types are classes.
(when (and (instancep t1) (instancep t2)
(clos::classp t1) (clos::classp t2))
(return-from subtypep (subclassp t1 t2) t))
(return-from subtypep (values (subclassp t1 t2) t)))
;; Finally, cached results.
(let* ((cache *subtypep-cache*)
(hash (logand (hash-eql t1 t2) 255))