From a33f4421972fb24b4543e5aacd0ff53f2a019490 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 5 Jul 2009 09:44:57 +0200 Subject: [PATCH] Implemented an experimental (and still incomplete) phase for type propagation. --- src/cmp/cmpdefs.lsp | 3 + src/cmp/cmpprop.lsp | 214 +++++++++++++++++++++++++++++++++++++++++++- src/cmp/cmptop.lsp | 22 ++++- 3 files changed, 237 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index ee4a7df5e..acb655e8b 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -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*) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 28bb4ae2b..60f5d346b 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -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)) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 2d0293bcb..2a9f8501f 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -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)