mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-01 23:30:40 -08:00
Implemented an optimizer for COERCE and improved the one for TYPEP, which did not handle sequence types.
This commit is contained in:
jjgarcia
parent
d03680f014
commit
2e100452ce
2 changed files with 222 additions and 41 deletions
|
|
@ -48,21 +48,40 @@
|
|||
;; step. Otherwise the compiler macro will enter an infinite loop.
|
||||
(let* ((space (cmp-env-optimization 'space env))
|
||||
(speed (cmp-env-optimization 'speed env))
|
||||
(safety (cmp-env-optimization 'safety env))
|
||||
(orig-type type)
|
||||
aux function
|
||||
first rest)
|
||||
(declare (si::fixnum space speed))
|
||||
(cond ((not (and (constantp type) (setf type (cmp-eval type)) t))
|
||||
form)
|
||||
;; Type is not known
|
||||
((not (known-type-p type))
|
||||
form)
|
||||
;; Simple ones
|
||||
((eq type 'T) T)
|
||||
((subtypep 'T type) T)
|
||||
((eq type 'NIL) NIL)
|
||||
((eq aux 'SATISFIES)
|
||||
`(funcall #',function ,object))
|
||||
;;
|
||||
;; Detect inconsistencies in the provided type. If we run at low
|
||||
;; safety, we will simply assume the user knows what she's doing.
|
||||
((subtypep type NIL)
|
||||
(cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type)
|
||||
(if (< safety 1)
|
||||
NIL
|
||||
form))
|
||||
;;
|
||||
;; There exists a function which checks for this type?
|
||||
((setf function (get-sysprop type 'si::type-predicate))
|
||||
`(,function ,object))
|
||||
;;
|
||||
;; Similar as before, but we assume the user did not give us
|
||||
;; the right name, or gave us an equivalent type.
|
||||
((loop for (a-type . function-name) in si::+known-typep-predicates+
|
||||
when (si::type= type a-type)
|
||||
do (return `(,function-name ,object))))
|
||||
;;
|
||||
;; The following are not real functions, but are expanded by the
|
||||
;; compiler into C forms.
|
||||
((setf function (assoc type '((SINGLE-FLOAT . SINGLE-FLOAT-P)
|
||||
|
|
@ -81,6 +100,11 @@
|
|||
((and (>= space 2) (> space speed))
|
||||
form)
|
||||
;;
|
||||
;; CONS types. They must be checked _before_ sequence types. We
|
||||
;; do not produce optimized forms because they can be recursive.
|
||||
((and (consp type) (eq (first type) 'CONS))
|
||||
form)
|
||||
;;
|
||||
;; The type denotes a known class and we can check it
|
||||
#+clos
|
||||
((setf aux (find-class type nil))
|
||||
|
|
@ -94,7 +118,7 @@
|
|||
((setf rest (rest type)
|
||||
first (first type)
|
||||
function (get-sysprop first 'SI::DEFTYPE-DEFINITION))
|
||||
(expand-typep form object (apply function rest) env))
|
||||
(expand-typep form object `',(apply function rest) env))
|
||||
;;
|
||||
;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't))
|
||||
((eq first 'NOT)
|
||||
|
|
@ -155,3 +179,131 @@
|
|||
(setq ,list-var (rest ,typed-var)))
|
||||
,(when output-form `(setq ,var nil))
|
||||
,output-form)))))
|
||||
|
||||
;;;
|
||||
;;; COERCE
|
||||
;;;
|
||||
;;; Simple coercion rules are implemented using the following
|
||||
;;; templates. X is replaced by the coerced value, which can be a
|
||||
;;; lisp form. We use a LET form to avoid evaluating twice the same
|
||||
;;; form.
|
||||
;;;
|
||||
(defvar +coercion-table+
|
||||
'((float . (float x))
|
||||
(short-float . (float x 0.0s0))
|
||||
(single-float . (float x 0.0f0))
|
||||
(double-float . (float x 0.0d0))
|
||||
(long-float . (float x 0.0l0))
|
||||
(base-char . (character x))
|
||||
(character . (character x))
|
||||
(function . (si::coerce-to-function x))
|
||||
(complex .
|
||||
(let ((y x))
|
||||
(declare (:read-only y))
|
||||
(complex (realpart y) (imagpart y))))
|
||||
))
|
||||
|
||||
(defun expand-coerce (form value type env)
|
||||
(declare (si::c-local))
|
||||
;; This function is reponsible for expanding (TYPEP object type)
|
||||
;; forms into a reasonable set of system calls. When it fails to
|
||||
;; match the compiler constraints on speed and space, it simply
|
||||
;; returns the original form. Note that for successful recursion we
|
||||
;; have to output indeed the ORIGINAL FORM, not some intermediate
|
||||
;; step. Otherwise the compiler macro will enter an infinite loop.
|
||||
(let* ((space (cmp-env-optimization 'space env))
|
||||
(speed (cmp-env-optimization 'speed env))
|
||||
(safety (cmp-env-optimization 'safety env))
|
||||
(orig-type type)
|
||||
first rest)
|
||||
(cond ((not (and (constantp type) (setf type (cmp-eval type))))
|
||||
form)
|
||||
;;
|
||||
;; Trivial case
|
||||
((subtypep 't type)
|
||||
value)
|
||||
;;
|
||||
;; Detect inconsistencies in the type form.
|
||||
((subtypep type 'nil)
|
||||
(cmperror "Cannot COERCE an expression to an empty type."))
|
||||
;;
|
||||
;; No optimizations that take up too much space unless requested.
|
||||
((and (>= space 2) (> space speed))
|
||||
form)
|
||||
;;
|
||||
;; Search for a simple template above, replacing X by the value.
|
||||
((loop for (a-type . template) in +coercion-table+
|
||||
when (eq type a-type)
|
||||
do (return (subst value 'x template))))
|
||||
;;
|
||||
;; Complex types defined with DEFTYPE.
|
||||
((and (atom type)
|
||||
(get-sysprop type 'SI::DEFTYPE-DEFINITION)
|
||||
(setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION)))
|
||||
(expand-coerce form value `',(funcall function) env))
|
||||
;;
|
||||
;; CONS types are not coercible.
|
||||
((and (consp type)
|
||||
(eq (first type) 'CONS))
|
||||
form)
|
||||
;;
|
||||
;; Search for a simple template above, but now assuming the user
|
||||
;; provided a more complex form of the same value.
|
||||
((loop for (a-type . template) in +coercion-table+
|
||||
when (si::type= type a-type)
|
||||
do (return (subst value 'x template))))
|
||||
;;
|
||||
;; SEQUENCE types
|
||||
((subtypep type 'sequence)
|
||||
(multiple-value-bind (elt-type length)
|
||||
(si::closest-sequence-type type)
|
||||
(when (eq elt-type 'list)
|
||||
(setf type 'list))
|
||||
`(let ((y ,value))
|
||||
(declare (:read-only y))
|
||||
(if (typep y ',type)
|
||||
y
|
||||
(concatenate ',type y)))))
|
||||
;;
|
||||
;; There are no other atomic types to optimize
|
||||
((atom type)
|
||||
form)
|
||||
;;
|
||||
;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...)
|
||||
((progn
|
||||
(setf rest (rest type) first (first type))
|
||||
(eq first 'AND))
|
||||
`(let ((x ,value))
|
||||
,@(loop for i in rest
|
||||
collect `(setf x (coerce x ',i)))
|
||||
x))
|
||||
;;
|
||||
;; (COMPLEX whatever) types
|
||||
((and (eq first 'complex)
|
||||
(= (length rest) 1))
|
||||
`(let ((y ,value))
|
||||
(declare (:read-only y))
|
||||
(complex (coerce (realpart y) ',(first rest))
|
||||
(coerce (imagpart y) ',(first rest)))))
|
||||
;;
|
||||
;; (INTEGER * *), etc We have to signal an error if the type
|
||||
;; does not match. However, if safety settings are low, we
|
||||
;; skip this test.
|
||||
((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT
|
||||
DOUBLE-FLOAT #+long-float LONG-FLOAT
|
||||
#+short-float SHORT-FLOAT))
|
||||
(let ((unchecked (expand-coerce form value `',first env)))
|
||||
(if (< safety 1)
|
||||
default
|
||||
`(let ((x ,unchecked))
|
||||
(declare (,first x))
|
||||
(check-type x ',type "coerced value")
|
||||
x))))
|
||||
;;
|
||||
;; We did not find a suitable expansion.
|
||||
(t
|
||||
form)
|
||||
)))
|
||||
|
||||
(define-compiler-macro coerce (&whole form value type &environment env)
|
||||
(expand-coerce form value type env))
|
||||
|
|
|
|||
|
|
@ -222,44 +222,47 @@ has no fill-pointer, and is not adjustable."
|
|||
(not (array-has-fill-pointer-p x))
|
||||
(not (array-displacement x))))
|
||||
|
||||
(dolist (l '((ARRAY . ARRAYP)
|
||||
(ATOM . ATOM)
|
||||
#-unicode
|
||||
(EXTENDED-CHAR . CONSTANTLY-NIL)
|
||||
(BASE-CHAR . BASE-CHAR-P)
|
||||
(BASE-STRING . BASE-STRING-P)
|
||||
(BIT-VECTOR . BIT-VECTOR-P)
|
||||
(CHARACTER . CHARACTERP)
|
||||
(COMPILED-FUNCTION . COMPILED-FUNCTION-P)
|
||||
(COMPLEX . COMPLEXP)
|
||||
(CONS . CONSP)
|
||||
(FLOAT . FLOATP)
|
||||
(FUNCTION . FUNCTIONP)
|
||||
(HASH-TABLE . HASH-TABLE-P)
|
||||
(INTEGER . INTEGERP)
|
||||
(FIXNUM . SI::FIXNUMP)
|
||||
(KEYWORD . KEYWORDP)
|
||||
(LIST . LISTP)
|
||||
(LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
|
||||
(NIL . CONSTANTLY-NIL)
|
||||
(NULL . NULL)
|
||||
(NUMBER . NUMBERP)
|
||||
(PACKAGE . PACKAGEP)
|
||||
(RANDOM-STATE . RANDOM-STATE-P)
|
||||
(RATIONAL . RATIONALP)
|
||||
(PATHNAME . PATHNAMEP)
|
||||
(READTABLE . READTABLEP)
|
||||
(REAL . REALP)
|
||||
(SIMPLE-ARRAY . SIMPLE-ARRAY-P)
|
||||
(SIMPLE-STRING . SIMPLE-STRING-P)
|
||||
(SIMPLE-VECTOR . SIMPLE-VECTOR-P)
|
||||
(STREAM . STREAMP)
|
||||
(STRING . STRINGP)
|
||||
(STRUCTURE . SYS:STRUCTUREP)
|
||||
(SYMBOL . SYMBOLP)
|
||||
(T . CONSTANTLY-T)
|
||||
(VECTOR . VECTORP)
|
||||
))
|
||||
(eval-when (:execute :load-toplevel :compile-toplevel)
|
||||
(defconstant +known-typep-predicates+
|
||||
'((ARRAY . ARRAYP)
|
||||
(ATOM . ATOM)
|
||||
#-unicode
|
||||
(EXTENDED-CHAR . CONSTANTLY-NIL)
|
||||
(BASE-CHAR . BASE-CHAR-P)
|
||||
(BASE-STRING . BASE-STRING-P)
|
||||
(BIT-VECTOR . BIT-VECTOR-P)
|
||||
(CHARACTER . CHARACTERP)
|
||||
(COMPILED-FUNCTION . COMPILED-FUNCTION-P)
|
||||
(COMPLEX . COMPLEXP)
|
||||
(CONS . CONSP)
|
||||
(FLOAT . FLOATP)
|
||||
(FUNCTION . FUNCTIONP)
|
||||
(HASH-TABLE . HASH-TABLE-P)
|
||||
(INTEGER . INTEGERP)
|
||||
(FIXNUM . SI::FIXNUMP)
|
||||
(KEYWORD . KEYWORDP)
|
||||
(LIST . LISTP)
|
||||
(LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
|
||||
(NIL . CONSTANTLY-NIL)
|
||||
(NULL . NULL)
|
||||
(NUMBER . NUMBERP)
|
||||
(PACKAGE . PACKAGEP)
|
||||
(RANDOM-STATE . RANDOM-STATE-P)
|
||||
(RATIONAL . RATIONALP)
|
||||
(PATHNAME . PATHNAMEP)
|
||||
(READTABLE . READTABLEP)
|
||||
(REAL . REALP)
|
||||
(SIMPLE-ARRAY . SIMPLE-ARRAY-P)
|
||||
(SIMPLE-STRING . SIMPLE-STRING-P)
|
||||
(SIMPLE-VECTOR . SIMPLE-VECTOR-P)
|
||||
(STREAM . STREAMP)
|
||||
(STRING . STRINGP)
|
||||
(STRUCTURE . SYS:STRUCTUREP)
|
||||
(SYMBOL . SYMBOLP)
|
||||
(T . CONSTANTLY-T)
|
||||
(VECTOR . VECTORP))))
|
||||
|
||||
(dolist (l +known-typep-predicates+)
|
||||
(put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
|
||||
|
||||
(defconstant +upgraded-array-element-types+
|
||||
|
|
@ -271,8 +274,9 @@ has no fill-pointer, and is not adjustable."
|
|||
(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+
|
||||
(let ((answer (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))))))
|
||||
|
|
@ -1263,3 +1267,28 @@ if not possible."
|
|||
(fast-subtypep t1 t2)
|
||||
(setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
|
||||
(values test confident)))))
|
||||
|
||||
(defun fast-type= (t1 t2)
|
||||
(declare (si::c-local))
|
||||
(when (eq t1 t2)
|
||||
(return-from fast-type= (values t t)))
|
||||
(let* ((tag1 (safe-canonical-type t1))
|
||||
(tag2 (safe-canonical-type t2)))
|
||||
(cond ((and (numberp tag1) (numberp tag2))
|
||||
(values (= (safe-canonical-type t1) (safe-canonical-type t2))
|
||||
t))
|
||||
#+nil
|
||||
((null tag1)
|
||||
(error "Unknown type specifier ~S." t1))
|
||||
#+nil
|
||||
((null tag2)
|
||||
(error "Unknown type specifier ~S." t2))
|
||||
(t
|
||||
(values nil nil)))))
|
||||
|
||||
(defun type= (t1 t2)
|
||||
(let ((*highest-type-tag* *highest-type-tag*)
|
||||
(*save-types-database* t)
|
||||
(*member-types* *member-types*)
|
||||
(*elementary-types* *elementary-types*))
|
||||
(fast-type= t1 t2)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue