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

cmp: allow for storing type definitions in the compiler environment

Browse source 
Currently unused; will be used in the implementation of
cross-compilation.
This commit is contained in:
Marius Gerbershagen 2021-04-11 19:17:52 +02:00
parent a213b4eaa1
commit a1b1eee8b5
23 changed files with 177 additions and 136 deletions
Download patch file Download diff file Expand all files Collapse all files

5
src/c/compiler.d
View file

@ -421,6 +421,7 @@ c_register_captured(cl_env_ptr env, cl_object c)
* SI:FUNCTION-BOUNDARY |
* SI:UNWIND-PROTECT-BOUNDARY
* (:declare declaration-arguments*)
* (:type type-name [type-definition | expansion-function])
* macro-record =
* (function-name FUNCTION [| function-object]) |
* (macro-name si::macro macro-function) |
@ -948,7 +949,7 @@ c_var_ref(cl_env_ptr env, cl_object var, bool allow_sym_mac, bool ensure_def)
type = pop(&reg);
special = pop(&reg);
if (type == @':block' || type == @':tag' || type == @':function'
|| type == @':declare' || type != var) {
|| type == @':declare' || type == @':type' || type != var) {
continue;
} else if (Null(special)) {
if (function_boundary_crossed) {
@ -1098,7 +1099,7 @@ c_undo_bindings(cl_env_ptr the_env, cl_object old_vars, int only_specials)
if (!only_specials) num_lexical++;
} else if (name == @':function' || Null(special)) {
if (!only_specials) num_lexical++;
} else if (name == @':declare') {
} else if (name == @':declare' || name == @':type') {
/* Ignored */
} else if (special != @'si::symbol-macro') {
/* If (third special) = NIL, the variable was declared

8
src/cmp/cmparray.lsp
View file

@ -17,7 +17,7 @@
(defun guess-array-element-type (element-type)
(if (and (setf element-type (extract-constant-value element-type))
(known-type-p element-type))
(upgraded-array-element-type element-type)
(upgraded-array-element-type element-type *cmp-env*)
'*))
(defun guess-array-dimensions-type (orig-dimensions &aux dimensions)
@ -30,13 +30,13 @@
(let ((dimensions (extract-constant-value orig-dimensions :failed)))
(cond ((eq dimensions ':failed)
'*)
((typep dimensions 'ext:array-index)
((typep dimensions 'ext:array-index *cmp-env*)
(list dimensions))
((and (listp dimensions)
(let ((rank (list-length dimensions)))
(and (numberp rank)
(< -1 rank array-rank-limit)
(every #'(lambda (x) (typep x 'ext:array-index)) dimensions)
(every #'(lambda (x) (typep x 'ext:array-index *cmp-env*)) dimensions)
(< (apply '* dimensions) array-total-size-limit))))
dimensions)
(t
@ -255,7 +255,7 @@
`(ffi:c-inline (,array) ,@(aref tails n))))
(defmacro array-dimension-fast (array n)
(if (typep n '(integer 0 #.(1- array-rank-limit)))
(if (typep n '(integer 0 #.(1- array-rank-limit)) *cmp-env*)
(array-dimension-accessor array n)
(error "In macro ARRAY-DIMENSION-FAST, the index is not a constant integer: ~A"
n)))

18
src/cmp/cmpbackend-cxx/cmpc-fun-inl.lsp
View file

@ -83,7 +83,9 @@
((equal (inline-info-arg-types ia) (inline-info-arg-types ib))
ia)
;; More specific?
((every #'type>= (inline-info-arg-types ia) (inline-info-arg-types ib))
((every #'(lambda (t1 t2) (type>= t1 t2 *cmp-env*))
(inline-info-arg-types ia)
(inline-info-arg-types ib))
ib)
;; Keep the first one, which is typically the least safe but fastest.
(t
@ -103,7 +105,7 @@
(defun to-fixnum-float-type (type)
(dolist (i '(CL:FIXNUM CL:DOUBLE-FLOAT CL:SINGLE-FLOAT CL:LONG-FLOAT) nil)
(when (type>= i type)
(when (type>= i type *cmp-env*)
(return i))))
(defun maximum-float-type (t1 t2)
@ -140,10 +142,10 @@
(setq number-max (maximum-float-type number-max new-type))))
#+sse2
;; Allow implicit casts between SSE subtypes to kick in
((and (type>= 'ext:sse-pack type)
(type>= 'ext:sse-pack arg-type))
((and (type>= 'ext:sse-pack type *cmp-env*)
(type>= 'ext:sse-pack arg-type *cmp-env*))
(push type rts))
((type>= type arg-type)
((type>= type arg-type *cmp-env*)
(push type rts))
(t (return-from inline-type-matches nil)))))
;;
@ -163,10 +165,10 @@
(and (setf number-max (if (eq number-max 'fixnum)
'integer
number-max))
(type>= inline-return-type number-max)
(type>= number-max return-type))
(type>= inline-return-type number-max *cmp-env*)
(type>= number-max return-type *cmp-env*))
;; no contravariance
(type>= inline-return-type return-type)))))
(type>= inline-return-type return-type *cmp-env*)))))
(let ((inline-info (copy-structure inline-info)))
(setf (inline-info-arg-types inline-info)
(nreverse rts))

13
src/cmp/cmpbackend-cxx/cmpc-mach.lsp
View file

@ -30,7 +30,7 @@
(from-lisp-unsafe nil))
(defun lisp-type-p (type)
(subtypep type 'T))
(subtypep type 'T *cmp-env*))
(defun host-type-record-unsafe (host-type)
(gethash host-type (machine-host-type-hash *machine*)))
@ -57,7 +57,7 @@
(t
;; Find the most specific type that fits
(dolist (record (machine-sorted-types *machine*) :object)
(when (subtypep type (host-type-lisp-type record))
(when (subtypep type (host-type-lisp-type record) *cmp-env*)
(return-from lisp-type->host-type (host-type-name record)))))))
(defun c-number-host-type-p (host-type)
@ -191,8 +191,8 @@
:name name
:lisp-type lisp-type
:bits bits
:numberp (subtypep lisp-type 'number)
:integerp (subtypep lisp-type 'integer)
:numberp (subtypep lisp-type 'number *cmp-env*)
:integerp (subtypep lisp-type 'integer *cmp-env*)
:c-name c-name
:to-lisp to-lisp
:from-lisp from-lisp
@ -218,7 +218,7 @@
with fixnum-lisp-type = (host-type-lisp-type fixnum-host-type)
for (name . rest) in +host-types+
for r = (gethash name table)
when (and r (subtypep (host-type-lisp-type r) fixnum-lisp-type))
when (and r (subtypep (host-type-lisp-type r) fixnum-lisp-type *cmp-env*))
do (setf (host-type-from-lisp-unsafe r) "ecl_fixnum"))
;; Create machine object
(make-machine :c-types all-c-types
@ -228,7 +228,4 @@
(defun machine-c-type-p (name)
(gethash name (machine-host-type-hash *machine*)))
(defun machine-fixnump (number)
(typep number (host-type-lisp-type (gethash :fixnum number))))
(defvar *default-machine* (setf *machine* (default-machine)))

2
src/cmp/cmpbackend-cxx/cmpc-opt-printer.lsp
View file

@ -22,7 +22,7 @@
(produce-inline-loc (list expression stream)
'(:wchar :object) '(:wchar)
"ecl_princ_char(#0,#1)" t t))
((and foundp (typep value 'base-string) (< (length value) 80))
((and foundp (typep value 'base-string *cmp-env*) (< (length value) 80))
(produce-inline-loc (list expression stream)
'(:object :object) '(:object)
(concatenate 'string "(ecl_princ_str("

2
src/cmp/cmpbackend-cxx/cmppass2-call.lsp
View file

@ -110,7 +110,7 @@
(defun c2call-unknown (c1form form args)
(declare (ignore c1form))
(let* ((form-type (c1form-primary-type form))
(function-p (and (subtypep form-type 'function)
(function-p (and (subtypep form-type 'function *cmp-env*)
(policy-assume-right-type)))
(loc (emit-inline-form form args))
(args (inline-args args)))

26
src/cmp/cmpbackend-cxx/cmppass2-data.lsp
View file

@ -243,7 +243,7 @@
si:*compiler-constants*
(and (not *use-static-constants-p*)
#+sse2
(not (typep object 'ext:sse-pack)))
(not (typep object 'ext:sse-pack *cmp-env*)))
(not (listp *static-constants*)))
(ext:if-let ((record (find object *static-constants* :key #'first :test #'equal)))
(second record)
@ -263,7 +263,7 @@
(defun try-value-c-inliner (value)
(ext:when-let ((x (assoc value *optimizable-constants*)))
(when (typep value '(or float (complex float)))
(when (typep value '(or float (complex float)) *cmp-env*)
(pushnew "#include <float.h>" *clines-string-list*)
(pushnew "#include <complex.h>" *clines-string-list*))
(cdr x)))
@ -285,13 +285,13 @@
(defun try-immediate-value (value)
;; FIXME we could inline here also (COMPLEX FLOAT). That requires adding an
;; emmiter of C complex floats in the function WT1.
(typecase value
((or fixnum character float #|#+complex-float (complex float)|#)
(cond
((typep value '(or fixnum character float #|#+complex-float (complex float)|#) *cmp-env*)
(make-vv :value value
:location nil
:host-type (lisp-type->host-type (type-of value))))
#+sse2
(ext:sse-pack
((typep value 'ext:sse-pack *cmp-env*)
(let* ((bytes (ext:sse-pack-to-vector value '(unsigned-byte 8)))
(elt-type (ext:sse-pack-element-type value)))
(multiple-value-bind (wrapper rtype)
@ -303,7 +303,7 @@
:location (format nil "~A(_mm_setr_epi8(~{~A~^,~}))"
wrapper (coerce bytes 'list))
:host-type rtype))))
(otherwise
(t
nil)))
@ -394,13 +394,13 @@
(wt "VVtemp[" index "]"))))
(defun wt-vv-value (vv value)
(etypecase value
((eql CL:T) (wt "ECL_T"))
((eql CL:NIL) (wt "ECL_NIL"))
(fixnum (wt-fixnum value vv))
(character (wt-character value vv))
(float (wt-number value vv))
((complex float) (wt-number value vv))))
(cond
((eql value CL:T) (wt "ECL_T"))
((eql value CL:NIL) (wt "ECL_NIL"))
((typep value 'fixnum *cmp-env*) (wt-fixnum value vv))
((typep value 'character *cmp-env*) (wt-character value vv))
((typep value 'float *cmp-env*) (wt-number value vv))
((typep value '(complex float) *cmp-env*) (wt-number value vv))))
(defun wt-vv (vv-loc)
(setf (vv-used-p vv-loc) t)

16
src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
View file

@ -46,13 +46,13 @@
(defun c2if (c1form fmla form1 form2)
;; FIXME! Optimize when FORM1 or FORM2 are constants
(cond ((type-true-p (c1form-primary-type fmla))
(cond ((type-true-p (c1form-primary-type fmla) *cmp-env*)
;; The true branch is always taken
(warn-dead-code form2 c1form "the test ~S always evaluates to true" fmla)
(let ((*destination* 'TRASH))
(c2expr* fmla))
(c2expr form1))
((type-false-p (c1form-primary-type fmla))
((type-false-p (c1form-primary-type fmla) *cmp-env*)
;; The false branch is always taken
(warn-dead-code form1 c1form "the test ~S always evaluates to false" fmla)
(let ((*destination* 'TRASH))
@ -90,11 +90,11 @@
(defun c2fmla-not (c1form arg)
(declare (ignore c1form))
(let ((dest *destination*))
(cond ((type-true-p (c1form-primary-type arg))
(cond ((type-true-p (c1form-primary-type arg) *cmp-env*)
(let ((*destination* 'TRASH))
(c2expr* arg))
(c2expr (c1nil)))
((type-false-p (c1form-primary-type arg))
((type-false-p (c1form-primary-type arg) *cmp-env*)
(let ((*destination* 'TRASH))
(c2expr* arg))
(c2expr (c1t)))
@ -114,13 +114,13 @@
for expr in butlast
for remaining-exprs on butlast
for type = (c1form-primary-type expr)
do (cond ((type-false-p type)
do (cond ((type-false-p type *cmp-env*)
(warn-dead-code (append (rest remaining-exprs) (list last)) c1form
"the test ~S always evaluates to false" expr)
(let ((*destination* exit-dest))
(c2expr* expr))
(return-from c2expr-and-arguments))
((type-true-p type)
((type-true-p type *cmp-env*)
(let ((*destination* 'TRASH))
(c2expr* expr)))
(t
@ -141,13 +141,13 @@
for expr in butlast
for remaining-exprs on butlast
for type = (c1form-primary-type expr)
do (cond ((type-true-p type)
do (cond ((type-true-p type *cmp-env*)
(warn-dead-code (append (rest remaining-exprs) (list last)) c1form
"the test ~S always evaluates to true" expr)
(let ((*destination* 'VALUE0))
(c2expr* expr))
(return-from c2expr-or-arguments))
((type-false-p type)
((type-false-p type *cmp-env*)
(let ((*destination* 'TRASH))
(c2expr* expr)))
(t

8
src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
View file

@ -48,8 +48,8 @@
;; overflow if we use a smaller integer type (overflows in long long
;; computations are taken care of by the compiler before we get to
;; this point).
#+msvc (princ (cond ((typep value (host-type->lisp-type :long-long)) "LL")
((typep value (host-type->lisp-type :unsigned-long-long)) "ULL")
#+msvc (princ (cond ((typep value (host-type->lisp-type :long-long) *cmp-env*) "LL")
((typep value (host-type->lisp-type :unsigned-long-long) *cmp-env*) "ULL")
(t (baboon :format-control
"wt-fixnum: The number ~A doesn't fit any integer type."
value)))
@ -225,7 +225,7 @@
(unless coercer
(cmperr "Cannot coerce lisp object to C type ~A" host-type))
(wt (if (or (policy-assume-no-errors)
(subtypep loc-type dest-type))
(subtypep loc-type dest-type *cmp-env*))
(host-type-from-lisp-unsafe record)
coercer)
"(" loc ")")))
@ -249,7 +249,7 @@
;; the latter case.
(wt "(ecl_miscompilation_error(),0)")))
(ensure-valid-object-type (a-lisp-type)
(when (subtypep `(AND ,loc-type ,a-lisp-type) NIL)
(when (subtypep `(AND ,loc-type ,a-lisp-type) NIL *cmp-env*)
(coercion-error nil))))
(when (eq dest-host-type loc-host-type)
(wt loc)

18
src/cmp/cmpclos.lsp
View file

@ -17,7 +17,7 @@
(defun maybe-optimize-generic-function (fname args)
(when (fboundp fname)
(let ((gf (fdefinition fname)))
(when (typep gf 'standard-generic-function)
(when (typep gf 'standard-generic-function *cmp-env*)
;;(check-generic-function-args gf args)
(when (policy-inline-slot-access)
(maybe-optimize-slot-accessor fname gf args))))))
@ -36,9 +36,11 @@
(loop for specializer in (clos:method-specializers m)
for arg in c-args
always (let ((arg-type (c1form-type arg)))
(subtypep arg-type (if (consp specializer)
`(member ,(second specializer))
specializer))))))
(subtypep arg-type
(if (consp specializer)
`(member ,(second specializer))
specializer)
*cmp-env*)))))
(delete-if-not #'applicable-method-p methods)))
;;;
@ -93,10 +95,10 @@
;(format t "~%;;; Found ~D really applicable reader" (length readers))
(when (= (length readers) 1)
(let ((reader (first readers)))
(when (typep reader 'clos:standard-reader-method)
(when (typep reader 'clos:standard-reader-method *cmp-env*)
(let* ((slotd (clos:accessor-method-slot-definition reader))
(index (clos::safe-slot-definition-location slotd)))
(when (ext:fixnump index)
(when (typep index 'fixnum *cmp-env*)
`(clos::safe-instance-ref ,object ,index))))))))
(defun try-optimize-slot-writer (orig-writers args)
@ -105,10 +107,10 @@
;(format t "~%;;; Found ~D really applicable writer" (length writers))
(when (= (length writers) 1)
(let ((writer (first writers)))
(when (typep writer 'clos:standard-writer-method)
(when (typep writer 'clos:standard-writer-method *cmp-env*)
(let* ((slotd (clos:accessor-method-slot-definition writer))
(index (clos::safe-slot-definition-location slotd)))
(when (ext:fixnump index)
(when (typep index 'fixnum *cmp-env*)
`(si::instance-set ,(second args) ,index ,(first args)))))))))
#+(or)

18
src/cmp/cmpenv-api.lsp
View file

@ -94,6 +94,16 @@ that are susceptible to be changed by PROCLAIM."
(cmp-env-functions *cmp-env-root*))
(values))
(defun cmp-env-register-type (name definition &optional (env *cmp-env*))
(push (list :type name definition)
(cmp-env-variables env))
env)
(defun cmp-env-register-types (definitions &optional (env *cmp-env*))
(dolist (def definitions)
(setf env (cmp-env-register-type (car def) (cdr def) env)))
env)
(defun cmp-env-search-function (name &optional (env *cmp-env*))
(let ((cfb nil)
(unw nil)
@ -203,3 +213,11 @@ that are susceptible to be changed by PROCLAIM."
return (cddr i)
finally (return default)))
(defun cmp-env-search-type (name &optional (env *cmp-env*) (default name))
(loop for i in (car env)
when (and (consp i)
(eq (first i) :type)
(eq (second i) name))
return (third i)
finally (return default)))

5
src/cmp/cmpenv-declare.lsp
View file

@ -22,7 +22,8 @@
(every test x))))
(defun type-name-p (name)
(or (si:get-sysprop name 'SI::DEFTYPE-DEFINITION)
(or (cmp-env-search-type name *cmp-env* nil)
(si:get-sysprop name 'SI::DEFTYPE-DEFINITION)
(find-class name nil)
(si:get-sysprop name 'SI::STRUCTURE-TYPE)))
@ -114,7 +115,7 @@ and a possible documentation string (only accepted when DOC-P is true)."
(valid-type-specifier decl-name))
(if (null ok)
(cmpwarn "Unknown declaration specifier ~s." decl-name)
(setf types (collect-declared type decl-args types))) ))))
(setf types (collect-declared type decl-args types)))))))
finally (return (values body specials types ignored
(nreverse others) doc all-declarations)))))

2
src/cmp/cmplocs.lsp
View file

@ -157,7 +157,7 @@
(defun precise-loc-lisp-type (loc new-type)
(let ((loc-type (loc-lisp-type loc)))
(if (subtypep loc-type new-type)
(if (subtypep loc-type new-type *cmp-env*)
loc
`(the ,(type-and loc-type new-type) ,loc))))

6
src/cmp/cmpopt-clos.lsp
View file

@ -14,7 +14,7 @@
(when (and (si::valid-function-name-p fname)
(fboundp fname))
(let ((function (fdefinition fname)))
(when (typep function 'generic-function)
(when (typep function 'generic-function *cmp-env*)
(generic-function-macro-expand function (list* fname args))))))
(defmethod generic-function-macro-expand ((g standard-generic-function) whole)
@ -24,7 +24,7 @@
(defun optimizable-slot-reader (method whole)
(declare (si::c-local))
(when (typep method 'clos:standard-reader-method)
(when (typep method 'clos:standard-reader-method *cmp-env*)
(let ((class (first (clos:method-specializers method))))
(when (clos::class-sealedp class)
(let* ((slotd (clos:accessor-method-slot-definition method))
@ -47,7 +47,7 @@
(defun optimizable-slot-writer (method whole)
(declare (si::c-local))
(when (typep method 'clos:standard-writer-method)
(when (typep method 'clos:standard-writer-method *cmp-env*)
(let ((class (second (clos:method-specializers method))))
(when (clos::class-sealedp class)
(let* ((slotd (clos:accessor-method-slot-definition method))

4
src/cmp/cmpopt-sequence.lsp
View file

@ -52,7 +52,7 @@
`(let* ((%seq ,seq)
(%iterator ,iterator))
(declare (optimize (safety 0)))
(if (ext:fixnump %iterator)
(if (typep %iterator 'fixnum *cmp-env*)
;; Fixnum iterators are always fine
(aref %seq %iterator)
;; Error check in case we may have been passed an improper list
@ -64,7 +64,7 @@
`(let* ((%seq ,seq)
(%iterator ,iterator))
(declare (optimize (safety 0)))
(if (ext:fixnump %iterator)
(if (typep %iterator 'fixnum *cmp-env*)
(let ((%iterator (1+ (ext:truly-the fixnum %iterator))))
(declare (fixnum %iterator))
(and (< %iterator (length (ext:truly-the vector %seq)))

24
src/cmp/cmpopt.lsp
View file

@ -53,7 +53,7 @@
first rest function)
;; Type must be constant to optimize
(if (constantp type env)
(setf type (ext:constant-form-value type env))
(setf type (cmp-env-search-type (ext:constant-form-value type env) env))
(return-from expand-typep form))
(cond ;; compound function type specifier: signals an error
((contains-compound-function-type type)
@ -62,15 +62,15 @@
;; Variable declared with a given type
((and (symbolp object)
(setf aux (cmp-env-search-var object env))
(subtypep (var-type aux) type))
(subtypep (var-type aux) type *cmp-env*))
t)
;; Simple ones
((subtypep 'T type) T)
((subtypep 'T type *cmp-env*) T)
((eq type 'NIL) NIL)
;;
;; 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)
((subtypep type NIL *cmp-env*)
(cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type)
form)
;;
@ -95,7 +95,7 @@
;; 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 env)
when (si::type= type a-type *cmp-env*)
do (return `(,function-name ,object))))
;;
;; No optimizations that take up too much space unless requested.
@ -144,7 +144,7 @@
;; Small optimization: it is easier to check for fixnum
;; than for integer. Use it when possible.
(when (and (eq first 'integer)
(subtypep type 'fixnum))
(subtypep type 'fixnum *cmp-env*))
(setf first 'fixnum))
`(LET ((,var1 ,object)
(,var2 ,(coerce 0 first)))
@ -261,14 +261,14 @@
first rest)
;; Type must be constant to optimize
(if (constantp type env)
(setf type (ext:constant-form-value type env))
(setf type (cmp-env-search-type (ext:constant-form-value type env) env))
(return-from expand-coerce form))
(cond ;; Trivial case
((subtypep 't type)
((subtypep 't type *cmp-env*)
value)
;;
;; Detect inconsistencies in the type form.
((subtypep type 'nil)
((subtypep type 'nil *cmp-env*)
(cmperror "Cannot COERCE an expression to an empty type."))
;;
;; No optimizations that take up too much space unless requested.
@ -293,18 +293,18 @@
;; 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 env)
when (si::type= type a-type *cmp-env*)
do (return (subst value 'x template))))
;;
;; SEQUENCE types
((subtypep type 'sequence)
((subtypep type 'sequence *cmp-env*)
(multiple-value-bind (elt-type length)
(si::closest-sequence-type type)
(if (or (eq length '*) (policy-assume-right-type))
(if (eq elt-type 'list)
`(si::coerce-to-list ,value)
`(si::coerce-to-vector ,value ',elt-type ',length
,(and (subtypep type 'simple-array) t)))
,(and (subtypep type 'simple-array *cmp-env*) t)))
form)))
;;
;; There are no other atomic types to optimize

20
src/cmp/cmpprop-num.lsp
View file

@ -20,7 +20,7 @@
(if args
(dolist (int-type '((UNSIGNED-BYTE 8) FIXNUM) 'integer)
(when (loop for value in args
always (subtypep value int-type))
always (subtypep value int-type *cmp-env*))
(return int-type)))
'fixnum)))
@ -51,11 +51,11 @@
(when (and only-real (or complex-t1 complex-t2))
(return-from maximum-number-type (values default default default)))
(loop for i across number-types
do (when (and (null t1-eq) (type>= i t1))
do (when (and (null t1-eq) (type>= i t1 *cmp-env*))
(when (equalp t1 t2)
(setf t2-eq i))
(setf t1-eq i output i))
(when (and (null t2-eq) (type>= i t2))
(when (and (null t2-eq) (type>= i t2 *cmp-env*))
(setf t2-eq i output i)))
(unless (and t1-eq t2-eq output)
(setf output default))
@ -134,10 +134,10 @@
(let ((exponent (ensure-real-type exponent)))
(values (list base exponent)
(cond ((eql exponent 'integer)
(if (subtypep base 'fixnum)
(if (subtypep base 'fixnum *cmp-env*)
'integer
base))
((type>= '(real 0 *) base)
((type>= '(real 0 *) base *cmp-env*)
(let* ((exponent (ensure-nonrational-type exponent)))
(maximum-number-type exponent base)))
(t
@ -148,7 +148,7 @@
(ensure-number-type arg)
(values (list arg)
(or (cdr (assoc output
'((FIXNUM . (INTEGER 0 #.MOST-POSITIVE-FIXNUM))
'((FIXNUM . (AND FIXNUM (INTEGER 0 *)))
(INTEGER . (INTEGER 0 *))
(RATIONAL . (RATIONAL 0 *))
(SHORT-FLOAT . (SHORT-FLOAT 0 *))
@ -163,10 +163,10 @@
(multiple-value-bind (output arg)
(ensure-nonrational-type arg)
(values (list arg)
(if (type>= '(REAL 0 *) arg) output 'NUMBER))))
(if (type>= '(REAL 0 *) arg *cmp-env*) output 'NUMBER))))
(def-type-propagator isqrt (fname arg)
(if (type>= '(integer 0 #.MOST-POSITIVE-FIXNUM) arg)
(values '((integer 0 #.MOST-POSITIVE-FIXNUM))
'(integer 0 #.MOST-POSITIVE-FIXNUM))
(if (type>= 'ext:non-negative-fixnum arg *cmp-env*)
(values '(ext:non-negative-fixnum)
'ext:non-negative-fixnum)
(values '((integer 0 *)) '(integer 0 *))))

24
src/cmp/cmpprop.lsp
View file

@ -138,9 +138,9 @@
(defun p1if (c1form fmla true-branch false-branch)
(declare (ignore c1form))
(let ((t0 (values-type-primary-type (p1propagate fmla))))
(cond ((type-true-p t0)
(cond ((type-true-p t0 *cmp-env*)
(p1propagate true-branch))
((type-false-p t0)
((type-false-p t0 *cmp-env*)
(p1propagate false-branch))
(t (let ((t1 (p1propagate true-branch))
(t2 (p1propagate false-branch)))
@ -149,9 +149,9 @@
(defun p1fmla-not (c1form form)
(declare (ignore c1form))
(let ((t0 (values-type-primary-type (p1propagate form))))
(cond ((type-true-p t0)
(cond ((type-true-p t0 *cmp-env*)
'(eql nil))
((type-false-p t0)
((type-false-p t0 *cmp-env*)
'(eql t))
(t
'(member t nil)))))
@ -162,15 +162,15 @@
for form in butlast
for type = (p1propagate form)
for primary-type = (values-type-primary-type type)
do (when (type-false-p primary-type)
do (when (type-false-p primary-type *cmp-env*)
(return-from p1fmla-and primary-type))
(unless (type-true-p primary-type)
(unless (type-true-p primary-type *cmp-env*)
(setf all-true nil))
finally
(setf type (p1propagate last)
primary-type (values-type-primary-type type))
(return (if (or (type-false-p primary-type)
(and (type-true-p primary-type) all-true))
(return (if (or (type-false-p primary-type *cmp-env*)
(and (type-true-p primary-type *cmp-env*) all-true))
type
(values-type-or 'null type)))))
@ -180,13 +180,13 @@
for type = (p1propagate form)
for primary-type = (values-type-primary-type type)
for output-type = primary-type then (type-or primary-type output-type)
do (when (type-true-p primary-type)
do (when (type-true-p primary-type *cmp-env*)
(return-from p1fmla-or (type-and output-type '(not null))))
finally
(setf type (p1propagate last)
primary-type (values-type-primary-type type)
output-type (values-type-or type output-type))
(return (if (type-true-p primary-type)
(return (if (type-true-p primary-type *cmp-env*)
(values-type-and output-type '(not null))
output-type))))
@ -245,7 +245,7 @@
for (a-type c1form) in expressions
for c1form-type = (p1propagate c1form)
when (or (member a-type '(t otherwise))
(subtypep var-type a-type))
(subtypep var-type a-type *cmp-env*))
do (setf output-type c1form-type)
finally (return output-type))))
@ -254,7 +254,7 @@
(let ((value-type (p1propagate value))
;;(alt-type (p1propagate let-form))
)
(if (subtypep value-type type)
(if (subtypep value-type type *cmp-env*)
value-type
type)))

2
src/cmp/cmpstructures.lsp
View file

@ -38,7 +38,7 @@
(unless (and (consp slot-description)
(setf structure-type (car slot-description)
slot-index (cdr slot-description))
(typep slot-index 'fixnum))
(typep slot-index 'fixnum *cmp-env*))
(cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A"
fname slot-index)
(return-from maybe-optimize-structure-access nil))

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

@ -39,7 +39,7 @@
(deftype any () 't)
(defun member-type (type disjoint-supertypes)
(member type disjoint-supertypes :test #'subtypep))
(member type disjoint-supertypes :test #'(lambda (t1 t2) (subtypep t1 t2 *cmp-env*))))
;;; Canonicalize the object type to a type recognized by the compiler.
;;; Depends on the implementation of TYPECASE.
@ -68,17 +68,17 @@
(defun valid-type-specifier (type)
(handler-case
(if (subtypep type 'T)
(if (subtypep type 'T *cmp-env*)
(values t type)
(values nil nil))
(error ()
(values nil nil))))
(defun known-type-p (type)
(subtypep type T))
(subtypep type T *cmp-env*))
(defun trivial-type-p (type)
(subtypep T type))
(subtypep T type *cmp-env*))
(defun-cached type-and (t1 t2) type-specifier=
;; FIXME! Should we allow "*" as type name???
@ -314,8 +314,8 @@
(cmpnote "Unknown type ~S" t2)
T))))
(defun type>= (type1 type2)
(subtypep type2 type1))
(defun type>= (type1 type2 &optional env)
(subtypep type2 type1 env))
(defun type-false-p (type) (subtypep type 'null))
(defun type-true-p (type) (subtypep type '(not null)))
(defun type-false-p (type &optional env) (subtypep type 'null env))
(defun type-true-p (type &optional env) (subtypep type '(not null) env))

11
src/cmp/cmptype-assert.lsp
View file

@ -16,7 +16,7 @@
(constant-value-p form *cmp-env*)
(when constantp
(loop for (type . forms) in (rest args)
when (typep value type)
when (typep value type *cmp-env*)
do (return-from c1compiler-typecase (c1progn forms))
finally (baboon :format-control "COMPILER-TYPECASE form missing a T statement")))))
(let* ((var-name (pop args))
@ -25,7 +25,7 @@
;; If the first type, which is supposedly the most specific
;; already includes the form, we keep it. This optimizes
;; most cases of CHECKED-VALUE.
(if (subtypep (var-type var) (car first-case))
(if (subtypep (var-type var) (car first-case) *cmp-env*)
(c1progn (cdr first-case))
(let* ((types '())
(expressions (loop for (type . forms) in args
@ -42,7 +42,7 @@
(loop with var-type = (var-type var)
for (type form) in expressions
when (or (member type '(t otherwise))
(subtypep var-type type))
(subtypep var-type type *cmp-env*))
return (c2expr form)))
(defconstant +simple-type-assertions+
@ -97,7 +97,8 @@
value)))
((and (policy-evaluate-forms) (constantp value *cmp-env*))
(if (typep (ext:constant-form-value value *cmp-env*)
(si::flatten-function-types type *cmp-env*))
(si::flatten-function-types type *cmp-env*)
*cmp-env*)
value
(progn
;; warn and generate error.
@ -135,7 +136,7 @@
(defun c2checked-value (c1form type value let-form)
(declare (ignore c1form))
(c2expr (if (subtypep (c1form-primary-type value) type)
(c2expr (if (subtypep (c1form-primary-type value) type *cmp-env*)
value
let-form)))

7
src/cmp/cmptype.lsp
View file

@ -46,7 +46,8 @@
'((si:complex-single-float . #c(0.0f0 0.0f0))
(si:complex-double-float . #c(0.0d0 0.0d0))
(si:complex-long-float . #c(0.0l0 0.0l0)))))
:test #'subtypep))))
:test #'(lambda (t1 t2)
(subtypep t1 t2 *cmp-env*))))))
(if new-value
(c1constant-value new-value)
(c1nil))))
@ -60,7 +61,7 @@
(flet ((maybe-fix-type (var init type type-iterator)
(multiple-value-bind (constantp value)
(c1form-constant-p init)
(when (and constantp (not (typep value type)))
(when (and constantp (not (typep value type *cmp-env*)))
(cmpwarn-style "The init-form of the argument ~A of ~:[an anonymous function~;the function ~:*~A~] is not of the declared type ~A."
(var-name var)
(fun-name *current-function*)
@ -191,7 +192,7 @@
(defmacro assert-type-if-known (value type &environment env)
"Generates a type check on an expression, ensuring that it is satisfied."
(multiple-value-bind (trivial valid)
(subtypep 't type)
(subtypep 't type *cmp-env*)
(cond ((and trivial valid)
value)
((multiple-value-setq (valid value) (constant-value-p value env))

58
src/lsp/predlib.lsp
View file

@ -458,7 +458,6 @@ and is not adjustable."
'(t)))
(defun upgraded-array-element-type (element-type &optional env)
(declare (ignore env))
(let* ((hash (logand 127 (si:hash-eql element-type)))
(record (aref *upgraded-array-element-type-cache* hash)))
(declare (type (integer 0 127) hash))
@ -468,14 +467,13 @@ and is not adjustable."
:test #'eq)
element-type
(dolist (v +upgraded-array-element-types+ 'T)
(when (subtypep element-type v)
(when (subtypep element-type v env)
(return v))))))
(setf (aref *upgraded-array-element-type-cache* hash)
(cons element-type answer))
answer))))
(defun upgraded-complex-part-type (real-type &optional env)
(declare (ignore env))
;; ECL does not have specialized complex types. If we had them, the
;; code would look as follows
;; (dolist (v '(INTEGER RATIO RATIONAL SINGLE-FLOAT DOUBLE-FLOAT FLOAT REAL)
@ -483,17 +481,17 @@ and is not adjustable."
;; (when (subtypep real-type v)
;; (return v))))
#+complex-float
(cond ((subtypep real-type 'null) nil)
((subtypep real-type 'rational) 'rational)
((subtypep real-type 'single-float) 'single-float)
((subtypep real-type 'double-float) 'double-float)
((subtypep real-type 'long-float) 'long-float)
((subtypep real-type 'float) 'float)
((subtypep real-type 'real) 'real)
(cond ((subtypep real-type 'null env) nil)
((subtypep real-type 'rational env) 'rational)
((subtypep real-type 'single-float env) 'single-float)
((subtypep real-type 'double-float env) 'double-float)
((subtypep real-type 'long-float env) 'long-float)
((subtypep real-type 'float env) 'float)
((subtypep real-type 'real env) 'real)
(t (error "~S is not a valid part type for a complex." real-type)))
#-complex-float
(cond ((subtypep real-type 'null) nil)
((subtypep real-type 'real) 'real)
(cond ((subtypep real-type 'null env) nil)
((subtypep real-type 'real env) 'real)
(t (error "~S is not a valid part type for a complex." real-type))))
(defun in-interval-p (x interval)
@ -536,6 +534,8 @@ and is not adjustable."
(defun typep (object type &optional env &aux tp i c)
"Args: (object type)
Returns T if X belongs to TYPE; NIL otherwise."
(when env
(setf type (search-type-in-env type env)))
(cond ((symbolp type)
(let ((f (get-sysprop type 'TYPE-PREDICATE)))
(if f
@ -549,11 +549,11 @@ Returns T if X belongs to TYPE; NIL otherwise."
(error-type-specifier type)))
(case tp
((EQL MEMBER) (and (member object i) t))
(NOT (not (typep object (car i))))
(NOT (not (typep object (car i) env)))
(OR (dolist (e i)
(when (typep object e) (return t))))
(when (typep object e env) (return t))))
(AND (dolist (e i t)
(unless (typep object e) (return nil))))
(unless (typep object e env) (return nil))))
(SATISFIES (funcall (car i) object))
((T *) t)
((NIL) nil)
@ -584,17 +584,17 @@ Returns T if X belongs to TYPE; NIL otherwise."
;; type specifier may be i.e (complex integer) so we
;; should check both real and imag part (disregarding
;; the fact that both have the same upgraded type).
(and (typep (realpart object) (car i))
(typep (imagpart object) (car i))))
(and (typep (realpart object) (car i) env)
(typep (imagpart object) (car i) env)))
))
(SEQUENCE (or (listp object) (vectorp object)))
(CONS (and (consp object)
(or (endp i)
(let ((car-type (first i)))
(or (eq car-type '*) (typep (car object) car-type))))
(or (eq car-type '*) (typep (car object) car-type env))))
(or (endp (cdr i))
(let ((cdr-type (second i)))
(or (eq cdr-type '*) (typep (cdr object) cdr-type))))))
(or (eq cdr-type '*) (typep (cdr object) cdr-type env))))))
(BASE-STRING
(and (base-string-p object)
(or (null i) (match-dimensions object i))))
@ -1446,7 +1446,7 @@ if not possible."
(values tag `(OR ,@out)))))
;;----------------------------------------------------------------------
;; (CANONICAL-TYPE TYPE)
;; (CANONICAL-TYPE TYPE ENV)
;;
;; This function registers all types mentioned in the given expression,
;; and outputs a code corresponding to the represented type. This
@ -1455,6 +1455,8 @@ if not possible."
;;
(defun canonical-type (type env)
(declare (notinline clos::classp))
(when env
(setf type (search-type-in-env type env)))
(cond ((find-registered-tag type))
((eq type 'T) -1)
((eq type 'NIL) 0)
@ -1608,3 +1610,19 @@ if not possible."
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(fast-type= t1 t2 env)))
(defun search-type-in-env (type env)
(let ((type-name type)
(type-args nil))
(when (consp type)
(setf type-name (first type)
type-args (rest type)))
(dolist (record (car env))
(when (and (consp record)
(eq (first record) :type)
(eq (second record) type-name))
(return-from search-type-in-env
(if (typep (third record) 'function)
(funcall (third record) type-args)
(third record))))))
type)