From d308c5cdfbd34f6e019c5cd922c9f7db2f1f3642 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 20 Nov 2023 12:08:27 +0100 Subject: [PATCH] cmp: object-type: do not depend on an exact type name 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. --- src/cmp/cmptype-arith.lsp | 40 ++++++++++++++++++++++----------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 45d000868..6172a2cc1 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -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