This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b9a5bac69082114a75278c0d0fceedab787dbf7c The branch, master has been updated via b9a5bac69082114a75278c0d0fceedab787dbf7c (commit) via ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31 (commit) via 44954194c936bee2f2faa4225480cb9dd2cbdcd8 (commit) via 7700e67226e76eb53ceef12368992161243b59df (commit) from 6fc634f8a378475efa336afadb8cef26807bd0cb (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit b9a5bac69082114a75278c0d0fceedab787dbf7c Author: Andy Wingo <[email protected]> Date: Sun Jul 20 20:52:06 2014 +0200 Better simplification of literal constants that continue to branches * module/language/cps/simplify.scm (eta-reduce): Constants that continue to branches eta-reduce to the true or false branch. commit ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31 Author: Andy Wingo <[email protected]> Date: Sun Jul 20 20:19:01 2014 +0200 CPS will not see "not" primcalls * module/language/tree-il/compile-cps.scm (convert): Remove "not" primcalls. * module/language/cps/effects-analysis.scm (values): * module/language/cps/types.scm: Remove special cases for the "not" primcall. commit 44954194c936bee2f2faa4225480cb9dd2cbdcd8 Author: Andy Wingo <[email protected]> Date: Sun Jul 6 12:38:26 2014 +0200 Simplify pass rewrite scope tree to reflect dominator tree * module/language/cps/simplify.scm (redominate): Add micropass to rewrite the scope tree to reflect the dominator tree. Will enable better eta reduction. commit 7700e67226e76eb53ceef12368992161243b59df Author: Andy Wingo <[email protected]> Date: Sun Jul 6 12:17:58 2014 +0200 Remove dead case in CSE * module/language/cps/cse.scm (apply-cse): Remove a case that couldn't occur. ----------------------------------------------------------------------- Summary of changes: module/language/cps/cse.scm | 2 - module/language/cps/effects-analysis.scm | 3 +- module/language/cps/simplify.scm | 99 +++++++++++++++++++++++++++++- module/language/cps/types.scm | 17 ----- module/language/tree-il/compile-cps.scm | 9 +++ 5 files changed, 107 insertions(+), 23 deletions(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 204480e..3a03ede 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -445,8 +445,6 @@ could be that both true and false proofs are available." (define (visit-fun-cont cont) (rewrite-cps-cont cont - (($ $cont label ($ $kargs names vars body)) - (label ($kargs names vars ,(visit-term body label)))) (($ $cont label ($ $kfun src meta self tail clause)) (label ($kfun src meta self ,tail ,(and clause (visit-fun-cont clause))))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index d59283c..246b22e 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -256,8 +256,7 @@ is or might be a read or a write to the same location as A." ;; Miscellaneous. (define-primitive-effects - ((values . _)) - ((not arg))) + ((values . _))) ;; Generic effect-free predicates. (define-primitive-effects diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 5185889..2c33edd 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -85,6 +85,30 @@ (reduce* k scope #f)) (define (reduce-values k scope) (reduce* k scope #t)) + (define (reduce-const k src scope const) + (let lp ((k k) (seen '()) (const const)) + (match (lookup-cont k dfg) + (($ $kargs (_) (arg) term) + (match (find-call term) + (($ $continue k* src* ($ $values (arg*))) + (and (eqv? arg arg*) + (not (memq k* seen)) + (lp k* (cons k seen) const))) + (($ $continue k* src* ($ $primcall 'not (arg*))) + (and (eqv? arg arg*) + (not (memq k* seen)) + (lp k* (cons k seen) (not const)))) + (($ $continue k* src* ($ $branch kt ($ $values (arg*)))) + (and (eqv? arg arg*) + (let ((k* (if const kt k*))) + (and (continuation-bound-in? k* scope dfg) + (build-cps-term + ($continue k* src ($values ()))))))) + (_ + (and (continuation-bound-in? k scope dfg) + (build-cps-term + ($continue k src ($const const))))))) + (_ #f)))) (define (visit-cont cont scope) (rewrite-cps-cont cont (($ $cont sym ($ $kargs names syms body)) @@ -104,11 +128,15 @@ ,(visit-term body scope))) (($ $letrec names syms funs body) ($letrec names syms (map visit-fun funs) - ,(visit-term body scope))) + ,(visit-term body scope))) (($ $continue k src ($ $values args)) ($continue (reduce-values k scope) src ($values args))) (($ $continue k src (and fun ($ $fun))) ($continue (reduce k scope) src ,(visit-fun fun))) + (($ $continue k src ($ $const const)) + ,(let ((k (reduce k scope))) + (or (reduce-const k src scope const) + (build-cps-term ($continue k src ($const const)))))) (($ $continue k src exp) ($continue (reduce k scope) src ,exp)))) (define (visit-fun fun) @@ -234,7 +262,74 @@ ($fun (map subst free) ,(must-visit-cont body))))) (must-visit-cont fun))) +;; Rewrite the scope tree to reflect the dominator tree. Precondition: +;; the fun has been renumbered, its min-label is 0, and its labels are +;; packed. +(define (redominate fun) + (let* ((dfg (compute-dfg fun)) + (idoms (compute-idoms dfg 0 (dfg-label-count dfg))) + (doms (compute-dom-edges idoms 0))) + (define (visit-fun-cont cont) + (rewrite-cps-cont cont + (($ $cont label ($ $kfun src meta self tail clause)) + (label ($kfun src meta self ,tail + ,(and clause (visit-fun-cont clause))))) + (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) + (label ($kclause ,arity ,(visit-cont kbody body) + ,(and alternate (visit-fun-cont alternate))))))) + + (define (visit-cont label cont) + (rewrite-cps-cont cont + (($ $kargs names vars body) + (label ($kargs names vars ,(visit-term body label)))) + (_ (label ,cont)))) + + (define (visit-exp k src exp) + (rewrite-cps-term exp + (($ $fun free body) + ($continue k src ($fun free ,(visit-fun-cont body)))) + (_ + ($continue k src ,exp)))) + + (define (visit-term term label) + (define (visit-dom-conts label) + (let ((cont (lookup-cont label dfg))) + (match cont + (($ $ktail) '()) + (($ $kargs) (list (visit-cont label cont))) + (else + (cons (visit-cont label cont) + (visit-dom-conts* (vector-ref doms label))))))) + + (define (visit-dom-conts* labels) + (match labels + (() '()) + ((label . labels) + (append (visit-dom-conts label) + (visit-dom-conts* labels))))) + + (rewrite-cps-term term + (($ $letk conts body) + ,(visit-term body label)) + (($ $letrec names syms funs body) + ($letrec names syms (let lp ((funs funs)) + (match funs + (() '()) + ((($ $fun free body) . funs) + (cons (build-cps-exp + ($fun free ,(visit-fun-cont body))) + (lp funs))))) + ,(visit-term body label))) + (($ $continue k src exp) + ,(let ((conts (visit-dom-conts* (vector-ref doms label)))) + (if (null? conts) + (visit-exp k src exp) + (build-cps-term + ($letk ,conts ,(visit-exp k src exp)))))))) + + (visit-fun-cont fun))) + (define (simplify fun) ;; Renumbering prunes continuations that are made unreachable by ;; eta/beta reductions. - (renumber (eta-reduce (beta-reduce fun)))) + (redominate (renumber (eta-reduce (beta-reduce fun))))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 677f542..2a21925 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -450,23 +450,6 @@ minimum, and maximum." ;;; -;;; Miscellaneous. -;;; - -(define-simple-type-checker (not &all-types)) -(define-type-inferrer (not val result) - (cond - ((and (eqv? (&type val) &boolean) - (eqv? (&min val) (&max val))) - (let ((val (if (zero? (&min val)) 1 0))) - (define! result &boolean val val))) - (else - (define! result &boolean 0 1)))) - - - - -;;; ;;; Generic effect-free predicates. ;;; diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index d81a82c..3822316 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -363,6 +363,15 @@ (kf ($kargs () () ($continue k src ($const #f))))) ($continue kf src ($branch kt ($primcall name args))))))))) + ((and (eq? name 'not) (match args ((_) #t) (_ #f))) + (convert-args args + (lambda (args) + (let-fresh (kt kf) () + (build-cps-term + ($letk ((kt ($kargs () () ($continue k src ($const #f)))) + (kf ($kargs () () ($continue k src ($const #t))))) + ($continue kf src + ($branch kt ($values args))))))))) ((and (eq? name 'list) (and-map (match-lambda ((or ($ <const>) hooks/post-receive -- GNU Guile
