[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/09: Verify pass works on first-order CPS
From: |
Andy Wingo |
Subject: |
[Guile-commits] 07/09: Verify pass works on first-order CPS |
Date: |
Wed, 15 Jul 2015 07:51:39 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit bf5c7954ffdfe33d88ed7fe2d89ded338d82c1f9
Author: Andy Wingo <address@hidden>
Date: Tue Jul 14 16:10:58 2015 +0200
Verify pass works on first-order CPS
* module/language/cps2/verify.scm: Work with first-order CPS.
---
module/language/cps2/verify.scm | 113 +++++++++++++++++++++++++-------------
1 files changed, 74 insertions(+), 39 deletions(-)
diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm
index 8d55042..c833d0d 100644
--- a/module/language/cps2/verify.scm
+++ b/module/language/cps2/verify.scm
@@ -128,75 +128,110 @@ definitions that are available at LABEL."
(define (check-valid-var-uses conts kfun)
(define (adjoin-def var defs) (intset-add defs var))
- (let visit-fun ((kfun kfun) (free empty-intset))
- (define (visit-exp exp bound)
+ (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
+ (define (visit-exp exp bound first-order)
(define (check-use var)
(unless (intset-ref bound var)
(error "unbound var" var)))
+ (define (visit-first-order kfun)
+ (if (intset-ref first-order kfun)
+ first-order
+ (visit-fun kfun empty-intset (intset-add first-order kfun))))
(match exp
- ((or ($ $const) ($ $prim)) #t)
+ ((or ($ $const) ($ $prim)) first-order)
;; todo: $closure
(($ $fun kfun)
- (visit-fun kfun bound))
+ (visit-fun kfun bound first-order))
+ (($ $closure kfun)
+ (visit-first-order kfun))
(($ $rec names vars (($ $fun kfuns) ...))
(let ((bound (fold1 adjoin-def vars bound)))
- (for-each (lambda (kfun) (visit-fun kfun bound)) kfuns)))
+ (fold1 (lambda (kfun first-order)
+ (visit-fun kfun bound first-order))
+ kfuns first-order)))
(($ $values args)
- (for-each check-use args))
+ (for-each check-use args)
+ first-order)
(($ $call proc args)
(check-use proc)
- (for-each check-use args))
- (($ $callk k proc args)
+ (for-each check-use args)
+ first-order)
+ (($ $callk kfun proc args)
(check-use proc)
- (for-each check-use args))
+ (for-each check-use args)
+ (visit-first-order kfun))
(($ $branch kt ($ $values (arg)))
- (check-use arg))
+ (check-use arg)
+ first-order)
(($ $branch kt ($ $primcall name args))
- (for-each check-use args))
+ (for-each check-use args)
+ first-order)
(($ $primcall name args)
- (for-each check-use args))
+ (for-each check-use args)
+ first-order)
(($ $prompt escape? tag handler)
- (check-use tag))))
- (intmap-for-each
- (lambda (label bound)
+ (check-use tag)
+ first-order)))
+ (intmap-fold
+ (lambda (label bound first-order)
(let ((bound (intset-union free bound)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
- (visit-exp exp (fold1 adjoin-def vars bound)))
- (_ #t))))
- (compute-available-definitions conts kfun))))
+ (visit-exp exp (fold1 adjoin-def vars bound) first-order))
+ (_ first-order))))
+ (compute-available-definitions conts kfun)
+ first-order)))
-(define (fold-nested-funs f conts kfun seed)
- (intset-fold
- (lambda (label seed)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _ ($ $fun label)))
- (f label seed))
- (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun label) ...))))
- (fold1 f label seed))
- (_ seed)))
- (compute-function-body conts kfun)
- seed))
+(define (reachable-functions conts kfun)
+ (worklist-fold*
+ (lambda (kfun kfuns)
+ ;(pk 'verify kfun kfuns)
+ (let ((kfuns (intset-add kfuns kfun)))
+ (values (intset-fold
+ (lambda (label nested)
+ (define (return kfun*)
+ ;(pk 'return label kfuns kfun* nested)
+ (append (filter (lambda (kfun)
+ (not (intset-ref kfuns kfun)))
+ kfun*)
+ nested))
+ (define (return1 kfun) (return (list kfun)))
+ (define (return0) (return '()))
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ (($ $fun label) (return1 label))
+ (($ $rec _ _ (($ $fun labels) ...)) (return labels))
+ (($ $closure label nfree) (return1 label))
+ (($ $callk label) (return1 label))
+ (_ (return0))))
+ (_ (return0))))
+ (compute-function-body conts kfun)
+ '())
+ kfuns)))
+ (intset kfun)
+ empty-intset))
(define (check-label-partition conts kfun)
;; A continuation can only belong to one function.
- (let visit-fun ((kfun kfun) (seen empty-intmap))
- (fold-nested-funs
- visit-fun
- conts
- kfun
+ (intset-fold
+ (lambda (kfun seen)
(intset-fold
(lambda (label seen)
(intmap-add seen label kfun
(lambda (old new)
(error "label used by two functions" label old new))))
(compute-function-body conts kfun)
- seen))))
+ seen))
+ (reachable-functions conts kfun)
+ empty-intmap))
(define (compute-reachable-labels conts kfun)
- (let visit-fun ((kfun kfun) (seen empty-intset))
- (fold-nested-funs visit-fun conts kfun
- (intset-union seen (compute-function-body conts kfun)))))
+ (intset-fold
+ (lambda (kfun seen)
+ (intset-union seen (compute-function-body conts kfun)))
+ (reachable-functions conts kfun)
+ empty-intset))
(define (check-arities conts kfun)
(define (check-arity exp cont)
- [Guile-commits] branch master updated (dbe6247 -> 981802c), Andy Wingo, 2015/07/15
- [Guile-commits] 01/09: Reorganizing of intset/intmap helper functions, Andy Wingo, 2015/07/15
- [Guile-commits] 02/09: intset-union fast paths, Andy Wingo, 2015/07/15
- [Guile-commits] 03/09: Fix intset-subtract to reliably produce empty-intset, Andy Wingo, 2015/07/15
- [Guile-commits] 04/09: CPS2 renumber works with first-order CPS, Andy Wingo, 2015/07/15
- [Guile-commits] 05/09: Tweak intset printing, Andy Wingo, 2015/07/15
- [Guile-commits] 06/09: Beginnings of first-order CPS optimization, Andy Wingo, 2015/07/15
- [Guile-commits] 07/09: Verify pass works on first-order CPS,
Andy Wingo <=
- [Guile-commits] 09/09: Wire up new closure conversion pass, Andy Wingo, 2015/07/15
- [Guile-commits] 08/09: Add CPS2 closure conversion module, Andy Wingo, 2015/07/15