mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-16 14:21:48 -08:00
Implemented type assertions using EXT:COMPILER-TYPECASE so that they can be optimized away.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
281fe567d4
commit
ecd9dd2470
6 changed files with 175 additions and 159 deletions
|
|
@ -24,73 +24,6 @@
|
|||
;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys)
|
||||
;;;
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defconstant +all-c1-forms+
|
||||
'((LOCATION loc :pure :single-valued)
|
||||
(VAR var :single-valued)
|
||||
(SETQ var value-c1form :side-effects)
|
||||
(PSETQ var-list value-c1form-list :side-effects)
|
||||
(BLOCK blk-var progn-c1form :pure)
|
||||
(PROGN body :pure)
|
||||
(PROGV symbols values form :side-effects)
|
||||
(TAGBODY tag-var tag-body :pure)
|
||||
(RETURN-FROM blk-var return-type value variable-or-nil :side-effects)
|
||||
(FUNCALL fun-value (arg-value*) :side-effects)
|
||||
(CALL-LOCAL obj-fun (arg-value*) :side-effects)
|
||||
(CALL-GLOBAL fun-name (arg-value*))
|
||||
(CATCH catch-value body :side-effects)
|
||||
(UNWIND-PROTECT protected-c1form body :side-effects)
|
||||
(THROW catch-value output-value :side-effects)
|
||||
(GO tag-var return-type :side-effects)
|
||||
(C-INLINE (arg-c1form*)
|
||||
(arg-type-symbol*)
|
||||
output-rep-type
|
||||
c-expression-string
|
||||
side-effects-p
|
||||
one-liner-p)
|
||||
(LOCALS local-fun-list body labels-p :pure)
|
||||
(IF fmla-c1form true-c1form false-c1form :pure)
|
||||
(FMLA-NOT fmla-c1form :pure)
|
||||
(FMLA-AND * :pure)
|
||||
(FMLA-OR * :pure)
|
||||
(LAMBDA lambda-list doc body-c1form)
|
||||
(LET* vars-list var-init-c1form-list decl-body-c1form :pure)
|
||||
(VALUES values-c1form-list :pure)
|
||||
(MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
|
||||
(MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
|
||||
(COMPILER-LET symbols values body)
|
||||
(FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
|
||||
(RPLACD (dest-c1form value-c1form) :side-effects)
|
||||
|
||||
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
|
||||
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
|
||||
|
||||
(WITH-STACK body :side-effects)
|
||||
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
|
||||
|
||||
(ORDINARY c1form :pure)
|
||||
(LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
|
||||
(SI:FSET function-object vv-loc macro-p pprint-p lambda-form
|
||||
:side-effects)
|
||||
(MAKE-FORM vv-loc value-c1form :side-effects)
|
||||
(INIT-FORM vv-loc value-c1form :side-effects))))
|
||||
|
||||
(defconstant +c1-form-hash+
|
||||
#.(loop with hash = (make-hash-table :size 128 :test #'eq)
|
||||
for (name . rest) in +all-c1-forms+
|
||||
for length = (if (member '* rest) nil (length rest))
|
||||
for side-effects = (if (member :side-effects rest)
|
||||
(progn (and length (decf length)) t)
|
||||
nil)
|
||||
for movable = (if (member :pure rest)
|
||||
(progn (and length (decf length)) t)
|
||||
nil)
|
||||
for single-valued = (if (member :single-valued rest)
|
||||
(progn (and length (decf length)) t)
|
||||
nil)
|
||||
do (setf (gethash name hash) (list length side-effects movable single-valued))
|
||||
finally (return hash)))
|
||||
|
||||
(defun print-c1form (form stream)
|
||||
(format stream "#<form ~A ~X>" (c1form-name form) (si:pointer form)))
|
||||
|
||||
|
|
|
|||
|
|
@ -14,32 +14,6 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defun compute-c1form-type (form)
|
||||
(let ((form (c1expr form)))
|
||||
(prog1 (c1form-primary-type form)
|
||||
(delete-c1forms form))))
|
||||
|
||||
(defun safe-type<= (t1 t2)
|
||||
(multiple-value-bind (subtypep known-typep)
|
||||
(subtypep t1 t2)
|
||||
(and subtypep known-typep)))
|
||||
|
||||
(defun c1compiler-typecase (args)
|
||||
(let* ((expr-type (compute-c1form-type (pop args)))
|
||||
(match (find expr-type args :test #'safe-type<= :key #'first)))
|
||||
(if match
|
||||
(c1progn (rest match))
|
||||
(c1nil))))
|
||||
|
||||
(defun c1compiler-typecases (args)
|
||||
(let* ((all-types (mapcar #'compute-c1form-type (pop args)))
|
||||
(match (find all-types args
|
||||
:test #'(lambda (s1 s2) (every #'safe-typep<= s1 s2))
|
||||
:key #'first)))
|
||||
(if match
|
||||
(c1progn (rest match))
|
||||
(c1nil))))
|
||||
|
||||
(define-compiler-macro dotimes ((variable limit &rest output) &body body)
|
||||
(multiple-value-bind (declarations body)
|
||||
(si:process-declarations body nil)
|
||||
|
|
@ -50,7 +24,7 @@
|
|||
`(block nil
|
||||
(let ((,%limit ,limit))
|
||||
(declare (:read-only ,%limit))
|
||||
(ext:compiler-typecase ,limit
|
||||
(ext:compiler-typecase ,%limit
|
||||
(fixnum (let ((,variable 0))
|
||||
(declare (fixnum ,variable)
|
||||
,@declarations)
|
||||
|
|
|
|||
|
|
@ -234,6 +234,16 @@ of the occurrences in those lists."
|
|||
(defun p1progn (c1form assumptions forms)
|
||||
(p1propagate-list forms assumptions))
|
||||
|
||||
(defun p1compiler-typecase (c1form assumptions variable expressions)
|
||||
(let ((var-type (var-type variable)))
|
||||
(loop with output-type = t
|
||||
for (a-type c1form) in expressions
|
||||
for c1form-type = (p1propagate c1form assumptions)
|
||||
when (or (member a-type '(t otherwise))
|
||||
(subtypep var-type a-type))
|
||||
do (setf output-type c1form-type)
|
||||
finally (return (values output-type assumptions)))))
|
||||
|
||||
(defun p1progv (c1form assumptions variables values body)
|
||||
(let (type)
|
||||
(multiple-value-setq (type assumptions)
|
||||
|
|
|
|||
|
|
@ -13,6 +13,74 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defconstant +all-c1-forms+
|
||||
'((LOCATION loc :pure :single-valued)
|
||||
(VAR var :single-valued)
|
||||
(SETQ var value-c1form :side-effects)
|
||||
(PSETQ var-list value-c1form-list :side-effects)
|
||||
(BLOCK blk-var progn-c1form :pure)
|
||||
(PROGN body :pure)
|
||||
(PROGV symbols values form :side-effects)
|
||||
(TAGBODY tag-var tag-body :pure)
|
||||
(RETURN-FROM blk-var return-type value variable-or-nil :side-effects)
|
||||
(FUNCALL fun-value (arg-value*) :side-effects)
|
||||
(CALL-LOCAL obj-fun (arg-value*) :side-effects)
|
||||
(CALL-GLOBAL fun-name (arg-value*))
|
||||
(CATCH catch-value body :side-effects)
|
||||
(UNWIND-PROTECT protected-c1form body :side-effects)
|
||||
(THROW catch-value output-value :side-effects)
|
||||
(GO tag-var return-type :side-effects)
|
||||
(C-INLINE (arg-c1form*)
|
||||
(arg-type-symbol*)
|
||||
output-rep-type
|
||||
c-expression-string
|
||||
side-effects-p
|
||||
one-liner-p)
|
||||
(LOCALS local-fun-list body labels-p :pure)
|
||||
(IF fmla-c1form true-c1form false-c1form :pure)
|
||||
(FMLA-NOT fmla-c1form :pure)
|
||||
(FMLA-AND * :pure)
|
||||
(FMLA-OR * :pure)
|
||||
(LAMBDA lambda-list doc body-c1form)
|
||||
(LET* vars-list var-init-c1form-list decl-body-c1form :pure)
|
||||
(VALUES values-c1form-list :pure)
|
||||
(MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects)
|
||||
(MULTIPLE-VALUE-BIND vars-list init-c1form body :pure)
|
||||
(COMPILER-LET symbols values body)
|
||||
(FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued)
|
||||
(RPLACD (dest-c1form value-c1form) :side-effects)
|
||||
|
||||
(SI:STRUCTURE-REF struct-c1form type-name slot-index (:UNSAFE/NIL) :pure)
|
||||
(SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form :side-effects)
|
||||
|
||||
(WITH-STACK body :side-effects)
|
||||
(STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects)
|
||||
|
||||
(ORDINARY c1form :pure)
|
||||
(LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued)
|
||||
(SI:FSET function-object vv-loc macro-p pprint-p lambda-form
|
||||
:side-effects)
|
||||
(MAKE-FORM vv-loc value-c1form :side-effects)
|
||||
(INIT-FORM vv-loc value-c1form :side-effects)
|
||||
(EXT:COMPILER-TYPECASE var expressions))))
|
||||
|
||||
(defconstant +c1-form-hash+
|
||||
#.(loop with hash = (make-hash-table :size 128 :test #'eq)
|
||||
for (name . rest) in +all-c1-forms+
|
||||
for length = (if (member '* rest) nil (length rest))
|
||||
for side-effects = (if (member :side-effects rest)
|
||||
(progn (and length (decf length)) t)
|
||||
nil)
|
||||
for movable = (if (member :pure rest)
|
||||
(progn (and length (decf length)) t)
|
||||
nil)
|
||||
for single-valued = (if (member :single-valued rest)
|
||||
(progn (and length (decf length)) t)
|
||||
nil)
|
||||
do (setf (gethash name hash) (list length side-effects movable single-valued))
|
||||
finally (return hash)))
|
||||
|
||||
(defconstant +c1-dispatch-alist+
|
||||
'((block . c1block) ; c1special
|
||||
(return-from . c1return-from) ; c1special
|
||||
|
|
@ -46,7 +114,6 @@
|
|||
(multiple-value-bind . c1multiple-value-bind) ; c1
|
||||
|
||||
(ext:compiler-typecase . c1compiler-typecase) ; c1special
|
||||
(c::compiler-typecases . c1compiler-typecases) ; c1special
|
||||
|
||||
(quote . c1quote) ; c1special
|
||||
(function . c1function) ; c1special
|
||||
|
|
@ -178,6 +245,8 @@
|
|||
|
||||
(sys:structure-ref . c2structure-ref) ; c2
|
||||
(sys:structure-set . c2structure-set) ; c2
|
||||
|
||||
(ext:compiler-typecase . c2compiler-typecase)
|
||||
))
|
||||
|
||||
(defconstant +t2-dispatch-alist+
|
||||
|
|
@ -226,6 +295,7 @@
|
|||
(c::with-stack . p1with-stack)
|
||||
(c::stack-push-values . p1stack-push-values)
|
||||
(sys::structure-set . p1structure-set)
|
||||
(ext:compiler-typecase . p1compiler-typecase) ; c1special
|
||||
))
|
||||
|
||||
(defun make-dispatch-table (alist)
|
||||
|
|
|
|||
|
|
@ -13,81 +13,101 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
(defmacro unlikely (bool)
|
||||
`(ffi:c-inline (,bool) (:bool) :bool "ecl_unlikely(#0)"
|
||||
:one-liner t :side-effects nil))
|
||||
(defun c1compiler-typecase (args)
|
||||
(let* ((var-name (pop args))
|
||||
(var (c1vref var-name))
|
||||
(expressions (loop for (type . forms) in args
|
||||
collect (list type (c1progn forms)))))
|
||||
(make-c1form* 'EXT:COMPILER-TYPECASE
|
||||
:type 't
|
||||
:args var expressions)))
|
||||
|
||||
(defun expand-type-assertion (value type env)
|
||||
(if (not (symbolp value))
|
||||
(with-clean-symbols (%value)
|
||||
`(let ((%value ,value))
|
||||
(declare (:read-only %value))
|
||||
,(expand-type-assertions '%value type env)))
|
||||
(case type
|
||||
(cons
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"@0;if (ecl_unlikely(ATOM(#0))) FEtype_error_cons(#0);"
|
||||
:one-liner nil))
|
||||
(array
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"if (ecl_unlikely(!ECL_ARRAYP(#0))) FEtype_error_array(#0);"
|
||||
:one-liner nil))
|
||||
(list
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"if (ecl_unlikely(!ECL_LISTP(#0))) FEtype_error_list(#0);"
|
||||
:one-liner nil))
|
||||
(sequence
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"if (ecl_unlikely(!(ECL_LISTP(#0) || ECL_VECTORP(#0))))
|
||||
(defun c2compiler-typecase (var expressions)
|
||||
(loop with var-type = (var-type var)
|
||||
for (type form) in expressions
|
||||
when (or (member type '(t otherwise))
|
||||
(subtypep var-type type))
|
||||
return (c2expr form)))
|
||||
|
||||
(defun variable-or-constant-p (value env)
|
||||
(or (when (symbolp value) (known-variable-p value env))
|
||||
(constantp value env)))
|
||||
|
||||
(defun simple-type-assertion (value type env)
|
||||
(case type
|
||||
(cons
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"@0;if (ecl_unlikely(ATOM(#0))) FEtype_error_cons(#0);"
|
||||
:one-liner nil))
|
||||
(array
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"if (ecl_unlikely(!ECL_ARRAYP(#0))) FEtype_error_array(#0);"
|
||||
:one-liner nil))
|
||||
(list
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"if (ecl_unlikely(!ECL_LISTP(#0))) FEtype_error_list(#0);"
|
||||
:one-liner nil))
|
||||
(sequence
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"if (ecl_unlikely(!(ECL_LISTP(#0) || ECL_VECTORP(#0))))
|
||||
FEtype_error_sequence(#0);"
|
||||
:one-liner nil))
|
||||
(otherwise
|
||||
`(ffi:c-inline
|
||||
((typep ,value ',type) ',type ,value)
|
||||
(:bool :object :object) :void
|
||||
"if (ecl_unlikely(!(#0)))
|
||||
FEwrong_type_argument(#1,#2);" :one-liner nil)
|
||||
#+(or)
|
||||
`(if (unlikely (not (typep ,value ',type)))
|
||||
(compiler-type-error ,value ,type))))))
|
||||
:one-liner nil))
|
||||
(otherwise
|
||||
`(ffi:c-inline
|
||||
((typep ,value ',type) ',type ,value)
|
||||
(:bool :object :object) :void
|
||||
"if (ecl_unlikely(!(#0)))
|
||||
FEwrong_type_argument(#1,#2);" :one-liner nil))))
|
||||
|
||||
(defun expand-type-assertion (value type env compulsory)
|
||||
(cond ((constantp value env)
|
||||
;; For constant values, we simply verify the assertion directly
|
||||
(unless (typep (cmp-eval value env) type)
|
||||
(cmpwarning "Failed type assertion for value ~A and type ~A"
|
||||
value type))
|
||||
t)
|
||||
((or (not (symbolp value))
|
||||
(special-variable-p value)
|
||||
(symbol-macro-p value))
|
||||
;; If multiple references to the value cost time and space,
|
||||
;; or may cause side effects, we save it.
|
||||
(with-clean-symbols (%value)
|
||||
`(let* ((%value ,value))
|
||||
(declare (:read-only %value))
|
||||
,(expand-type-assertion '%value type env compulsory))))
|
||||
(compulsory
|
||||
;; The check has to be produced, independent of the declared
|
||||
;; value of the variable (for instance, in LAMBDA arguments).
|
||||
(simple-type-assertion value type env))
|
||||
(t
|
||||
;; We may rely on the compiler to choose the appropriate
|
||||
;; branch once type propagation has happened.
|
||||
`(ext:compiler-typecase ,value
|
||||
(,type)
|
||||
(t ,(simple-type-assertion value type env))))))
|
||||
|
||||
(defmacro optional-type-assertion (&whole whole value type &environment env)
|
||||
"Generates a type check on an expression, ensuring that it is satisfied."
|
||||
(when (policy-type-assertions env)
|
||||
(cmpnote "Checking type ~A for expression~&~A" type value)
|
||||
(expand-type-assertion value type env)))
|
||||
(expand-type-assertion value type env nil)))
|
||||
|
||||
(defmacro type-assertion (&whole whole value type &environment env)
|
||||
"Generates a type check on an expression, ensuring that it is satisfied."
|
||||
(cmpnote "Checking type ~A for expression~&~A" type value)
|
||||
(expand-type-assertion value type env))
|
||||
(expand-type-assertion value type env t))
|
||||
|
||||
(defmacro checked-value (&whole whole value type &environment env)
|
||||
(if (policy-type-assertions env)
|
||||
(with-clean-symbols (%value)
|
||||
`(let* ((%value ,value))
|
||||
,(expand-type-assertion '%value type env)
|
||||
(the ,type %value)))
|
||||
value))
|
||||
(cond ((not (policy-type-assertions env))
|
||||
`(the ,type ,value))
|
||||
((or (constantp value type)
|
||||
(and (symbolp value) (local-variable-p value env)))
|
||||
`(progn
|
||||
,(expand-type-assertion value type env nil)
|
||||
(the ,type ,value)))
|
||||
(t
|
||||
(with-clean-symbols (%checked-value)
|
||||
`(let* ((%checked-value ,value))
|
||||
,(expand-type-assertion '%checked-value type env nil)
|
||||
(the ,type ,value))))))
|
||||
|
||||
(defmacro compiler-type-error (value type &environment env)
|
||||
(case type
|
||||
(cons
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"FEtype_error_cons(#0);"
|
||||
:one-liner t))
|
||||
(array
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"FEtype_error_array(#0);"
|
||||
:one-liner t))
|
||||
(list
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"FEtype_error_list(#0);"
|
||||
:one-liner t))
|
||||
(sequence
|
||||
`(ffi:c-inline (,value) (:object) :void
|
||||
"FEtype_error_sequence(#0);"
|
||||
:one-liner t))
|
||||
(otherwise
|
||||
`(ffi:c-inline (',type ,value) (:object :object) :void
|
||||
"FEwrong_type_argument(#0,#1);"))))
|
||||
|
|
|
|||
|
|
@ -138,6 +138,7 @@
|
|||
(member name *global-vars* :test #'eq :key #'var-name))
|
||||
|
||||
(defun special-variable-p (name)
|
||||
"Return true if NAME is associated to a special variable in the lexical environment."
|
||||
(or (si::specialp name)
|
||||
(check-global name)
|
||||
(let ((v (cmp-env-search-var name *cmp-env-root*)))
|
||||
|
|
@ -145,6 +146,14 @@
|
|||
;; we also have to consider 'GLOBAL here.
|
||||
(and v (eq (var-kind v) 'SPECIAL)))))
|
||||
|
||||
(defun local-variable-p (name &optional (env *cmp-env*))
|
||||
(let ((record (cmp-env-search-var name env)))
|
||||
(and record (var-p record))))
|
||||
|
||||
(defun symbol-macro-p (name &optional (env *cmp-env*))
|
||||
(let ((record (cmp-env-search-var name env)))
|
||||
(and record (not (var-p record)))))
|
||||
|
||||
;;;
|
||||
;;; Check if the symbol has a symbol macro
|
||||
;;;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue