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

Implemented a type propagation phase

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2010-05-26 22:01:55 +02:00
parent 89b99fbcee
commit 3994456543
11 changed files with 155 additions and 180 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/cmp/cmpblock.lsp
View file

@ -40,7 +40,7 @@
;; either NIL or T), we lose a lot of information.
(make-c1form* 'BLOCK
:local-vars (list blk-var)
:type (type-or (blk-type blk) (c1form-type body))
:type (values-type-or (blk-type blk) (c1form-type body))
:args blk body)
body))))
@ -97,7 +97,7 @@
(unw (setf type 'UNWIND-PROTECT
var (blk-var blk))))
(incf (blk-ref blk))
(setf (blk-type blk) (type-or (blk-type blk) (c1form-primary-type val)))
(setf (blk-type blk) (values-type-or (blk-type blk) (c1form-type val)))
(let ((output (make-c1form* 'RETURN-FROM :type 'T
:args blk type val var)))
(when var (add-to-read-nodes var output))

5
src/cmp/cmpform.lsp
View file

@ -54,7 +54,6 @@
(FMLA-AND * :pure)
(FMLA-OR * :pure)
(LAMBDA lambda-list doc body-c1form)
(LET vars-list var-init-c1form-list decl-body-c1form :pure)
(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)
@ -299,8 +298,8 @@
;; Remaining flags are just copied
(setf (c1form-name dest) (c1form-name new-fields)
(c1form-local-vars dest) (c1form-local-vars new-fields)
(c1form-type dest) (type-and (c1form-type new-fields)
(c1form-type dest))
(c1form-type dest) (values-type-and (c1form-type new-fields)
(c1form-type dest))
(c1form-sp-change dest) (c1form-sp-change new-fields)
(c1form-side-effects dest) (c1form-side-effects new-fields)
(c1form-volatile dest) (c1form-volatile new-fields)

2
src/cmp/cmpglobals.lsp
View file

@ -215,7 +215,7 @@ slashes before special characters.")
;;; --cmptop.lsp--
;;;
(defvar *do-type-propagation* nil
(defvar *do-type-propagation* t
"Flag for switching on the type propagation phase. Use with care, experimental.")
(defvar *compiler-phase* nil)

10
src/cmp/cmpif.lsp
View file

@ -28,8 +28,8 @@
(let* ((true-branch (c1expr (second args)))
(false-branch (c1expr (third args))))
(make-c1form* 'IF
:type (type-or (c1form-type true-branch)
(c1form-type false-branch))
:type (values-type-or (c1form-type true-branch)
(c1form-type false-branch))
:args test true-branch false-branch))))
(defun c1not (args)
@ -55,7 +55,7 @@
;; (AND x) => x
(if butlast
(make-c1form* 'FMLA-AND
:type (type-or 'null (c1form-type last))
:type (type-or 'null (c1form-primary-type last))
:args butlast last)
last))))
@ -70,8 +70,8 @@
(if butlast
(make-c1form* 'FMLA-OR
:type (reduce #'type-or butlast
:key #'c1form-type
:initial-value (c1form-type last))
:key #'c1form-primary-type
:initial-value (c1form-primary-type last))
:args butlast last)
last))))

9
src/cmp/cmplet.lsp
View file

@ -200,11 +200,6 @@
(member v (rest i)))
(return t))))
(defun c2let-update-variable-type (var form)
(unless (or (var-set-nodes var)
(unboxed var))
(update-variable-type var (c1form-type form))))
(defun env-grows (possibily)
;; if additional closure variables are introduced and this is not
;; last form, we must use a new env.
@ -237,10 +232,6 @@
(*inline-blocks* 0))
(declare (type boolean block-p))
;; FIXME! Until we switch on the type propagation phase we do
;; this little optimization here
(mapc 'c2let-update-variable-type vars forms)
;; Replace read-only variables when it is worth doing it.
(loop for var in vars
for rest-forms on (append forms (list body))

279
src/cmp/cmpprop.lsp
View file

@ -18,135 +18,83 @@
;;; TYPE PROPAGATION LOOP
;;;
(defvar *type-propagation-messages* t)
(eval-when (eval compile)
(defvar *type-propagation-messages* nil)
(defmacro prop-message (&rest args)
`(when *type-propagation-messages*
(format *standard-output* ,@args))))
(when *type-propagation-messages*
`(format *standard-output* ,@args))))
(defun p1propagate (form assumptions)
(let* ((name (c1form-name form))
(type (c1form-type form))
propagator)
(cond ((eq name 'VAR)
(let* ((var (c1form-arg 0 form))
(record (assoc var assumptions)))
(when record
(setf type (type-and (cdr record) (values-type-primary-type type))))
(prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type)
(values (setf (c1form-type form) type) assumptions)))
((setf propagator (gethash name *p0-dispatch-table*))
(let* ((*cmp-env* (c1form-env form))
(name (c1form-name form))
(propagator (gethash name *p1-dispatch-table*)))
(cond (propagator
(prop-message "~&;;; Entering type propagation for ~A" name)
(multiple-value-bind (type assumptions)
(multiple-value-bind (new-type assumptions)
(apply propagator form assumptions (c1form-args form))
(prop-message "~&;;; Propagating ~A gives type ~A" name type)
(values (setf (c1form-type form) (values-type-and (c1form-type form) type))
assumptions)))
(when assumptions
(baboon :format-control "Non-empty assumptions found in P1PROPAGATE"))
(prop-message "~&;;; Propagating ~A gives type ~A" name
new-type)
(values (setf (c1form-type form)
(values-type-and (c1form-type form)
new-type))
assumptions)))
(t
(prop-message "~&;;; Refusing to propagate ~A" name type)
(cmpnote "Refusing to propagate ~A" name)
(values (c1form-type form) assumptions)))))
(defun p1location (form assumptions loc)
(values (c1form-type form) assumptions))
(defun p1var (form assumptions var)
(let ((record (assoc var assumptions))
;; Use the type of C1FORM because it might have been
;; coerced by a THE form.
(type (c1form-primary-type form)))
(when record
(setf type (type-and (cdr record) (values-type-primary-type type)))
(prop-message "~&;;; Querying variable ~A gives ~A" (var-name var) type))
(values type assumptions)))
(defun p1values (form assumptions values)
(loop for v in values
collect (multiple-value-bind (type new-assumptions)
(p1propagate v assumptions)
(setf assumptions new-assumptions)
(values-type-primary-type type))
into all-values
finally (return (values `(values ,@all-values) assumptions))))
(defun p1propagate-list (list assumptions)
(loop with final-type = t
for f in list
do (multiple-value-setq (final-type assumptions) (p1propagate f assumptions))
finally (return (values final-type assumptions))))
(defun print-assumptions (message assumptions &optional (always-p t))
(when (and always-p (null assumptions))
(prop-message "~&;;; ~A: NIL" message))
(when assumptions
(prop-message "~&;;; ~A:" message))
(dolist (record assumptions)
(prop-message "~&;;; ~A : ~A" (var-name (car record)) (cdr record))))
(defun p1merge-branches (root chains)
"ROOT is a list of assumptions, while CHAINS is list of extended versions of
ROOT. This function takes all those extensions and makes a final list in which
type assumptions have been merged, giving the variables the OR type of each
of the occurrences in those lists."
;; First the simple case in which we only have one list.
(when (null (rest chains))
(setf root (first chains))
(print-assumptions "Only one branch" root)
(return-from p1merge-branches root))
;; When we have to merge more than one list, we use a hash table in which
;; we push all possible assumptions, merging the types with TYPE-OR.
(let* ((all-new-variables (make-hash-table))
(scanned (make-hash-table)))
(print-assumptions "Root branch" root t)
(dolist (l chains)
(print-assumptions "Extra branch" (ldiff l root)))
;; The first pass is filling the hash with unequal assumptions
;; mergin the types
(loop for c in chains
do (clrhash scanned)
do (loop for list on c
for record = (first list)
until (eq list root)
do (let* ((var (car record))
(type (cdr record)))
(unless (gethash var scanned)
(setf (gethash var scanned) type)
(let ((other-type (gethash var all-new-variables :missing)))
(unless (eq other-type :missing)
(setf type (type-or type other-type)))
(setf (gethash var all-new-variables) type))))))
;; While the last pass is extending the list of assumptions with
;; the merged ones.
(loop with new-root = root
for var being the hash-key in all-new-variables
using (hash-value type)
do (setf new-root (acons var type new-root))
finally (progn
(print-assumptions "Output branch" new-root)
(return new-root)))))
(unless (and (null root)
(every #'null chains))
(baboon :format-control "P1MERGE-BRANCHES got a non-empty list of assumptions")))
(defun revise-var-type (variable assumptions where-to-stop)
(unless (member (var-kind variable)
'(LEXICAL CLOSURE SPECIAL GLOBAL) :test #'eql)
(do* ((l assumptions (cdr l))
(variable-type nil))
((or (null l) (eq l where-to-stop))
(prop-message "~&;;; Changing type of variable ~A to ~A"
(var-name variable) variable-type)
(unless variable-type
(error "Variable ~A not found" (var-name variable)))
(setf (var-type variable) variable-type
(var-kind variable) (lisp-type->rep-type variable-type)))
(let ((record (first l)))
(print (list record (eql (car record) variable)))
(when (eql (car record) variable)
(let ((one-type (cdr record)))
(setf variable-type (if variable-type
(type-or variable-type one-type)
one-type))))))))
(defun p1expand-assumptions (var type assumptions)
(unless (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL))
(prop-message "~&;;; Adding variable ~A with type ~A" (var-name var) type)
(unless (or (var-set-nodes var) (var-functions-setting var))
(prop-message "~&;;; Changing type of read-only variable ~A" (var-name var))
(setf (var-type var) type (var-kind var) (lisp-type->rep-type type)))
(setf assumptions (acons var type assumptions))))
(defun p1expand-many (var type assumptions)
(loop for v in var
for v-t in type
do (setf assumptions (p1expand-assumptions v v-t assumptions)))
assumptions)
#+nil
(trace c::p1propagate c::p1progate-list c::p1expand-assumptions
c::p1call-global)
(unless (and (null assumptions) (null where-to-stop))
(baboon :format-control "REVISE-VAR-TYPE got a non-empty list of assumptions")))
(defun p1block (c1form assumptions blk body)
(multiple-value-bind (normal-type assumptions)
(p1propagate body assumptions)
(values (type-or (blk-type blk) normal-type)
(values (values-type-or (blk-type blk) normal-type)
assumptions)))
(defun p1return-from (c1form assumptions blk-var return-type value variable-or-nil)
(p1propagate value assumptions)
(values t assumptions))
(defun p1call-global (c1form assumptions fname args &optional (return-type t))
(loop for v in args
do (multiple-value-bind (arg-type local-ass)
@ -154,13 +102,20 @@ of the occurrences in those lists."
(setf assumptions local-ass))
finally (let ((type (propagate-types fname args)))
(prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A"
fname (mapcar #'c1form-type args) type (c1form-type c1form))
fname (mapcar #'c1form-primary-type args)
type (c1form-type c1form))
(return (values type assumptions)))))
(defun p1catch (c1form assumptions tag body)
(multiple-value-bind (tag-type assumptions)
(p1propagate tag assumptions)
(p1propagate-list body assumptions))
(p1propagate body assumptions))
(values t assumptions))
(defun p1throw (c1form assumptions catch-value output-value)
(multiple-value-bind (type new-assumptions)
(p1propagate catch-value assumptions)
(p1propagate output-value new-assumptions))
(values t assumptions))
(defun p1if (c1form assumptions fmla true-branch false-branch)
@ -170,43 +125,85 @@ of the occurrences in those lists."
(p1propagate true-branch base-assumptions)
(multiple-value-bind (t2 a2)
(p1propagate false-branch base-assumptions)
(values (type-or t1 t2) (p1merge-branches base-assumptions (list a1 a2)))))))
(values (values-type-or t1 t2)
(p1merge-branches base-assumptions (list a1 a2)))))))
(defun p1fmla-not (c1form assumptions form)
(multiple-value-bind (type assumptions)
(p1propagate form assumptions)
(values '(member t nil) assumptions)))
(defun p1fmla-and (c1form orig-assumptions butlast last)
(loop with type = t
with assumptions = orig-assumptions
for form in (append butlast (list last))
collect (progn
(multiple-value-setq (type assumptions)
(p1propagate form assumptions))
assumptions)
into assumptions-list
finally (return (values (type-or 'null (values-type-primary-type type))
(p1merge-branches orig-assumptions
assumptions-list)))))
(defun p1fmla-or (c1form orig-assumptions butlast last)
(loop with type
with output-type = t
with assumptions = orig-assumptions
for form in (append butlast (list last))
collect (progn
(multiple-value-setq (type assumptions)
(p1propagate form assumptions))
(setf output-type (type-or (values-type-primary-type type)
output-type))
assumptions)
into assumptions-list
finally (return (values output-type
(p1merge-branches orig-assumptions
assumptions-list)))))
(defun p1lambda (c1form assumptions lambda-list doc body &rest not-used)
(prop-message "~&;;;~&;;; Propagating function~&;;;")
(let ((type (p1propagate body assumptions)))
(values type assumptions)))
(defun p1propagate-function (fun assumptions)
(p1propagate (fun-lambda fun) assumptions))
(defun p1let* (c1form base-assumptions vars forms body)
(let ((assumptions base-assumptions))
(loop for v in vars
(loop with type
for v in vars
for f in forms
do (multiple-value-bind (type ass)
(p1propagate f assumptions)
(setf assumptions (p1expand-assumptions v type assumptions))))
when (null (var-set-nodes v))
do (progn
(multiple-value-setq (type assumptions) (p1propagate f assumptions))
(setf (var-type v) (type-and (values-type-primary-type type)
(var-type v)))))
(multiple-value-bind (type assumptions)
(p1propagate body assumptions)
(loop for v in vars
do (revise-var-type v assumptions base-assumptions))
(values (setf (c1form-type c1form) type)
assumptions))))
(values type assumptions))))
(defun p1locals (c1form assumptions funs body labels)
(loop for f in funs
do (p1propagate funs assumptions))
(p1propagate-list body assumptions))
do (p1propagate-function f assumptions))
(p1propagate body assumptions))
(defun p1multiple-value-bind (c1form assumptions vars-list init-c1form body)
(multiple-value-bind (init-form-type assumptions)
(p1propagate init-c1form assumptions)
(let ((new-types (values-type-to-n-types init-form-type (length vars-list))))
(p1propagate body (p1expand-many vars-list new-types assumptions)))))
(loop for v in vars-list
for type in (values-type-to-n-types init-form-type (length vars-list))
when (null (var-set-nodes v))
do (setf (var-type v) (type-and (var-type v) type)))
(p1propagate body assumptions)))
(defun p1multiple-value-setq (c1form assumptions vars-list value-c1form)
(multiple-value-bind (init-form-type assumptions)
(p1propagate value-c1form assumptions)
(let ((new-types (values-type-to-n-types init-form-type (length vars-list))))
(values init-form-type (p1expand-many vars-list new-types assumptions)))))
(values init-form-type assumptions)))
(defun p1progn (c1form assumptions forms)
(p1propagate-list forms assumptions))
@ -214,25 +211,28 @@ of the occurrences in those lists."
(defun p1setq (c1form assumptions var c1form)
(multiple-value-bind (value-type assumptions)
(p1propagate c1form assumptions)
(let ((type (type-and (var-type var) (values-type-primary-type value-type))))
(values type (p1expand-assumptions var type assumptions)))))
(values (type-and (var-type var) (values-type-primary-type value-type))
assumptions)))
(defvar *tagbody-depth* -1
"If n > 0, limit the number of passes to converge tagbody forms. If
-1, let the compiler do as many passes as it wishes. Complexity grows
as 2^*tagbody-limit* in the worst cases.")
(defun p1tagbody (c1form assumptions tag-loc body)
(let ((*tagbody-depth* *tagbody-depth*))
(cond ((zerop *tagbody-depth*)
(p1tagbody-simple c1form assumptions tag-loc body))
(t
(setf *tagbody-depth* (1- *tagbody-depth*))
(p1tagbody-many-passes c1form assumptions tag-loc body)))))
(defun p1go (c1form assumptions tag-var return-type)
(values t assumptions))
(defun filter-only-declarations (assumptions)
(when assumptions
(baboon :format-control "FILTER-ONLY-DECLARATIONS gets a non-empty assumption list"))
nil)
(defun p1tagbody (c1form orig-assumptions tag-loc body)
(prop-message "~&;;; P1TAGBODY-SIMPLE pass")
(let* ((assumptions (filter-only-declarations orig-assumptions))
(ass-list (p1tagbody-one-pass c1form assumptions tag-loc body)))
(values 'null (append (p1merge-branches nil ass-list) orig-assumptions))))
(defun p1tagbody-one-pass (c1form assumptions tag-loc body)
(loop with local-ass = assumptions
with ass-list = '()
@ -250,37 +250,10 @@ as 2^*tagbody-limit* in the worst cases.")
(cons diff ass-list)
ass-list)))))
(defun p1tagbody-simple (c1form orig-assumptions tag-loc body)
(prop-message "~&;;; P1TAGBODY-SIMPLE pass")
(print-assumptions "Orig assumptions:" orig-assumptions)
(let* ((assumptions (filter-only-declarations orig-assumptions))
(ass-list (p1tagbody-one-pass c1form assumptions tag-loc body)))
(values 'null (append (p1merge-branches nil ass-list) orig-assumptions))))
(defun p1tagbody-many-passes (c1form orig-assumptions tag-loc body)
(loop with orig-ass-list = '()
with assumptions = orig-assumptions
for i from 0 below 3
for foo = (prop-message "~&;;; P1TAGBODY-MANY-PASSES pass ~D" i)
for ass-list = (p1tagbody-one-pass c1form assumptions tag-loc body)
for faa = (progn
(print-assumptions "Old tagbody assumptions" assumptions)
(pprint ass-list))
for new-assumptions = (nconc (p1merge-branches nil ass-list) orig-assumptions)
for fee = (print-assumptions "New tagbody assumptions" new-assumptions)
for end = (equalp assumptions (setf assumptions new-assumptions))
until end
finally (cond (end
(prop-message "~&;;; P1TAGBODY-MANY-PASSES exists at ~D" i)
(return (values 'null assumptions)))
(t
(prop-message "~&;;; P1TAGBODY-MANY-PASSES refuses at ~D" i)
(p1tagbody-simple c1form orig-assumptions tag-loc body)))))
(defun p1unwind-protect (c1form assumptions form body)
(multiple-value-bind (output-type assumptions)
(p1propagate form assumptions)
(p1propagate-list body assumptions)
(p1propagate body assumptions)
(values output-type assumptions)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

9
src/cmp/cmptables.lsp
View file

@ -188,9 +188,14 @@
(defconstant +p1-dispatch-alist+
'((block . p1block)
(return-from . p1return-from)
(call-global . p1call-global)
(catch . p1catch)
(throw . p1throw)
(if . p1if)
(fmla-not . p1fmla-not)
(fmla-and . p1fmla-and)
(fmla-or . p1fmla-or)
(lambda . p1lambda)
(let* . p1let*)
(locals . p1locals)
@ -199,9 +204,13 @@
(progn . p1progn)
(setq . p1setq)
(tagbody . p1tagbody)
(go . p1go)
(unwind-protect . p1unwind-protect)
(ordinary . p1ordinary)
(si::fset . p1fset)
(var . p1var)
(location . p1location)
(values . p1values)
))
(defun make-dispatch-table (alist)

3
src/cmp/cmptop.lsp
View file

@ -182,7 +182,8 @@
(when *do-type-propagation*
(setq *compiler-phase* 'p1propagate)
(dolist (form *top-level-forms*)
(p1propagate form nil))
(when form
(p1propagate form nil)))
(dolist (fun *local-funs*)
(p1propagate (fun-lambda fun) nil)))

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

@ -103,12 +103,12 @@
t1)
((null tag1)
(setf c::*compiler-break-enable* t)
;(error "foo")
;(break)
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
(setf c::*compiler-break-enable* t)
;(error "foo")
;(break)
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1))))
@ -277,9 +277,11 @@
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
;(break)
(cmpnote "Unknown type ~S" t1)
T)
(t
;(break)
(cmpnote "Unknown type ~S" t2)
T))))

6
src/cmp/cmptypes.lsp
View file

@ -190,7 +190,7 @@
destination ;;; Where the value of the block to go.
var ;;; Variable containing the block ID.
#-new-cmp
(type 'NIL) ;;; Estimated type.
(type '(VALUES &REST T)) ;;; Estimated type.
#+new-cmp
env ;;; Block environment.
)
@ -213,8 +213,8 @@
(defstruct (info)
(local-vars nil) ;;; List of var-objects created directly in the form.
#-new-cmp
(type t) ;;; Type of the form.
#-new-cmp
(type '(VALUES &REST T)) ;;; Type of the form.
(sp-change nil) ;;; Whether execution of the form may change
;;; the value of a special variable.
(volatile nil) ;;; whether there is a possible setjmp. Beppe

2
src/cmp/cmpvar.lsp
View file

@ -67,7 +67,7 @@
(loop for form in (var-read-forms var)
when (and (eq (c1form-name form) 'VAR)
(eq var (c1form-arg 0 form)))
do (setf (c1form-type form) (type-and type (c1form-type form)))
do (setf (c1form-type form) (type-and type (c1form-primary-type form)))
finally (setf (var-type var) type)))))
(defun var-read-forms (var)