mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
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.
This commit is contained in:
Andy Wingo
parent
34ff3af9f0
commit
50fcdfece3
18 changed files with 65 additions and 66 deletions
|
|
@ -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 ...)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ())))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@
|
|||
(_ #t)))))
|
||||
(define (visit-fun fun)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(($ $fun body)
|
||||
(visit-cont body))))
|
||||
|
||||
(visit-cont fun)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue