mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-15 09:20:23 -07:00
Implemented an experimental (and still incomplete) phase for type propagation.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
aebe505993
commit
a33f442197
3 changed files with 237 additions and 2 deletions
|
|
@ -488,6 +488,9 @@ coprocessor).")
|
|||
|
||||
;;; --cmptop.lsp--
|
||||
;;;
|
||||
(defvar *do-type-propagation* nil
|
||||
"Flag for switching on the type propagation phase. Use with care, experimental.")
|
||||
|
||||
(defvar *compiler-phase* nil)
|
||||
|
||||
(defvar *volatile*)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,218 @@
|
|||
|
||||
(in-package "COMPILER")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;
|
||||
;;; TYPE PROPAGATION LOOP
|
||||
;;;
|
||||
;;;
|
||||
;;; ALL C1FORMS: Intermediate language used by the compiler
|
||||
;;;
|
||||
;;; (LOCATION loc)
|
||||
;;; (VAR var)
|
||||
;;; (SETQ var value-c1form)
|
||||
;;; (PSETQ var-list value-c1form-list)
|
||||
;;; (BLOCK blk-var progn-c1form)
|
||||
;;; (PROGN body)
|
||||
;;; (TAGBODY tag-var tag-body)
|
||||
;;; (DECL-BODY declaration-list progn-c1form)
|
||||
;;; (RETURN-FROM blk-var return-type value)
|
||||
;;; (FUNCALL fun-value (arg-value*))
|
||||
;;; (CALL-LOCAL obj-fun (arg-value*))
|
||||
;;; (CALL-GLOBAL fun-name (arg-value*))
|
||||
;;; (CATCH catch-value body)
|
||||
;;; (UNWIND-PROTECT protected-c1form body)
|
||||
;;; (THROW catch-value output-value)
|
||||
;;; (GO tag-var return-type)
|
||||
;;; (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)
|
||||
;;; (IF fmla-c1form true-c1form false-c1form)
|
||||
;;; (FMLA-NOT fmla-c1form)
|
||||
;;; (LAMBDA lambda-list doc body-c1form)
|
||||
;;; (LET vars-list var-init-c1form-list decl-body-c1form)
|
||||
;;; (LET* vars-list var-init-c1form-list decl-body-c1form)
|
||||
;;; (VALUES values-c1form-list)
|
||||
;;; (MULTIPLE-VALUE-SETQ vars-list values-c1form-list)
|
||||
;;; (MULTIPLE-VALUE-BIND vars-list init-c1form body)
|
||||
;;; (COMPILER-LET symbols values body)
|
||||
;;; (FUNCTION {GLOBAL|CLOSURE} lambda-form fun-object)
|
||||
;;;
|
||||
;;; (C2PRINC object-string-or-char stream-var stream-c1form)
|
||||
;;; (RPLACA dest-c1form value-c1form)
|
||||
;;; (RPLACD dest-c1form value-c1form)
|
||||
;;; (MEMBER!2 fun-symbol args-c1form-list)
|
||||
;;; (ASSOC!2 fun-symbol args-c1form-list)
|
||||
;;;
|
||||
;;; (SI:STRUCTURE-REF struct-c1form type-name slot-index {:UNSAFE|NIL})
|
||||
;;; (SI:STRUCTURE-SET struct-c1form type-name slot-index value-c1form)
|
||||
;;;
|
||||
;;; (WITH-STACK body)
|
||||
;;; (STACK-PUSH-VALUES value-c1form push-statement-c1form)
|
||||
;;;
|
||||
;;; (ORDINARY c1form)
|
||||
;;; (LOAD-TIME-VALUE dest-loc value-c1form)
|
||||
;;; (FSET function-object vv-loc, macro-p pprint-p lambda-form)
|
||||
;;; (MAKE-FORM vv-loc value-c1form)
|
||||
;;; (INIT-FORM vv-loc value-c1form)
|
||||
;;;
|
||||
;;; body = (c1form*)
|
||||
;;; tag-body = ({c1form | tag}*)
|
||||
;;; return-type = {CLB | CCB | UNWIND-PROTECT}
|
||||
;;; *value = c1form
|
||||
;;; lambda-list = (requireds optionals rest key-flag keywords allow-other-keys)
|
||||
;;;
|
||||
;;;
|
||||
|
||||
(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) type)))
|
||||
(format t "~&;;; Querying variable ~A gives ~A" (var-name var) type)
|
||||
(values (setf (c1form-type form) type) assumptions)))
|
||||
((setf propagator (get-sysprop name 'p1propagate))
|
||||
(multiple-value-bind (type assumptions)
|
||||
(apply propagator form assumptions (c1form-args form))
|
||||
(format t "~&;;; Propagating ~A gives type ~A" name type)
|
||||
(values (setf (c1form-type form) (values-type-and (c1form-type form) type))
|
||||
assumptions)))
|
||||
(t
|
||||
(format t "~&;;; Refusing to propagate ~A" name type)
|
||||
(values (c1form-type form) 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 p1expand-assumptions (var type assumptions)
|
||||
(unless (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED))
|
||||
(format t "~&;;; Adding variable ~A with type ~A" (var-name var) type)
|
||||
(unless (var-functions-setting var)
|
||||
(format t "~&;;; 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))))
|
||||
|
||||
#+nil
|
||||
(trace c::p1propagate c::p1progate-list c::p1expand-assumptions
|
||||
c::p1call-global)
|
||||
|
||||
(defun p1block (c1form assumptions blk body)
|
||||
(multiple-value-bind (normal-type assumptions)
|
||||
(p1propagate body assumptions)
|
||||
(values (type-or (blk-type blk) normal-type)
|
||||
assumptions)))
|
||||
|
||||
(defun p1call-global (c1form assumptions fname args &optional (return-type t))
|
||||
(print args)
|
||||
(loop for v in args
|
||||
do (multiple-value-bind (arg-type local-ass)
|
||||
(p1propagate v assumptions)
|
||||
(setf assumptions local-ass))
|
||||
finally (let ((type (propagate-types fname args nil)))
|
||||
(format t "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A"
|
||||
fname (mapcar #'c1form-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))
|
||||
(values t assumptions))
|
||||
|
||||
(defun p1decl-body (c1form assumptions decls body)
|
||||
(p1propagate body assumptions))
|
||||
|
||||
(defun p1if (c1form assumptions fmla true-branch false-branch)
|
||||
(multiple-value-bind (fmla-type assumptions)
|
||||
(p1propagate fmla assumptions)
|
||||
(let ((t1 (p1propagate true-branch assumptions))
|
||||
(t2 (p1propagate false-branch assumptions)))
|
||||
(values (type-or t1 t2) assumptions))))
|
||||
|
||||
(defun p1lambda (c1form assumptions lambda-list doc body &rest not-used)
|
||||
(format t "~&;;;~&;;; Propagating function~&;;;")
|
||||
(let ((type (p1propagate body assumptions)))
|
||||
(values type assumptions)))
|
||||
|
||||
(defun p1let (c1form assumptions vars forms body)
|
||||
(let ((new-assumptions assumptions))
|
||||
(loop for v in vars
|
||||
for f in forms
|
||||
do (multiple-value-bind (type ass)
|
||||
(p1propagate f assumptions)
|
||||
(setf new-assumptions (p1expand-assumptions v type new-assumptions))))
|
||||
(multiple-value-bind (type assumptions)
|
||||
(p1propagate body new-assumptions)
|
||||
(values (setf (c1form-type c1form) type)
|
||||
assumptions))))
|
||||
|
||||
(defun p1let* (c1form assumptions vars forms body)
|
||||
(loop for v in vars
|
||||
for f in forms
|
||||
do (multiple-value-bind (type ass)
|
||||
(p1propagate f assumptions)
|
||||
(setf assumptions (p1expand-assumptions v type assumptions))))
|
||||
(multiple-value-bind (type assumptions)
|
||||
(p1propagate body assumptions)
|
||||
(values (setf (c1form-type c1form) type)
|
||||
assumptions)))
|
||||
|
||||
(defun p1locals (c1form assumptions funs body labels)
|
||||
(loop for f in funs
|
||||
do (p1propagate funs assumptions))
|
||||
(p1propagate-list body assumptions))
|
||||
|
||||
(defun p1progn (c1form assumptions forms)
|
||||
(p1propagate-list forms assumptions))
|
||||
|
||||
(defun p1setq (c1form assumptions var c1form)
|
||||
(multiple-value-bind (value-type assumptions)
|
||||
(p1propagate c1form assumptions)
|
||||
(let ((type (type-and (var-type var) value-type)))
|
||||
(values type (p1expand-assumptions var type assumptions)))))
|
||||
|
||||
(defun p1tagbody (c1form assumptions tag-loc body)
|
||||
(loop with local-ass = assumptions
|
||||
for f in body
|
||||
do (if (tag-p f)
|
||||
(setf local-ass assumptions)
|
||||
(multiple-value-setq (aux local-ass) (p1propagate f local-ass))))
|
||||
(values 'null assumptions))
|
||||
|
||||
(defun p1unwind-protect (c1form assumptions form body)
|
||||
(multiple-value-bind (output-type assumptions)
|
||||
(p1propagate form assumptions)
|
||||
(p1propagate-list body assumptions)
|
||||
(values output-type assumptions)))
|
||||
|
||||
(put-sysprop 'BLOCK 'P1PROPAGATE 'p1block)
|
||||
(put-sysprop 'call-global 'p1propagate 'p1call-global)
|
||||
(put-sysprop 'CATCH 'P1PROPAGATE 'p1catch)
|
||||
(put-sysprop 'decl-body 'p1propagate 'p1decl-body)
|
||||
(put-sysprop 'if 'p1propagate #'p1if)
|
||||
(put-sysprop 'LAMBDA 'P1PROPAGATE 'p1lambda)
|
||||
(put-sysprop 'LET 'P1PROPAGATE 'p1let)
|
||||
(put-sysprop 'LET* 'P1PROPAGATE 'p1let*)
|
||||
(put-sysprop 'LOCALS 'p1propagate 'p1locals)
|
||||
(put-sysprop 'PROGN 'P1PROPAGATE 'p1progn)
|
||||
(put-sysprop 'SETQ 'p1propagate 'p1setq)
|
||||
(put-sysprop 'tagbody 'p1propagate 'p1tagbody)
|
||||
(put-sysprop 'UNWIND-PROTECT 'P1PROPAGATE 'p1unwind-protect)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun type-from-array-elt (array)
|
||||
"Input is a lisp type representing a valid subtype of ARRAY. Output is
|
||||
either the array element type or NIL, denoting that we are not able to
|
||||
|
|
@ -71,7 +283,7 @@ compute it. This version only handles the simplest cases."
|
|||
(setf upgraded-type (upgraded-array-element-type upgraded-type))
|
||||
(cmpnote "Unknown element type ~A passed to MAKE-ARRAY" upgraded-type)))
|
||||
(unless (eq guess-dims '*)
|
||||
(if (listp gues-dims)
|
||||
(if (listp guess-dims)
|
||||
(setf guess-dims (make-list (length guess-dims) :initial-element '*))
|
||||
(setf guess-dims '(*))))
|
||||
(setf type (list type upgraded-type guess-dims))
|
||||
|
|
|
|||
|
|
@ -166,10 +166,19 @@
|
|||
(wt-nl "memcpy(VV, data->vector.self.t, VM*sizeof(cl_object));}"))
|
||||
(wt-nl "VVtemp = Cblock->cblock.temp_data;")
|
||||
|
||||
;; Type propagation phase
|
||||
|
||||
(when *do-type-propagation*
|
||||
(setq *compiler-phase* 'p1propagate)
|
||||
(dolist (form *top-level-forms*)
|
||||
(p1propagate form nil))
|
||||
(dolist (fun *local-funs*)
|
||||
(p1propagate (fun-lambda fun) nil)))
|
||||
|
||||
(setq *compiler-phase* 't2)
|
||||
|
||||
;; useless in initialization.
|
||||
(dolist (form (nconc (nreverse *make-forms*) *top-level-forms*))
|
||||
(dolist (form (nconc (reverse *make-forms*) *top-level-forms*))
|
||||
(let* ((*compile-to-linking-call* nil)
|
||||
(*compile-file-truename* (and form (c1form-file form)))
|
||||
(*compile-file-position* (and form (c1form-file-position form)))
|
||||
|
|
@ -451,6 +460,9 @@
|
|||
(*compile-time-too* nil))
|
||||
(add-load-time-values (make-c1form* 'ORDINARY :args (c1expr form)))))
|
||||
|
||||
(defun p1ordinary (c1form assumptions form)
|
||||
(p1propagate form assumptions))
|
||||
|
||||
(defun t2ordinary (form)
|
||||
(let* ((*exit* (next-label))
|
||||
(*unwind-exit* (list *exit*))
|
||||
|
|
@ -741,6 +753,9 @@
|
|||
(c1expr pprint))))))))
|
||||
(c1call-global 'SI:FSET (list fname def macro pprint))))
|
||||
|
||||
(defun p1fset (c1form assumptions fun fname macro pprint c1forms)
|
||||
(p1propagate (fun-lambda fun) assumptions))
|
||||
|
||||
(defun c2fset (fun fname macro pprint c1forms)
|
||||
(when (fun-no-entry fun)
|
||||
(wt-nl "(void)0; /* No entry created for "
|
||||
|
|
@ -796,6 +811,11 @@
|
|||
(put-sysprop 'LOAD-TIME-VALUE 'C1 'c1load-time-value)
|
||||
(put-sysprop 'SI:FSET 'C1 'c1fset)
|
||||
|
||||
;;; Pass 1 1/2 type propagation
|
||||
|
||||
(put-sysprop 'ORDINARY 'P1PROPAGATE 'p1ordinary)
|
||||
(put-sysprop 'SI:FSET 'P1PROPAGATE 'p1fset)
|
||||
|
||||
;;; Pass 2 initializers.
|
||||
|
||||
(put-sysprop 'COMPILER-LET 'T2 't2compiler-let)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue