diff options
author | Andy Wingo <wingo@pobox.com> | 2015-03-26 14:10:09 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-04-01 10:10:10 +0200 |
commit | 50fcdfece306a437ebad326679245e206cfbe6b2 (patch) | |
tree | 97c6ccaf97d3548550bdf4f495dec7a0d0b2bc88 | |
parent | 34ff3af9f0024c6d5163f422ca5e1202a560efe3 (diff) | |
download | guile-50fcdfece306a437ebad326679245e206cfbe6b2.tar.gz |
Remove "free" field of $fun
* module/language/cps.scm ($fun): Remove unused "free" field.
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/type-fold.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt all callers.
-rw-r--r-- | module/language/cps.scm | 16 | ||||
-rw-r--r-- | module/language/cps/arities.scm | 8 | ||||
-rw-r--r-- | module/language/cps/closure-conversion.scm | 8 | ||||
-rw-r--r-- | module/language/cps/constructors.scm | 4 | ||||
-rw-r--r-- | module/language/cps/contification.scm | 14 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 6 | ||||
-rw-r--r-- | module/language/cps/dce.scm | 12 | ||||
-rw-r--r-- | module/language/cps/dfg.scm | 6 | ||||
-rw-r--r-- | module/language/cps/elide-values.scm | 4 | ||||
-rw-r--r-- | module/language/cps/prune-bailouts.scm | 4 | ||||
-rw-r--r-- | module/language/cps/prune-top-level-scopes.scm | 2 | ||||
-rw-r--r-- | module/language/cps/renumber.scm | 8 | ||||
-rw-r--r-- | module/language/cps/self-references.scm | 8 | ||||
-rw-r--r-- | module/language/cps/simplify.scm | 18 | ||||
-rw-r--r-- | module/language/cps/specialize-primcalls.scm | 4 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 4 | ||||
-rw-r--r-- | module/language/cps/verify.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 2 |
18 files changed, 65 insertions, 66 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm index 3e0748ff5..befa20f66 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -71,7 +71,7 @@ ;;; That's to say that a $fun can be matched like this: ;;; ;;; (match f -;;; (($ $fun free +;;; (($ $fun ;;; ($ $cont kfun ;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail)) ;;; ($ $kclause arity @@ -189,7 +189,7 @@ ;; Expressions. (define-cps-type $const val) (define-cps-type $prim name) -(define-cps-type $fun free body) ; Higher-order. +(define-cps-type $fun body) ; Higher-order. (define-cps-type $rec names syms funs) ; Higher-order. (define-cps-type $closure label nfree) ; First-order. (define-cps-type $branch k exp) @@ -268,7 +268,7 @@ ((_ (unquote exp)) exp) ((_ ($const val)) (make-$const val)) ((_ ($prim name)) (make-$prim name)) - ((_ ($fun free body)) (make-$fun free (build-cps-cont body))) + ((_ ($fun body)) (make-$fun (build-cps-cont body))) ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs)) ((_ ($closure k nfree)) (make-$closure k nfree)) ((_ ($call proc (unquote args))) (make-$call proc args)) @@ -381,8 +381,8 @@ (build-cps-exp ($const exp))) (('prim name) (build-cps-exp ($prim name))) - (('fun free body) - (build-cps-exp ($fun free ,(parse-cps body)))) + (('fun body) + (build-cps-exp ($fun ,(parse-cps body)))) (('closure k nfree) (build-cps-exp ($closure k nfree))) (('rec (name sym fun) ...) @@ -439,8 +439,8 @@ `(const ,val)) (($ $prim name) `(prim ,name)) - (($ $fun free body) - `(fun ,free ,(unparse-cps body))) + (($ $fun body) + `(fun ,(unparse-cps body))) (($ $closure k nfree) `(closure ,k ,nfree)) (($ $rec names syms funs) @@ -490,7 +490,7 @@ (define (fun-folder fun seed ...) (match fun - (($ $fun free body) + (($ $fun body) (cont-folder body seed ...)))) (define (term-folder term seed ...) diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm index 7448eb006..fa7cc1418 100644 --- a/module/language/cps/arities.scm +++ b/module/language/cps/arities.scm @@ -133,16 +133,16 @@ ($ $prim) ($ $values (_))) ,(adapt-exp 1 k src exp)) - (($ $fun free body) + (($ $fun body) ,(adapt-exp 1 k src (build-cps-exp - ($fun free ,(fix-arities* body dfg))))) + ($fun ,(fix-arities* body dfg))))) (($ $rec names syms funs) ;; Assume $rec expressions have the correct arity. ($continue k src ($rec names syms (map (lambda (fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(fix-arities* body dfg))))) + (($ $fun body) + ($fun ,(fix-arities* body dfg))))) funs)))) ((or ($ $call) ($ $callk)) ;; In general, calls have unknown return arity. For that diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 8848e0725..49ff30f93 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -99,14 +99,14 @@ (union (visit-cont cont bound) free)) (visit-term body bound) conts)) - (($ $continue k src ($ $fun () body)) + (($ $continue k src ($ $fun body)) (match (lookup-predecessors k dfg) ((_) (match (lookup-cont k dfg) (($ $kargs (name) (var)) (add-named-fun! var body)))) (_ #f)) (visit-cont body bound)) - (($ $continue k src ($ $rec names vars (($ $fun () cont) ...))) + (($ $continue k src ($ $rec names vars (($ $fun cont) ...))) (hashq-set! letrec-conts k (lookup-cont k dfg)) (let ((bound (append vars bound))) (for-each add-named-fun! vars cont) @@ -443,7 +443,7 @@ bound to @var{var}, and continue with @var{body}." (($ $continue k src (or ($ $const) ($ $prim))) term) - (($ $continue k src ($ $fun () ($ $cont kfun))) + (($ $continue k src ($ $fun ($ $cont kfun))) (let ((fun-free (hashq-ref free-vars kfun))) (match (cons (well-known? kfun) fun-free) ((known?) @@ -479,7 +479,7 @@ bound to @var{var}, and continue with @var{body}." (visit-term body))))) (match in (() (bindings body)) - (((name var ($ $fun () + (((name var ($ $fun (and fun-body ($ $cont kfun ($ $kfun src))))) . in) (let ((fun-free (hashq-ref free-vars kfun))) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm index 1416f1782..bbe779d27 100644 --- a/module/language/cps/constructors.scm +++ b/module/language/cps/constructors.scm @@ -94,8 +94,8 @@ ,term))) (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(inline-constructors* body))))) + (($ $fun body) + ($fun ,(inline-constructors* body))))) (visit-cont fun)) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 88bc097b0..1f702310a 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -216,7 +216,7 @@ (define (visit-fun term) (match term - (($ $fun free body) + (($ $fun body) (visit-cont body)))) (define (visit-cont cont) (match cont @@ -236,7 +236,7 @@ (visit-term body term-k)) (($ $continue k src exp) (match exp - (($ $fun free + (($ $fun ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause))) (if (and=> (bound-symbol k) @@ -261,7 +261,7 @@ (if (null? rec) '() (list rec))) - (((and elt (n s ($ $fun free ($ $cont kfun)))) + (((and elt (n s ($ $fun ($ $cont kfun)))) . nsf) (if (recursive? kfun) (lp nsf (cons elt rec)) @@ -273,7 +273,7 @@ (match component (((name sym fun) ...) (match fun - ((($ $fun free + ((($ $fun ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause))) @@ -342,8 +342,8 @@ ,body))))))) (define (visit-fun term) (rewrite-cps-exp term - (($ $fun free body) - ($fun free ,(visit-cont body))))) + (($ $fun body) + ($fun ,(visit-cont body))))) (define (visit-cont cont) (rewrite-cps-cont cont (($ $cont label ($ $kargs names syms body)) @@ -381,7 +381,7 @@ (splice-continuations term-k (match exp - (($ $fun free + (($ $fun ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k)))) ;; If the function's tail continuation has been substituted, ;; that means it has been contified. diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 3534596c5..c8a57ca0b 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -287,7 +287,7 @@ could be that both true and false proofs are available." (match exp (($ $const val) (cons 'const val)) (($ $prim name) (cons 'prim name)) - (($ $fun free body) #f) + (($ $fun body) #f) (($ $rec names syms funs) #f) (($ $call proc args) #f) (($ $callk k proc args) #f) @@ -469,8 +469,8 @@ could be that both true and false proofs are available." (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun (map subst-var free) ,(cse body dfg))))) + (($ $fun body) + ($fun ,(cse body dfg))))) (define (visit-exp* k src exp) (match exp diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 0be9d61c4..34ffc3a47 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -199,13 +199,13 @@ (match exp ((or ($ $const) ($ $prim)) #f) - (($ $fun free body) + (($ $fun body) (visit-fun body)) (($ $rec names syms funs) (for-each (lambda (sym fun) (when (value-live? sym) (match fun - (($ $fun free body) + (($ $fun body) (visit-fun body))))) syms funs)) (($ $prompt escape? tag handler) @@ -320,20 +320,20 @@ (($ $continue k src exp) (if (bitvector-ref live-conts (label->idx term-k)) (match exp - (($ $fun free body) + (($ $fun body) (build-cps-term - ($continue k src ($fun free ,(visit-fun body))))) + ($continue k src ($fun ,(visit-fun body))))) (($ $rec names syms funs) (rewrite-cps-term (filter-map (lambda (name sym fun) (and (value-live? sym) (match fun - (($ $fun free body) + (($ $fun body) (list name sym (build-cps-exp - ($fun free ,(visit-fun body)))))))) + ($fun ,(visit-fun body)))))))) names syms funs) (() ($continue k src ($values ()))) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm index 6cba7649f..22bc15900 100644 --- a/module/language/cps/dfg.scm +++ b/module/language/cps/dfg.scm @@ -660,7 +660,7 @@ body continuation in the prompt." (($ $prompt escape? tag handler) (use! tag) (link-blocks! label handler)) - (($ $fun free body) + (($ $fun body) (when global? (visit-fun body))) (($ $rec names syms funs) @@ -668,7 +668,7 @@ body continuation in the prompt." (error "$rec should not be present when building a local DFG")) (for-each (lambda (fun) (match fun - (($ $fun free body) + (($ $fun body) (visit-fun body)))) funs)))) @@ -748,7 +748,7 @@ body continuation in the prompt." (match exp (($ $const val) (format port "const ~@y" val)) (($ $prim name) (format port "prim ~a" name)) - (($ $fun free ($ $cont kbody)) (format port "fun k~a" kbody)) + (($ $fun ($ $cont kbody)) (format port "fun k~a" kbody)) (($ $rec names syms funs) (format port "rec~{ v~a~}" syms)) (($ $closure label nfree) (format port "closure k~a (~a free)" label nfree)) (($ $call proc args) (format port "call~{ v~a~}" (cons proc args))) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm index 100ad1f5b..dadbd403a 100644 --- a/module/language/cps/elide-values.scm +++ b/module/language/cps/elide-values.scm @@ -98,8 +98,8 @@ ,term))) (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free cont) - ($fun free ,(visit-cont cont))))) + (($ $fun cont) + ($fun ,(visit-cont cont))))) (visit-cont fun)) diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm index cc0c08bc7..c224f4531 100644 --- a/module/language/cps/prune-bailouts.scm +++ b/module/language/cps/prune-bailouts.scm @@ -87,8 +87,8 @@ (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(prune-bailouts* body))))) + (($ $fun body) + ($fun ,(prune-bailouts* body))))) (rewrite-cps-cont fun (($ $cont kfun diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm index f300db408..4839b71f7 100644 --- a/module/language/cps/prune-top-level-scopes.scm +++ b/module/language/cps/prune-top-level-scopes.scm @@ -81,7 +81,7 @@ (_ #t))))) (define (visit-fun fun) (match fun - (($ $fun free body) + (($ $fun body) (visit-cont body)))) (visit-cont fun) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index 58968a7bb..8a1c7a0f2 100644 --- a/module/language/cps/renumber.scm +++ b/module/language/cps/renumber.scm @@ -219,14 +219,14 @@ (($ $letk conts body) (for-each visit-cont conts) (visit-term body reachable?)) - (($ $continue k src ($ $fun free body)) + (($ $continue k src ($ $fun body)) (when reachable? (set! queue (cons body queue)))) (($ $continue k src ($ $rec names syms funs)) (when reachable? (set! queue (fold (lambda (fun queue) (match fun - (($ $fun free body) + (($ $fun body) (cons body queue)))) queue funs)))) @@ -327,8 +327,8 @@ ($prompt escape? (rename tag) (relabel handler)))))) (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun (map rename free) ,(must-visit-cont body))))) + (($ $fun body) + ($fun ,(must-visit-cont body))))) (match term (($ $cont) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm index 6cf2545ec..45e2389ff 100644 --- a/module/language/cps/self-references.scm +++ b/module/language/cps/self-references.scm @@ -54,8 +54,8 @@ (define (visit-exp exp) (rewrite-cps-exp exp ((or ($ $const) ($ $prim)) ,exp) - (($ $fun free body) - ($fun free ,(resolve-self-references body env))) + (($ $fun body) + ($fun ,(resolve-self-references body env))) (($ $rec names vars funs) ($rec names vars (map visit-recursive-fun funs vars))) (($ $call proc args) @@ -73,7 +73,7 @@ (define (visit-recursive-fun fun var) (rewrite-cps-exp fun - (($ $fun free (and cont ($ $cont _ ($ $kfun src meta self)))) - ($fun free ,(resolve-self-references cont (acons var self env)))))) + (($ $fun (and cont ($ $cont _ ($ $kfun src meta self)))) + ($fun ,(resolve-self-references cont (acons var self env)))))) (visit-cont fun)) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 8f3b63078..10e9d0aa2 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -61,7 +61,7 @@ #f))) (define (visit-fun fun) (match fun - (($ $fun free body) + (($ $fun body) (visit-cont body)))) (visit-cont fun) table)) @@ -139,8 +139,8 @@ ($continue (reduce k scope) src ,exp)))) (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(visit-cont body #f))))) + (($ $fun body) + ($fun ,(visit-cont body #f))))) (visit-cont fun #f))) (define (compute-beta-reductions fun) @@ -189,7 +189,7 @@ #f))) (define (visit-fun fun) (match fun - (($ $fun free body) + (($ $fun body) (visit-cont body)))) (visit-cont fun) (values var-table k-table))) @@ -253,8 +253,8 @@ (build-cps-exp ($prompt escape? (subst tag) handler))))) (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun (map subst free) ,(must-visit-cont body))))) + (($ $fun body) + ($fun ,(must-visit-cont body))))) (must-visit-cont fun))) ;; Rewrite the scope tree to reflect the dominator tree. Precondition: @@ -281,12 +281,12 @@ (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(visit-fun-cont body))))) + (($ $fun body) + ($fun ,(visit-fun-cont body))))) (define (visit-exp k src exp) (rewrite-cps-term exp - (($ $fun free body) + (($ $fun body) ($continue k src ,(visit-fun exp))) (($ $rec names syms funs) ($continue k src ($rec names syms (map visit-fun funs)))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 3a840dd07..e5b76fb13 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -101,7 +101,7 @@ (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(visit-cont body))))) + (($ $fun body) + ($fun ,(visit-cont body))))) (visit-cont fun)))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index c13f7fb43..ba66ec3ff 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -430,8 +430,8 @@ (_ ,term))) (define (visit-fun fun) (rewrite-cps-exp fun - (($ $fun free body) - ($fun free ,(fold-constants* body dfg))))) + (($ $fun body) + ($fun ,(fold-constants* body dfg))))) (rewrite-cps-cont fun (($ $cont kfun ($ $kfun src meta self tail clause)) (kfun ($kfun src meta self ,tail ,(visit-cont clause)))))))))) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index e10cf8319..6c2310737 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -127,8 +127,7 @@ (define (visit-fun fun k-env v-env) (match fun - (($ $fun (free ...) entry) - (for-each (cut check-var <> v-env) free) + (($ $fun entry) (visit-entry entry '() v-env)) (_ (error "unexpected $fun" fun)))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 65bec09b5..4e515f763 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -296,7 +296,7 @@ (let-fresh (kfun ktail) (self) (build-cps-term ($continue k fun-src - ($fun '() + ($fun (kfun ($kfun fun-src meta self (ktail ($ktail)) ,(convert-clauses body ktail))))))) (let ((scope-id (fresh-scope-id))) |