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

Replace all let-gensyms uses with let-fresh

Browse source 
* .dir-locals.el: Add with-fresh-name-state.
* module/language/cps.scm (fresh-label, fresh-var): Signal an error if
  the counters are not initialized.
  (with-fresh-name-state): New macro.
  (make-cont-folder): New macro, generates an n-ary folder.
  (compute-max-label-and-var): New function, uses make-cont-folder.
  (fold-conts): Use make-cont-folder.
  (let-gensyms): Remove.

* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/dce.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/specialize-primcalls.scm: Use let-fresh instead of
  let-gensyms, and wrap in a with-fresh-name-state as needed.

* module/language/tree-il/compile-cps.scm: Remove hack to avoid
  importing let-gensyms from (language tree-il).
This commit is contained in:
Andy Wingo 2014-03-28 16:29:16 +01:00
parent 0534735314
commit 828ed94469
10 changed files with 378 additions and 320 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -13,6 +13,7 @@
(eval . (put 'with-statprof 'scheme-indent-function 1)) (eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms 'scheme-indent-function 1)) (eval . (put 'let-gensyms 'scheme-indent-function 1))
(eval . (put 'let-fresh 'scheme-indent-function 2)) (eval . (put 'let-fresh 'scheme-indent-function 2))
(eval . (put 'with-fresh-name-state 'scheme-indent-function 1))
(eval . (put 'build-cps-term 'scheme-indent-function 0)) (eval . (put 'build-cps-term 'scheme-indent-function 0))
(eval . (put 'build-cps-exp 'scheme-indent-function 0)) (eval . (put 'build-cps-exp 'scheme-indent-function 0))
(eval . (put 'build-cps-cont 'scheme-indent-function 0)) (eval . (put 'build-cps-cont 'scheme-indent-function 0))

87
module/language/cps.scm
View file

@ -107,6 +107,7 @@
#:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:export (;; Helper. #:export (;; Helper.
$arity $arity
make-$arity make-$arity
@ -126,7 +127,8 @@
;; Fresh names. ;; Fresh names.
label-counter var-counter label-counter var-counter
fresh-label fresh-var fresh-label fresh-var
let-fresh let-gensyms with-fresh-name-state compute-max-label-and-var
let-fresh
;; Building macros. ;; Building macros.
build-cps-term build-cps-cont build-cps-exp build-cps-term build-cps-cont build-cps-exp
@ -195,14 +197,16 @@
(define var-counter (make-parameter #f)) (define var-counter (make-parameter #f))
(define (fresh-label) (define (fresh-label)
(let ((count (label-counter))) (let ((count (or (label-counter)
(error "fresh-label outside with-fresh-name-state"))))
(label-counter (1+ count)) (label-counter (1+ count))
count)) count))
;; FIXME: Currently vars and labels need to be unique, so we use the ;; FIXME: Currently vars and labels need to be unique, so we use the
;; label counter. ;; label counter.
(define (fresh-var) (define (fresh-var)
(let ((count (label-counter))) (let ((count (or (label-counter)
(error "fresh-var outside with-fresh-name-state"))))
(label-counter (1+ count)) (label-counter (1+ count))
count)) count))
@ -211,11 +215,17 @@
(var (fresh-var)) ...) (var (fresh-var)) ...)
body ...)) body ...))
(define-syntax let-gensyms ;; FIXME: Same FIXME as above.
(syntax-rules () (define-syntax-rule (with-fresh-name-state fun body ...)
((_ (sym ...) body body* ...) (begin
(let ((sym (gensym (symbol->string 'sym))) ...) (when (or (label-counter) (var-counter))
body body* ...)))) (error "with-fresh-name-state should not be called recursively"))
(call-with-values (lambda ()
(compute-max-label-and-var fun))
(lambda (max-label max-var)
(parameterize ((label-counter (1+ (max max-label max-var)))
(var-counter (1+ (max max-label max-var))))
body ...)))))
(define-syntax build-arity (define-syntax build-arity
(syntax-rules (unquote) (syntax-rules (unquote)
@ -432,42 +442,73 @@
(_ (_
(error "unexpected cps" exp)))) (error "unexpected cps" exp))))
(define (fold-conts proc seed fun) (define-syntax-rule (make-cont-folder seed ...)
(define (cont-folder cont seed) (lambda (proc fun seed ...)
(define (fold-values proc in seed ...)
(if (null? in)
(values seed ...)
(let-values (((seed ...) (proc (car in) seed ...)))
(fold-values proc (cdr in) seed ...))))
(define (cont-folder cont seed ...)
(match cont (match cont
(($ $cont k cont) (($ $cont k cont)
(let ((seed (proc k cont seed))) (let-values (((seed ...) (proc k cont seed ...)))
(match cont (match cont
(($ $kargs names syms body) (($ $kargs names syms body)
(term-folder body seed)) (term-folder body seed ...))
(($ $kentry self tail clauses) (($ $kentry self tail clauses)
(fold cont-folder (cont-folder tail seed) clauses)) (let-values (((seed ...) (cont-folder tail seed ...)))
(fold-values cont-folder clauses seed ...)))
(($ $kclause arity body) (($ $kclause arity body)
(cont-folder body seed)) (cont-folder body seed ...))
(_ seed)))))) (_ (values seed ...)))))))
(define (fun-folder fun seed) (define (fun-folder fun seed ...)
(match fun (match fun
(($ $fun src meta free body) (($ $fun src meta free body)
(cont-folder body seed)))) (cont-folder body seed ...))))
(define (term-folder term seed) (define (term-folder term seed ...)
(match term (match term
(($ $letk conts body) (($ $letk conts body)
(fold cont-folder (term-folder body seed) conts)) (let-values (((seed ...) (term-folder body seed ...)))
(fold-values cont-folder conts seed ...)))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun) (fun-folder exp seed)) (($ $fun) (fun-folder exp seed ...))
(_ seed))) (_ (values seed ...))))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
(fold fun-folder (term-folder body seed) funs)))) (let-values (((seed ...) (term-folder body seed ...)))
(fold-values fun-folder funs seed ...)))))
(fun-folder fun seed)) (fun-folder fun seed ...)))
(define (compute-max-label-and-var fun)
(define (max* var max-var)
(if (number? var)
(max var max-var)
max-var))
((make-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
(($ $kargs names vars)
(fold max* max-var vars))
(($ $kentry self)
(max* self max-var))
(_ max-var))))
fun
-1
-1))
(define (fold-conts proc seed fun)
((make-cont-folder seed) proc fun seed))
(define (fold-local-conts proc seed cont) (define (fold-local-conts proc seed cont)
(define (cont-folder cont seed) (define (cont-folder cont seed)

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

@ -41,7 +41,7 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map fix-arities funs) ,(visit-term body))) ($letrec names syms (map fix-arities* funs) ,(visit-term body)))
(($ $continue k src exp) (($ $continue k src exp)
,(visit-exp k src exp)))) ,(visit-exp k src exp))))
@ -50,7 +50,7 @@
(0 (0
(rewrite-cps-term (lookup-cont k conts) (rewrite-cps-term (lookup-cont k conts)
(($ $ktail) (($ $ktail)
,(let-gensyms (kvoid kunspec unspec) ,(let-fresh (kvoid kunspec) (unspec)
(build-cps-term (build-cps-term
($letk* ((kunspec ($kargs (unspec) (unspec) ($letk* ((kunspec ($kargs (unspec) (unspec)
($continue k src ($continue k src
@ -62,7 +62,7 @@
,(match arity ,(match arity
(($ $arity () () rest () #f) (($ $arity () () rest () #f)
(if rest (if rest
(let-gensyms (knil) (let-fresh (knil) ()
(build-cps-term (build-cps-term
($letk ((knil ($kargs () () ($letk ((knil ($kargs () ()
($continue kargs src ($const '()))))) ($continue kargs src ($const '())))))
@ -70,7 +70,7 @@
(build-cps-term (build-cps-term
($continue kargs src ,exp)))) ($continue kargs src ,exp))))
(_ (_
(let-gensyms (kvoid kvalues void) (let-fresh (kvoid kvalues) (void)
(build-cps-term (build-cps-term
($letk* ((kvalues ($kargs ('void) (void) ($letk* ((kvalues ($kargs ('void) (void)
($continue k src ($continue k src
@ -82,7 +82,7 @@
(($ $kargs () () _) (($ $kargs () () _)
($continue k src ,exp)) ($continue k src ,exp))
(_ (_
,(let-gensyms (k*) ,(let-fresh (k*) ()
(build-cps-term (build-cps-term
($letk ((k* ($kargs () () ($continue k src ($void))))) ($letk ((k* ($kargs () () ($continue k src ($void)))))
($continue k* src ,exp))))))) ($continue k* src ,exp)))))))
@ -93,7 +93,7 @@
(($values (sym)) (($values (sym))
($continue ktail src ($primcall 'return (sym)))) ($continue ktail src ($primcall 'return (sym))))
(_ (_
,(let-gensyms (k* v) ,(let-fresh (k*) (v)
(build-cps-term (build-cps-term
($letk ((k* ($kargs (v) (v) ($letk ((k* ($kargs (v) (v)
($continue k src ($continue k src
@ -103,7 +103,7 @@
,(match arity ,(match arity
(($ $arity (_) () rest () #f) (($ $arity (_) () rest () #f)
(if rest (if rest
(let-gensyms (kval val nil) (let-fresh (kval) (val nil)
(build-cps-term (build-cps-term
($letk ((kval ($kargs ('val) (val) ($letk ((kval ($kargs ('val) (val)
($letconst (('nil nil '())) ($letconst (('nil nil '()))
@ -112,14 +112,14 @@
($continue kval src ,exp)))) ($continue kval src ,exp))))
(build-cps-term ($continue kargs src ,exp)))) (build-cps-term ($continue kargs src ,exp))))
(_ (_
(let-gensyms (kvalues value) (let-fresh (kvalues) (value)
(build-cps-term (build-cps-term
($letk ((kvalues ($kargs ('value) (value) ($letk ((kvalues ($kargs ('value) (value)
($continue k src ($continue k src
($primcall 'values (value)))))) ($primcall 'values (value))))))
($continue kvalues src ,exp))))))) ($continue kvalues src ,exp)))))))
(($ $kargs () () _) (($ $kargs () () _)
,(let-gensyms (k* drop) ,(let-fresh (k*) (drop)
(build-cps-term (build-cps-term
($letk ((k* ($kargs ('drop) (drop) ($letk ((k* ($kargs ('drop) (drop)
($continue k src ($values ()))))) ($continue k src ($values ())))))
@ -135,7 +135,7 @@
($ $values (_))) ($ $values (_)))
,(adapt-exp 1 k src exp)) ,(adapt-exp 1 k src exp))
(($ $fun) (($ $fun)
,(adapt-exp 1 k src (fix-arities exp))) ,(adapt-exp 1 k src (fix-arities* exp)))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to ;; reason every non-tail call has a $kreceive continuation to
@ -158,7 +158,7 @@
(if (and inst (not (eq? inst name))) (if (and inst (not (eq? inst name)))
(build-cps-exp ($primcall inst args)) (build-cps-exp ($primcall inst args))
exp))) exp)))
(let-gensyms (k* p*) (let-fresh (k*) (p*)
(build-cps-term (build-cps-term
($letk ((k* ($kargs ('prim) (p*) ($letk ((k* ($kargs ('prim) (p*)
($continue k src ($call p* args))))) ($continue k src ($call p* args)))))
@ -183,7 +183,11 @@
(($ $cont sym ($ $kentry self tail clauses)) (($ $cont sym ($ $kentry self tail clauses))
(sym ($kentry self ,tail ,(map visit-cont clauses))))))) (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
(define (fix-arities fun) (define (fix-arities* fun)
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun src meta free body)
($fun src meta free ,(fix-clause-arities body))))) ($fun src meta free ,(fix-clause-arities body)))))
(define (fix-arities fun)
(with-fresh-name-state fun
(fix-arities* fun)))

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

@ -60,7 +60,7 @@ called with @var{sym}.
values in the term." values in the term."
(if (memq sym bound) (if (memq sym bound)
(k sym) (k sym)
(let-gensyms (k* sym*) (let-fresh (k*) (sym*)
(receive (exp free) (k sym*) (receive (exp free) (k sym*)
(values (build-cps-term (values (build-cps-term
($letk ((k* ($kargs (sym*) (sym*) ,exp))) ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
@ -86,7 +86,7 @@ values: the term and a list of additional free variables in the term."
label of the outer procedure, where the initialization will be label of the outer procedure, where the initialization will be
performed, and @var{outer-bound} is the list of bound variables there." performed, and @var{outer-bound} is the list of bound variables there."
(fold (lambda (free idx body) (fold (lambda (free idx body)
(let-gensyms (k idxsym) (let-fresh (k) (idxsym)
(build-cps-term (build-cps-term
($letk ((k ($kargs () () ,body))) ($letk ((k ($kargs () () ,body)))
,(convert-free-var ,(convert-free-var
@ -157,7 +157,7 @@ convert functions to flat closures."
(receive (fun-body fun-free) (cc fun-body #f '()) (receive (fun-body fun-free) (cc fun-body #f '())
(lp in (lp in
(lambda (body) (lambda (body)
(let-gensyms (k) (let-fresh (k) ()
(build-cps-term (build-cps-term
($letk ((k ($kargs (name) (sym) ,(bindings body)))) ($letk ((k ($kargs (name) (sym) ,(bindings body))))
($continue k src ($continue k src
@ -180,7 +180,7 @@ convert functions to flat closures."
free)) free))
(_ (_
(values (values
(let-gensyms (kinit v) (let-fresh (kinit) (v)
(build-cps-term (build-cps-term
($letk ((kinit ($kargs (v) (v) ($letk ((kinit ($kargs (v) (v)
,(init-closure ,(init-closure
@ -241,7 +241,7 @@ convert functions to flat closures."
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src ($ $primcall 'free-ref (closure sym))) (($ $continue k src ($ $primcall 'free-ref (closure sym)))
,(let-gensyms (idx) ,(let-fresh () (idx)
(build-cps-term (build-cps-term
($letconst (('idx idx (free-index sym))) ($letconst (('idx idx (free-index sym)))
($continue k src ($primcall 'free-ref (closure idx))))))) ($continue k src ($primcall 'free-ref (closure idx)))))))
@ -268,10 +268,11 @@ convert functions to flat closures."
(define (convert-closures exp) (define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref}, "Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures." and allocate and initialize flat closures."
(with-fresh-name-state exp
(match exp (match exp
(($ $fun src meta () body) (($ $fun src meta () body)
(receive (body free) (cc body #f '()) (receive (body free) (cc body #f '())
(unless (null? free) (unless (null? free)
(error "Expected no free vars in toplevel thunk" exp body free)) (error "Expected no free vars in toplevel thunk" exp body free))
(build-cps-exp (build-cps-exp
($fun src meta free ,(convert-to-indices body free))))))) ($fun src meta free ,(convert-to-indices body free))))))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -29,7 +29,7 @@
#:use-module (language cps) #:use-module (language cps)
#:export (inline-constructors)) #:export (inline-constructors))
(define (inline-constructors fun) (define (inline-constructors* fun)
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
@ -46,10 +46,10 @@
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map inline-constructors funs) ($letrec names syms (map inline-constructors* funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k src ($ $primcall 'list args)) (($ $continue k src ($ $primcall 'list args))
,(let-gensyms (kvalues val) ,(let-fresh (kvalues) (val)
(build-cps-term (build-cps-term
($letk ((kvalues ($kargs ('val) (val) ($letk ((kvalues ($kargs ('val) (val)
($continue k src ($continue k src
@ -60,21 +60,21 @@
(build-cps-term (build-cps-term
($continue k src ($const '())))) ($continue k src ($const '()))))
((arg . args) ((arg . args)
(let-gensyms (ktail tail) (let-fresh (ktail) (tail)
(build-cps-term (build-cps-term
($letk ((ktail ($kargs ('tail) (tail) ($letk ((ktail ($kargs ('tail) (tail)
($continue k src ($continue k src
($primcall 'cons (arg tail)))))) ($primcall 'cons (arg tail))))))
,(lp args ktail))))))))))) ,(lp args ktail)))))))))))
(($ $continue k src ($ $primcall 'vector args)) (($ $continue k src ($ $primcall 'vector args))
,(let-gensyms (kalloc vec len init) ,(let-fresh (kalloc) (vec len init)
(define (initialize args n) (define (initialize args n)
(match args (match args
(() (()
(build-cps-term (build-cps-term
($continue k src ($primcall 'values (vec))))) ($continue k src ($primcall 'values (vec)))))
((arg . args) ((arg . args)
(let-gensyms (knext idx) (let-fresh (knext) (idx)
(build-cps-term (build-cps-term
($letk ((knext ($kargs () () ($letk ((knext ($kargs () ()
,(initialize args (1+ n))))) ,(initialize args (1+ n)))))
@ -89,10 +89,14 @@
($continue kalloc src ($continue kalloc src
($primcall 'make-vector (len init)))))))) ($primcall 'make-vector (len init))))))))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(inline-constructors fun))) ($continue k src ,(inline-constructors* fun)))
(($ $continue) (($ $continue)
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun src meta free body)
($fun src meta free ,(visit-cont body))))) ($fun src meta free ,(visit-cont body)))))
(define (inline-constructors fun)
(with-fresh-name-state fun
(inline-constructors* fun)))

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

@ -174,6 +174,7 @@
(values fun-data-table live-vars))) (values fun-data-table live-vars)))
(define (eliminate-dead-code fun) (define (eliminate-dead-code fun)
(with-fresh-name-state fun
(call-with-values (lambda () (compute-live-code fun)) (call-with-values (lambda () (compute-live-code fun))
(lambda (fun-data-table live-vars) (lambda (fun-data-table live-vars)
(define (value-live? sym) (define (value-live? sym)
@ -226,7 +227,7 @@
(let ((defs (vector-ref defs n))) (let ((defs (vector-ref defs n)))
(if (and-map value-live? defs) (if (and-map value-live? defs)
(list (build-cps-cont (sym ,cont))) (list (build-cps-cont (sym ,cont)))
(let-gensyms (adapt) (let-fresh (adapt) ()
(list (make-adaptor adapt kargs defs) (list (make-adaptor adapt kargs defs)
(build-cps-cont (build-cps-cont
(sym ($kreceive req rest adapt)))))))) (sym ($kreceive req rest adapt))))))))
@ -270,7 +271,7 @@
(build-cps-term (build-cps-term
($continue k src ,exp))) ($continue k src ,exp)))
(syms (syms
(let-gensyms (adapt) (let-fresh (adapt) ()
(build-cps-term (build-cps-term
($letk (,(make-adaptor adapt k syms)) ($letk (,(make-adaptor adapt k syms))
($continue adapt src ,exp)))))))) ($continue adapt src ,exp))))))))
@ -278,4 +279,4 @@
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun src meta free body)
($fun src meta free ,(must-visit-cont body))))))) ($fun src meta free ,(must-visit-cont body)))))))
(visit-fun fun)))) (visit-fun fun)))))

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

@ -35,7 +35,7 @@
#:use-module (language cps dfg) #:use-module (language cps dfg)
#:export (elide-values)) #:export (elide-values))
(define (elide-values fun) (define (elide-values* fun)
(let ((conts (build-local-cont-table (let ((conts (build-local-cont-table
(match fun (($ $fun src meta free body) body))))) (match fun (($ $fun src meta free body) body)))))
(define (visit-cont cont) (define (visit-cont cont)
@ -54,7 +54,7 @@
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms (map elide-values funs) ($letrec names syms (map elide-values* funs)
,(visit-term body))) ,(visit-term body)))
(($ $continue k src ($ $primcall 'values vals)) (($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (lookup-cont k conts) ,(rewrite-cps-term (lookup-cont k conts)
@ -66,7 +66,7 @@
(build-cps-term (build-cps-term
($continue kargs src ($values vals)))) ($continue kargs src ($values vals))))
((and rest (>= (length vals) (length req))) ((and rest (>= (length vals) (length req)))
(let-gensyms (krest rest) (let-fresh (krest) (rest)
(let ((vals* (append (list-head vals (length req)) (let ((vals* (append (list-head vals (length req))
(list rest)))) (list rest))))
(build-cps-term (build-cps-term
@ -80,7 +80,7 @@
(build-cps-term ($continue k src (build-cps-term ($continue k src
($const '())))) ($const '()))))
((v . tail) ((v . tail)
(let-gensyms (krest rest) (let-fresh (krest) (rest)
(build-cps-term (build-cps-term
($letk ((krest ($kargs ('rest) (rest) ($letk ((krest ($kargs ('rest) (rest)
($continue k src ($continue k src
@ -95,10 +95,14 @@
(build-cps-term (build-cps-term
($continue k src ($values vals)))))))) ($continue k src ($values vals))))))))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(elide-values fun))) ($continue k src ,(elide-values* fun)))
(($ $continue) (($ $continue)
,term))) ,term)))
(rewrite-cps-exp fun (rewrite-cps-exp fun
(($ $fun src meta free body) (($ $fun src meta free body)
($fun src meta free ,(visit-cont body)))))) ($fun src meta free ,(visit-cont body))))))
(define (elide-values fun)
(with-fresh-name-state fun
(elide-values* fun)))

11
module/language/cps/reify-primitives.scm
View file

@ -33,7 +33,7 @@
#:export (reify-primitives)) #:export (reify-primitives))
(define (module-box src module name public? bound? val-proc) (define (module-box src module name public? bound? val-proc)
(let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box) (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(build-cps-term (build-cps-term
($letconst (('module module-sym module) ($letconst (('module module-sym module)
('name name-sym name) ('name name-sym name)
@ -81,14 +81,14 @@
($continue k src ($primcall 'box-ref (box))))))) ($continue k src ($primcall 'box-ref (box)))))))
(define (builtin-ref idx k src) (define (builtin-ref idx k src)
(let-gensyms (idx-sym) (let-fresh () (idx-sym)
(build-cps-term (build-cps-term
($letconst (('idx idx-sym idx)) ($letconst (('idx idx-sym idx))
($continue k src ($continue k src
($primcall 'builtin-ref (idx-sym))))))) ($primcall 'builtin-ref (idx-sym)))))))
(define (reify-clause ktail) (define (reify-clause ktail)
(let-gensyms (kclause kbody wna false str eol kthrow throw) (let-fresh (kclause kbody kthrow) (wna false str eol throw)
(build-cps-cont (build-cps-cont
(kclause ($kclause ('() '() #f '() #f) (kclause ($kclause ('() '() #f '() #f)
(kbody (kbody
@ -106,6 +106,7 @@
;; FIXME: Operate on one function at a time, for efficiency. ;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun) (define (reify-primitives fun)
(with-fresh-name-state fun
(let ((conts (build-cont-table fun))) (let ((conts (build-cont-table fun)))
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (rewrite-cps-exp term
@ -150,7 +151,7 @@
;; Assume arities are correct. ;; Assume arities are correct.
term) term)
(else (else
(let-gensyms (k* v) (let-fresh (k*) (v)
(build-cps-term (build-cps-term
($letk ((k* ($kargs (v) (v) ($letk ((k* ($kargs (v) (v)
($continue k src ($call v args))))) ($continue k src ($call v args)))))
@ -161,4 +162,4 @@
(else (primitive-ref name k* src))))))))) (else (primitive-ref name k* src)))))))))
(_ term))))) (_ term)))))
(visit-fun fun))) (visit-fun fun))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -31,6 +31,7 @@
#:export (specialize-primcalls)) #:export (specialize-primcalls))
(define (specialize-primcalls fun) (define (specialize-primcalls fun)
(with-fresh-name-state fun
(let ((dfg (compute-dfg fun #:global? #t))) (let ((dfg (compute-dfg fun #:global? #t)))
(define (immediate-u8? sym) (define (immediate-u8? sym)
(call-with-values (lambda () (find-constant-value sym dfg)) (call-with-values (lambda () (find-constant-value sym dfg))
@ -65,7 +66,7 @@
;; will need to ensure that the return arity matches. Rely on the ;; will need to ensure that the return arity matches. Rely on the
;; elide-values pass to clean up. ;; elide-values pass to clean up.
(define-syntax-rule (adapt-void exp) (define-syntax-rule (adapt-void exp)
(let-gensyms (k* val kvoid) (let-fresh (k* kvoid) (val)
(build-cps-term (build-cps-term
($letk ((k* ($kargs ('val) (val) ($letk ((k* ($kargs ('val) (val)
($continue k src ($primcall 'values (val))))) ($continue k src ($primcall 'values (val)))))
@ -73,7 +74,7 @@
($continue k* src ($void))))) ($continue k* src ($void)))))
($continue kvoid src exp))))) ($continue kvoid src exp)))))
(define-syntax-rule (adapt-val exp) (define-syntax-rule (adapt-val exp)
(let-gensyms (k* val) (let-fresh (k*) (val)
(build-cps-term (build-cps-term
($letk ((k* ($kargs ('val) (val) ($letk ((k* ($kargs ('val) (val)
($continue k src ($primcall 'values (val)))))) ($continue k src ($primcall 'values (val))))))
@ -95,7 +96,7 @@
;; Unhappily, and undocumentedly, struct-set! returns the value ;; Unhappily, and undocumentedly, struct-set! returns the value
;; that was set. There is code that relies on this. Hackety ;; that was set. There is code that relies on this. Hackety
;; hack... ;; hack...
(let-gensyms (k*) (let-fresh (k*) ()
(build-cps-term (build-cps-term
($letk ((k* ($kargs () () ($letk ((k* ($kargs () ()
($continue k src ($primcall 'values (x)))))) ($continue k src ($primcall 'values (x))))))
@ -108,4 +109,4 @@
(($ $fun src meta free body) (($ $fun src meta free body)
($fun src meta free ,(visit-cont body))))) ($fun src meta free ,(visit-cont body)))))
(visit-fun fun))) (visit-fun fun))))

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

@ -58,7 +58,7 @@
#:use-module (language cps primitives) #:use-module (language cps primitives)
#:use-module (language tree-il analyze) #:use-module (language tree-il analyze)
#:use-module (language tree-il optimize) #:use-module (language tree-il optimize)
#:use-module ((language tree-il) #:hide (let-gensyms)) #:use-module (language tree-il)
#:export (compile-cps)) #:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on ;;; Guile's semantics are that a toplevel lambda captures a reference on