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

cmp: object-type: do not depend on an exact type name

Browse source 
Previously object-type first called (TYPE-OF THING) and then matched it with
exact type names. This fails when we have a more precise type, i.e

   (type-of 3)                 -> (integer 3 3)
   (eq 'fixnum '(integer 3 3)) -> nil
   =>
   (object-type 3)             -> T

and that left us with subpar optimizations down the road.
This commit is contained in:
Daniel Kochmański 2023-11-20 12:08:27 +01:00
parent 6e161b5f44
commit d308c5cdfb
1 changed files with 23 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

40
src/cmp/cmptype-arith.lsp
View file

@ -46,24 +46,30 @@
(defun member-type (type disjoint-supertypes)
(member type disjoint-supertypes :test #'subtypep))
;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
;;; (only used for saving constants?)
;;; Canonicalize the object type to a type recognized by the compiler.
;;; Depends on the implementation of TYPECASE.
(defun object-type (thing)
(let ((type (type-of thing)))
(case type
((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type)
((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
((STRING BASE-STRING BIT-VECTOR) type)
(VECTOR (list 'VECTOR (array-element-type thing)))
(ARRAY (list 'ARRAY (array-element-type thing)))
#+clos
(STANDARD-OBJECT 'STANDARD-OBJECT)
#+clos
(STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
#+sse2
((EXT:SSE-PACK EXT:INT-SSE-PACK EXT:FLOAT-SSE-PACK EXT:DOUBLE-SSE-PACK) type)
(t t))))
(typecase thing
(FIXNUM 'FIXNUM)
(SHORT-FLOAT 'SHORT-FLOAT)
(SINGLE-FLOAT 'SINGLE-FLOAT)
(DOUBLE-FLOAT 'DOUBLE-FLOAT)
(LONG-FLOAT 'LONG-FLOAT)
(SYMBOL 'SYMBOL)
(NULL 'NULL)
((OR BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
(BASE-STRING 'BASE-STRING)
(STRING 'STRING)
(BIT-VECTOR 'BIT-VECTOR)
(VECTOR (list 'VECTOR (array-element-type thing)))
(ARRAY (list 'ARRAY (array-element-type thing)))
#+clos (STANDARD-OBJECT 'STANDARD-OBJECT)
#+clos (STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
#+sse2 (EXT:SSE-PACK 'EXT:SSE-PACK)
#+sse2 (EXT:INT-SSE-PACK 'EXT:INT-SSE-PACK)
#+sse2 (EXT:FLOAT-SSE-PACK 'EXT:FLOAT-SSE-PACK)
#+sse2 (EXT:DOUBLE-SSE-PACK 'EXT:DOUBLE-SSE-PACK)
(t t)))
(defun valid-type-specifier (type)
(handler-case