diff --git a/module/language/cps.scm b/module/language/cps.scm index e6cb3cbd6..ddda6ff50 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -215,10 +215,7 @@ body ...)) (define-syntax-rule (with-fresh-name-state fun body ...) - (call-with-values (lambda () - (match fun - (($ $fun free fun-k) - (compute-max-label-and-var fun-k)))) + (call-with-values (lambda () (compute-max-label-and-var fun)) (lambda (max-label max-var) (parameterize ((label-counter (1+ max-label)) (var-counter (1+ max-var))) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 479a5906f..85bf30ec9 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -275,9 +275,9 @@ convert functions to flat closures." (define (convert-closures exp) "Convert free reference in @var{exp} to primcalls to @code{free-ref}, and allocate and initialize flat closures." - (with-fresh-name-state exp - (match exp - (($ $fun () body) + (match exp + (($ $fun () body) + (with-fresh-name-state body (receive (body free) (cc body #f '()) (unless (null? free) (error "Expected no free vars in toplevel thunk" exp body free)) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm index be1c964d8..e4ab6a9d0 100644 --- a/module/language/cps/constructors.scm +++ b/module/language/cps/constructors.scm @@ -99,5 +99,7 @@ ($fun free ,(visit-cont body))))) (define (inline-constructors fun) - (with-fresh-name-state fun - (inline-constructors* fun))) + (match fun + (($ $fun free body) + (with-fresh-name-state body + (inline-constructors* fun))))) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm index 754bcc7c6..c86702574 100644 --- a/module/language/cps/elide-values.scm +++ b/module/language/cps/elide-values.scm @@ -105,6 +105,6 @@ (define (elide-values fun) (match fun (($ $fun free funk) - (with-fresh-name-state fun + (with-fresh-name-state funk (let ((conts (build-cont-table funk))) (elide-values* fun conts)))))) diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm index 81b2581ef..b241781a9 100644 --- a/module/language/cps/prune-bailouts.scm +++ b/module/language/cps/prune-bailouts.scm @@ -95,5 +95,7 @@ ,(and clause (visit-cont clause ktail)))))))) (define (prune-bailouts fun) - (with-fresh-name-state fun - (prune-bailouts* fun))) + (match fun + (($ $fun free body) + (with-fresh-name-state body + (prune-bailouts* fun))))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index c34d6c600..6a4bea058 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -109,7 +109,7 @@ (define (reify-primitives fun) (match fun (($ $fun free body) - (with-fresh-name-state fun + (with-fresh-name-state body (let ((conts (build-cont-table body))) (define (visit-fun term) (rewrite-cps-exp term