mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

Remove "free" field of $fun

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-03-26 14:10:09 +01:00
parent 34ff3af9f0
commit 50fcdfece3
18 changed files with 65 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

16
module/language/cps.scm
View file

@ -71,7 +71,7 @@
;;; That's to say that a $fun can be matched like this: ;;; That's to say that a $fun can be matched like this:
;;; ;;;
;;; (match f ;;; (match f
;;; (($ $fun free ;;; (($ $fun
;;; ($ $cont kfun ;;; ($ $cont kfun
;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail)) ;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
;;; ($ $kclause arity ;;; ($ $kclause arity
@ -189,7 +189,7 @@
;; Expressions. ;; Expressions.
(define-cps-type $const val) (define-cps-type $const val)
(define-cps-type $prim name) (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 $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order. (define-cps-type $closure label nfree) ; First-order.
(define-cps-type $branch k exp) (define-cps-type $branch k exp)
@ -268,7 +268,7 @@
((_ (unquote exp)) exp) ((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val)) ((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name)) ((_ ($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)) ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
((_ ($closure k nfree)) (make-$closure k nfree)) ((_ ($closure k nfree)) (make-$closure k nfree))
((_ ($call proc (unquote args))) (make-$call proc args)) ((_ ($call proc (unquote args))) (make-$call proc args))
@ -381,8 +381,8 @@
(build-cps-exp ($const exp))) (build-cps-exp ($const exp)))
(('prim name) (('prim name)
(build-cps-exp ($prim name))) (build-cps-exp ($prim name)))
(('fun free body) (('fun body)
(build-cps-exp ($fun free ,(parse-cps body)))) (build-cps-exp ($fun ,(parse-cps body))))
(('closure k nfree) (('closure k nfree)
(build-cps-exp ($closure k nfree))) (build-cps-exp ($closure k nfree)))
(('rec (name sym fun) ...) (('rec (name sym fun) ...)
@ -439,8 +439,8 @@
`(const ,val)) `(const ,val))
(($ $prim name) (($ $prim name)
`(prim ,name)) `(prim ,name))
(($ $fun free body) (($ $fun body)
`(fun ,free ,(unparse-cps body))) `(fun ,(unparse-cps body)))
(($ $closure k nfree) (($ $closure k nfree)
`(closure ,k ,nfree)) `(closure ,k ,nfree))
(($ $rec names syms funs) (($ $rec names syms funs)
@ -490,7 +490,7 @@
(define (fun-folder fun seed ...) (define (fun-folder fun seed ...)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(cont-folder body seed ...)))) (cont-folder body seed ...))))
(define (term-folder term seed ...) (define (term-folder term seed ...)

8
module/language/cps/arities.scm
View file

@ -133,16 +133,16 @@
($ $prim) ($ $prim)
($ $values (_))) ($ $values (_)))
,(adapt-exp 1 k src exp)) ,(adapt-exp 1 k src exp))
(($ $fun free body) (($ $fun body)
,(adapt-exp 1 k src (build-cps-exp ,(adapt-exp 1 k src (build-cps-exp
($fun free ,(fix-arities* body dfg))))) ($fun ,(fix-arities* body dfg)))))
(($ $rec names syms funs) (($ $rec names syms funs)
;; Assume $rec expressions have the correct arity. ;; Assume $rec expressions have the correct arity.
($continue k src ($continue k src
($rec names syms (map (lambda (fun) ($rec names syms (map (lambda (fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(fix-arities* body dfg))))) ($fun ,(fix-arities* body dfg)))))
funs)))) funs))))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that

8
module/language/cps/closure-conversion.scm
View file

@ -99,14 +99,14 @@
(union (visit-cont cont bound) free)) (union (visit-cont cont bound) free))
(visit-term body bound) (visit-term body bound)
conts)) conts))
(($ $continue k src ($ $fun () body)) (($ $continue k src ($ $fun body))
(match (lookup-predecessors k dfg) (match (lookup-predecessors k dfg)
((_) (match (lookup-cont k dfg) ((_) (match (lookup-cont k dfg)
(($ $kargs (name) (var)) (($ $kargs (name) (var))
(add-named-fun! var body)))) (add-named-fun! var body))))
(_ #f)) (_ #f))
(visit-cont body bound)) (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)) (hashq-set! letrec-conts k (lookup-cont k dfg))
(let ((bound (append vars bound))) (let ((bound (append vars bound)))
(for-each add-named-fun! vars cont) (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))) (($ $continue k src (or ($ $const) ($ $prim)))
term) term)
(($ $continue k src ($ $fun () ($ $cont kfun))) (($ $continue k src ($ $fun ($ $cont kfun)))
(let ((fun-free (hashq-ref free-vars kfun))) (let ((fun-free (hashq-ref free-vars kfun)))
(match (cons (well-known? kfun) fun-free) (match (cons (well-known? kfun) fun-free)
((known?) ((known?)
@ -479,7 +479,7 @@ bound to @var{var}, and continue with @var{body}."
(visit-term body))))) (visit-term body)))))
(match in (match in
(() (bindings body)) (() (bindings body))
(((name var ($ $fun () (((name var ($ $fun
(and fun-body (and fun-body
($ $cont kfun ($ $kfun src))))) . in) ($ $cont kfun ($ $kfun src))))) . in)
(let ((fun-free (hashq-ref free-vars kfun))) (let ((fun-free (hashq-ref free-vars kfun)))

4
module/language/cps/constructors.scm
View file

@ -94,8 +94,8 @@
,term))) ,term)))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(inline-constructors* body))))) ($fun ,(inline-constructors* body)))))
(visit-cont fun)) (visit-cont fun))

14
module/language/cps/contification.scm
View file

@ -216,7 +216,7 @@
(define (visit-fun term) (define (visit-fun term)
(match term (match term
(($ $fun free body) (($ $fun body)
(visit-cont body)))) (visit-cont body))))
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
@ -236,7 +236,7 @@
(visit-term body term-k)) (visit-term body term-k))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun free (($ $fun
($ $cont fun-k ($ $cont fun-k
($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause))) ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
(if (and=> (bound-symbol k) (if (and=> (bound-symbol k)
@ -261,7 +261,7 @@
(if (null? rec) (if (null? rec)
'() '()
(list rec))) (list rec)))
(((and elt (n s ($ $fun free ($ $cont kfun)))) (((and elt (n s ($ $fun ($ $cont kfun))))
. nsf) . nsf)
(if (recursive? kfun) (if (recursive? kfun)
(lp nsf (cons elt rec)) (lp nsf (cons elt rec))
@ -273,7 +273,7 @@
(match component (match component
(((name sym fun) ...) (((name sym fun) ...)
(match fun (match fun
((($ $fun free ((($ $fun
($ $cont fun-k ($ $cont fun-k
($ $kfun src meta self ($ $cont tail-k ($ $ktail)) ($ $kfun src meta self ($ $cont tail-k ($ $ktail))
clause))) clause)))
@ -342,8 +342,8 @@
,body))))))) ,body)))))))
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (rewrite-cps-exp term
(($ $fun free body) (($ $fun body)
($fun free ,(visit-cont body))))) ($fun ,(visit-cont body)))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont label ($ $kargs names syms body)) (($ $cont label ($ $kargs names syms body))
@ -381,7 +381,7 @@
(splice-continuations (splice-continuations
term-k term-k
(match exp (match exp
(($ $fun free (($ $fun
($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k)))) ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
;; If the function's tail continuation has been substituted, ;; If the function's tail continuation has been substituted,
;; that means it has been contified. ;; that means it has been contified.

6
module/language/cps/cse.scm
View file

@ -287,7 +287,7 @@ could be that both true and false proofs are available."
(match exp (match exp
(($ $const val) (cons 'const val)) (($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name)) (($ $prim name) (cons 'prim name))
(($ $fun free body) #f) (($ $fun body) #f)
(($ $rec names syms funs) #f) (($ $rec names syms funs) #f)
(($ $call proc args) #f) (($ $call proc args) #f)
(($ $callk k 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) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun (map subst-var free) ,(cse body dfg))))) ($fun ,(cse body dfg)))))
(define (visit-exp* k src exp) (define (visit-exp* k src exp)
(match exp (match exp

12
module/language/cps/dce.scm
View file

@ -199,13 +199,13 @@
(match exp (match exp
((or ($ $const) ($ $prim)) ((or ($ $const) ($ $prim))
#f) #f)
(($ $fun free body) (($ $fun body)
(visit-fun body)) (visit-fun body))
(($ $rec names syms funs) (($ $rec names syms funs)
(for-each (lambda (sym fun) (for-each (lambda (sym fun)
(when (value-live? sym) (when (value-live? sym)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(visit-fun body))))) (visit-fun body)))))
syms funs)) syms funs))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
@ -320,20 +320,20 @@
(($ $continue k src exp) (($ $continue k src exp)
(if (bitvector-ref live-conts (label->idx term-k)) (if (bitvector-ref live-conts (label->idx term-k))
(match exp (match exp
(($ $fun free body) (($ $fun body)
(build-cps-term (build-cps-term
($continue k src ($fun free ,(visit-fun body))))) ($continue k src ($fun ,(visit-fun body)))))
(($ $rec names syms funs) (($ $rec names syms funs)
(rewrite-cps-term (rewrite-cps-term
(filter-map (filter-map
(lambda (name sym fun) (lambda (name sym fun)
(and (value-live? sym) (and (value-live? sym)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(list name (list name
sym sym
(build-cps-exp (build-cps-exp
($fun free ,(visit-fun body)))))))) ($fun ,(visit-fun body))))))))
names syms funs) names syms funs)
(() (()
($continue k src ($values ()))) ($continue k src ($values ())))

6
module/language/cps/dfg.scm
View file

@ -660,7 +660,7 @@ body continuation in the prompt."
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(use! tag) (use! tag)
(link-blocks! label handler)) (link-blocks! label handler))
(($ $fun free body) (($ $fun body)
(when global? (when global?
(visit-fun body))) (visit-fun body)))
(($ $rec names syms funs) (($ $rec names syms funs)
@ -668,7 +668,7 @@ body continuation in the prompt."
(error "$rec should not be present when building a local DFG")) (error "$rec should not be present when building a local DFG"))
(for-each (lambda (fun) (for-each (lambda (fun)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(visit-fun body)))) (visit-fun body))))
funs)))) funs))))
@ -748,7 +748,7 @@ body continuation in the prompt."
(match exp (match exp
(($ $const val) (format port "const ~@y" val)) (($ $const val) (format port "const ~@y" val))
(($ $prim name) (format port "prim ~a" name)) (($ $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)) (($ $rec names syms funs) (format port "rec~{ v~a~}" syms))
(($ $closure label nfree) (format port "closure k~a (~a free)" label nfree)) (($ $closure label nfree) (format port "closure k~a (~a free)" label nfree))
(($ $call proc args) (format port "call~{ v~a~}" (cons proc args))) (($ $call proc args) (format port "call~{ v~a~}" (cons proc args)))

4
module/language/cps/elide-values.scm
View file

@ -98,8 +98,8 @@
,term))) ,term)))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free cont) (($ $fun cont)
($fun free ,(visit-cont cont))))) ($fun ,(visit-cont cont)))))
(visit-cont fun)) (visit-cont fun))

4
module/language/cps/prune-bailouts.scm
View file

@ -87,8 +87,8 @@
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(prune-bailouts* body))))) ($fun ,(prune-bailouts* body)))))
(rewrite-cps-cont fun (rewrite-cps-cont fun
(($ $cont kfun (($ $cont kfun

2
module/language/cps/prune-top-level-scopes.scm
View file

@ -81,7 +81,7 @@
(_ #t))))) (_ #t)))))
(define (visit-fun fun) (define (visit-fun fun)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(visit-cont body)))) (visit-cont body))))
(visit-cont fun) (visit-cont fun)

8
module/language/cps/renumber.scm
View file

@ -219,14 +219,14 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body reachable?)) (visit-term body reachable?))
(($ $continue k src ($ $fun free body)) (($ $continue k src ($ $fun body))
(when reachable? (when reachable?
(set! queue (cons body queue)))) (set! queue (cons body queue))))
(($ $continue k src ($ $rec names syms funs)) (($ $continue k src ($ $rec names syms funs))
(when reachable? (when reachable?
(set! queue (fold (lambda (fun queue) (set! queue (fold (lambda (fun queue)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(cons body queue)))) (cons body queue))))
queue queue
funs)))) funs))))
@ -327,8 +327,8 @@
($prompt escape? (rename tag) (relabel handler)))))) ($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun (map rename free) ,(must-visit-cont body))))) ($fun ,(must-visit-cont body)))))
(match term (match term
(($ $cont) (($ $cont)

8
module/language/cps/self-references.scm
View file

@ -54,8 +54,8 @@
(define (visit-exp exp) (define (visit-exp exp)
(rewrite-cps-exp exp (rewrite-cps-exp exp
((or ($ $const) ($ $prim)) ,exp) ((or ($ $const) ($ $prim)) ,exp)
(($ $fun free body) (($ $fun body)
($fun free ,(resolve-self-references body env))) ($fun ,(resolve-self-references body env)))
(($ $rec names vars funs) (($ $rec names vars funs)
($rec names vars (map visit-recursive-fun funs vars))) ($rec names vars (map visit-recursive-fun funs vars)))
(($ $call proc args) (($ $call proc args)
@ -73,7 +73,7 @@
(define (visit-recursive-fun fun var) (define (visit-recursive-fun fun var)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free (and cont ($ $cont _ ($ $kfun src meta self)))) (($ $fun (and cont ($ $cont _ ($ $kfun src meta self))))
($fun free ,(resolve-self-references cont (acons var self env)))))) ($fun ,(resolve-self-references cont (acons var self env))))))
(visit-cont fun)) (visit-cont fun))

18
module/language/cps/simplify.scm
View file

@ -61,7 +61,7 @@
#f))) #f)))
(define (visit-fun fun) (define (visit-fun fun)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(visit-cont body)))) (visit-cont body))))
(visit-cont fun) (visit-cont fun)
table)) table))
@ -139,8 +139,8 @@
($continue (reduce k scope) src ,exp)))) ($continue (reduce k scope) src ,exp))))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(visit-cont body #f))))) ($fun ,(visit-cont body #f)))))
(visit-cont fun #f))) (visit-cont fun #f)))
(define (compute-beta-reductions fun) (define (compute-beta-reductions fun)
@ -189,7 +189,7 @@
#f))) #f)))
(define (visit-fun fun) (define (visit-fun fun)
(match fun (match fun
(($ $fun free body) (($ $fun body)
(visit-cont body)))) (visit-cont body))))
(visit-cont fun) (visit-cont fun)
(values var-table k-table))) (values var-table k-table)))
@ -253,8 +253,8 @@
(build-cps-exp ($prompt escape? (subst tag) handler))))) (build-cps-exp ($prompt escape? (subst tag) handler)))))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun (map subst free) ,(must-visit-cont body))))) ($fun ,(must-visit-cont body)))))
(must-visit-cont fun))) (must-visit-cont fun)))
;; Rewrite the scope tree to reflect the dominator tree. Precondition: ;; Rewrite the scope tree to reflect the dominator tree. Precondition:
@ -281,12 +281,12 @@
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(visit-fun-cont body))))) ($fun ,(visit-fun-cont body)))))
(define (visit-exp k src exp) (define (visit-exp k src exp)
(rewrite-cps-term exp (rewrite-cps-term exp
(($ $fun free body) (($ $fun body)
($continue k src ,(visit-fun exp))) ($continue k src ,(visit-fun exp)))
(($ $rec names syms funs) (($ $rec names syms funs)
($continue k src ($rec names syms (map visit-fun funs)))) ($continue k src ($rec names syms (map visit-fun funs))))

4
module/language/cps/specialize-primcalls.scm
View file

@ -101,7 +101,7 @@
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(visit-cont body))))) ($fun ,(visit-cont body)))))
(visit-cont fun)))) (visit-cont fun))))

4
module/language/cps/type-fold.scm
View file

@ -430,8 +430,8 @@
(_ ,term))) (_ ,term)))
(define (visit-fun fun) (define (visit-fun fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun free body) (($ $fun body)
($fun free ,(fold-constants* body dfg))))) ($fun ,(fold-constants* body dfg)))))
(rewrite-cps-cont fun (rewrite-cps-cont fun
(($ $cont kfun ($ $kfun src meta self tail clause)) (($ $cont kfun ($ $kfun src meta self tail clause))
(kfun ($kfun src meta self ,tail ,(visit-cont clause)))))))))) (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))

3
module/language/cps/verify.scm
View file

@ -127,8 +127,7 @@
(define (visit-fun fun k-env v-env) (define (visit-fun fun k-env v-env)
(match fun (match fun
(($ $fun (free ...) entry) (($ $fun entry)
(for-each (cut check-var <> v-env) free)
(visit-entry entry '() v-env)) (visit-entry entry '() v-env))
(_ (_
(error "unexpected $fun" fun)))) (error "unexpected $fun" fun))))

2
module/language/tree-il/compile-cps.scm
View file

@ -296,7 +296,7 @@
(let-fresh (kfun ktail) (self) (let-fresh (kfun ktail) (self)
(build-cps-term (build-cps-term
($continue k fun-src ($continue k fun-src
($fun '() ($fun
(kfun ($kfun fun-src meta self (ktail ($ktail)) (kfun ($kfun fun-src meta self (ktail ($ktail))
,(convert-clauses body ktail))))))) ,(convert-clauses body ktail)))))))
(let ((scope-id (fresh-scope-id))) (let ((scope-id (fresh-scope-id)))