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

Optimize C1COMPILER-TYPECASE for the case in which the first form already satisfies the check in the first pass.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2011-12-26 21:58:16 +01:00
parent ecd9dd2470
commit 1a3d3cd2ce
1 changed files with 21 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -16,11 +16,21 @@
(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)))
(first-case (car args)))
;; 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))
(c1progn (cdr first-case))
(let* ((types '())
(expressions (loop for (type . forms) in args
for c1form = (c1progn forms)
for c1form-type = (c1form-primary-type c1form)
do (push c1form-type types)
collect (list type c1form))))
(make-c1form* 'EXT:COMPILER-TYPECASE
:type (reduce #'type-or types)
:args var expressions)))))
(defun c2compiler-typecase (var expressions)
(loop with var-type = (var-type var)
@ -29,10 +39,6 @@
(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
@ -71,10 +77,10 @@
(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))))
(with-clean-symbols (%asserted-value)
`(let* ((%asserted-value ,value))
(declare (:read-only %asserted-value))
,(expand-type-assertion '%asserted-value type env compulsory))))
(compulsory
;; The check has to be produced, independent of the declared
;; value of the variable (for instance, in LAMBDA arguments).
@ -108,6 +114,7 @@
(t
(with-clean-symbols (%checked-value)
`(let* ((%checked-value ,value))
(declare (:read-only %checked-value))
,(expand-type-assertion '%checked-value type env nil)
(the ,type ,value))))))
(the ,type %checked-value))))))