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))

127
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-syntax-rule (make-cont-folder 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
(($ $cont k cont)
(let-values (((seed ...) (proc k cont seed ...)))
(match cont
(($ $kargs names syms body)
(term-folder body seed ...))
(($ $kentry self tail clauses)
(let-values (((seed ...) (cont-folder tail seed ...)))
(fold-values cont-folder clauses seed ...)))
(($ $kclause arity body)
(cont-folder body seed ...))
(_ (values seed ...)))))))
(define (fun-folder fun seed ...)
(match fun
(($ $fun src meta free body)
(cont-folder body seed ...))))
(define (term-folder term seed ...)
(match term
(($ $letk conts body)
(let-values (((seed ...) (term-folder body seed ...)))
(fold-values cont-folder conts seed ...)))
(($ $continue k src exp)
(match exp
(($ $fun) (fun-folder exp seed ...))
(_ (values seed ...))))
(($ $letrec names syms funs body)
(let-values (((seed ...) (term-folder body seed ...)))
(fold-values fun-folder funs 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) (define (fold-conts proc seed fun)
(define (cont-folder cont seed) ((make-cont-folder seed) proc fun seed))
(match cont
(($ $cont k cont)
(let ((seed (proc k cont seed)))
(match cont
(($ $kargs names syms body)
(term-folder body seed))
(($ $kentry self tail clauses)
(fold cont-folder (cont-folder tail seed) clauses))
(($ $kclause arity body)
(cont-folder body seed))
(_ seed))))))
(define (fun-folder fun seed)
(match fun
(($ $fun src meta free body)
(cont-folder body seed))))
(define (term-folder term seed)
(match term
(($ $letk conts body)
(fold cont-folder (term-folder body seed) conts))
(($ $continue k src exp)
(match exp
(($ $fun) (fun-folder exp seed))
(_ seed)))
(($ $letrec names syms funs body)
(fold fun-folder (term-folder body seed) funs))))
(fun-folder 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)))

25
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."
(match exp (with-fresh-name-state exp
(($ $fun src meta () body) (match exp
(receive (body free) (cc body #f '()) (($ $fun src meta () body)
(unless (null? free) (receive (body free) (cc body #f '())
(error "Expected no free vars in toplevel thunk" exp body free)) (unless (null? free)
(build-cps-exp (error "Expected no free vars in toplevel thunk" exp body free))
($fun src meta free ,(convert-to-indices body free))))))) (build-cps-exp
($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)))

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

@ -174,108 +174,109 @@
(values fun-data-table live-vars))) (values fun-data-table live-vars)))
(define (eliminate-dead-code fun) (define (eliminate-dead-code fun)
(call-with-values (lambda () (compute-live-code fun)) (with-fresh-name-state fun
(lambda (fun-data-table live-vars) (call-with-values (lambda () (compute-live-code fun))
(define (value-live? sym) (lambda (fun-data-table live-vars)
(hashq-ref live-vars sym)) (define (value-live? sym)
(define (make-adaptor name k defs) (hashq-ref live-vars sym))
(let* ((names (map (lambda (_) 'tmp) defs)) (define (make-adaptor name k defs)
(syms (map (lambda (_) (gensym "tmp")) defs)) (let* ((names (map (lambda (_) 'tmp) defs))
(live (filter-map (lambda (def sym) (syms (map (lambda (_) (gensym "tmp")) defs))
(and (value-live? def) (live (filter-map (lambda (def sym)
sym)) (and (value-live? def)
defs syms))) sym))
(build-cps-cont defs syms)))
(name ($kargs names syms (build-cps-cont
($continue k #f ($values live))))))) (name ($kargs names syms
(define (visit-fun fun) ($continue k #f ($values live)))))))
(match (hashq-ref fun-data-table fun) (define (visit-fun fun)
(($ $fun-data cfa effects contv live-conts defs) (match (hashq-ref fun-data-table fun)
(define (must-visit-cont cont) (($ $fun-data cfa effects contv live-conts defs)
(match (visit-cont cont) (define (must-visit-cont cont)
((cont) cont) (match (visit-cont cont)
(conts (error "cont must be reachable" cont conts)))) ((cont) cont)
(define (visit-cont cont) (conts (error "cont must be reachable" cont conts))))
(match cont (define (visit-cont cont)
(($ $cont sym cont) (match cont
(match (cfa-k-idx cfa sym #:default (lambda (k) #f)) (($ $cont sym cont)
(#f '()) (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
(n (#f '())
(match cont (n
(($ $kargs names syms body) (match cont
(match (filter-map (lambda (name sym) (($ $kargs names syms body)
(and (value-live? sym) (match (filter-map (lambda (name sym)
(cons name sym))) (and (value-live? sym)
names syms) (cons name sym)))
(((names . syms) ...) names syms)
(list (((names . syms) ...)
(build-cps-cont (list
(sym ($kargs names syms (build-cps-cont
,(visit-term body n)))))))) (sym ($kargs names syms
(($ $kentry self tail clauses) ,(visit-term body n))))))))
(list (($ $kentry self tail clauses)
(build-cps-cont (list
(sym ($kentry self ,tail (build-cps-cont
,(visit-conts clauses)))))) (sym ($kentry self ,tail
(($ $kclause arity body) ,(visit-conts clauses))))))
(list (($ $kclause arity body)
(build-cps-cont (list
(sym ($kclause ,arity (build-cps-cont
,(must-visit-cont body)))))) (sym ($kclause ,arity
(($ $kreceive ($ $arity req () rest () #f) kargs) ,(must-visit-cont body))))))
(let ((defs (vector-ref defs n))) (($ $kreceive ($ $arity req () rest () #f) kargs)
(if (and-map value-live? defs) (let ((defs (vector-ref defs n)))
(list (build-cps-cont (sym ,cont))) (if (and-map value-live? defs)
(let-gensyms (adapt) (list (build-cps-cont (sym ,cont)))
(list (make-adaptor adapt kargs defs) (let-fresh (adapt) ()
(build-cps-cont (list (make-adaptor adapt kargs defs)
(sym ($kreceive req rest adapt)))))))) (build-cps-cont
(_ (list (build-cps-cont (sym ,cont)))))))))) (sym ($kreceive req rest adapt))))))))
(define (visit-conts conts) (_ (list (build-cps-cont (sym ,cont))))))))))
(append-map visit-cont conts)) (define (visit-conts conts)
(define (visit-term term term-k-idx) (append-map visit-cont conts))
(match term (define (visit-term term term-k-idx)
(($ $letk conts body) (match term
(let ((body (visit-term body term-k-idx))) (($ $letk conts body)
(match (visit-conts conts) (let ((body (visit-term body term-k-idx)))
(() body) (match (visit-conts conts)
(conts (build-cps-term ($letk ,conts ,body)))))) (() body)
(($ $letrec names syms funs body) (conts (build-cps-term ($letk ,conts ,body))))))
(let ((body (visit-term body term-k-idx))) (($ $letrec names syms funs body)
(match (filter-map (let ((body (visit-term body term-k-idx)))
(lambda (name sym fun) (match (filter-map
(and (value-live? sym) (lambda (name sym fun)
(list name sym (visit-fun fun)))) (and (value-live? sym)
names syms funs) (list name sym (visit-fun fun))))
(() body) names syms funs)
(((names syms funs) ...) (() body)
(build-cps-term (((names syms funs) ...)
($letrec names syms funs ,body)))))) (build-cps-term
(($ $continue k src ($ $values args)) ($letrec names syms funs ,body))))))
(match (vector-ref defs term-k-idx) (($ $continue k src ($ $values args))
(#f term) (match (vector-ref defs term-k-idx)
(defs (#f term)
(let ((args (filter-map (lambda (use def) (defs
(and (value-live? def) use)) (let ((args (filter-map (lambda (use def)
args defs))) (and (value-live? def) use))
(build-cps-term args defs)))
($continue k src ($values args))))))) (build-cps-term
(($ $continue k src exp) ($continue k src ($values args)))))))
(if (bitvector-ref live-conts term-k-idx) (($ $continue k src exp)
(rewrite-cps-term exp (if (bitvector-ref live-conts term-k-idx)
(($ $fun) ($continue k src ,(visit-fun exp))) (rewrite-cps-term exp
(_ (($ $fun) ($continue k src ,(visit-fun exp)))
,(match (vector-ref defs term-k-idx) (_
((or #f ((? value-live?) ...)) ,(match (vector-ref defs term-k-idx)
(build-cps-term ((or #f ((? value-live?) ...))
($continue k src ,exp)))
(syms
(let-gensyms (adapt)
(build-cps-term (build-cps-term
($letk (,(make-adaptor adapt k syms)) ($continue k src ,exp)))
($continue adapt src ,exp)))))))) (syms
(build-cps-term ($continue k src ($values ()))))))) (let-fresh (adapt) ()
(rewrite-cps-exp fun (build-cps-term
(($ $fun src meta free body) ($letk (,(make-adaptor adapt k syms))
($fun src meta free ,(must-visit-cont body))))))) ($continue adapt src ,exp))))))))
(visit-fun fun)))) (build-cps-term ($continue k src ($values ())))))))
(rewrite-cps-exp fun
(($ $fun src meta free body)
($fun src meta free ,(must-visit-cont body)))))))
(visit-fun fun)))))

16
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)
@ -64,9 +64,9 @@
,(cond ,(cond
((and (not rest) (= (length vals) (length req))) ((and (not rest) (= (length vals) (length req)))
(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)))

117
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,59 +106,60 @@
;; 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)
(let ((conts (build-cont-table fun))) (with-fresh-name-state fun
(define (visit-fun term) (let ((conts (build-cont-table fun)))
(rewrite-cps-exp term (define (visit-fun term)
(($ $fun src meta free body) (rewrite-cps-exp term
($fun src meta free ,(visit-cont body))))) (($ $fun src meta free body)
(define (visit-cont cont) ($fun src meta free ,(visit-cont body)))))
(rewrite-cps-cont cont (define (visit-cont cont)
(($ $cont sym ($ $kargs names syms body)) (rewrite-cps-cont cont
(sym ($kargs names syms ,(visit-term body)))) (($ $cont sym ($ $kargs names syms body))
(($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ())) (sym ($kargs names syms ,(visit-term body))))
;; A case-lambda with no clauses. Reify a clause. (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
(sym ($kentry self ,tail (,(reify-clause ktail))))) ;; A case-lambda with no clauses. Reify a clause.
(($ $cont sym ($ $kentry self tail clauses)) (sym ($kentry self ,tail (,(reify-clause ktail)))))
(sym ($kentry self ,tail ,(map visit-cont clauses)))) (($ $cont sym ($ $kentry self tail clauses))
(($ $cont sym ($ $kclause arity body)) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(sym ($kclause ,arity ,(visit-cont body)))) (($ $cont sym ($ $kclause arity body))
(($ $cont) (sym ($kclause ,arity ,(visit-cont body))))
,cont))) (($ $cont)
(define (visit-term term) ,cont)))
(rewrite-cps-term term (define (visit-term term)
(($ $letk conts body) (rewrite-cps-term term
($letk ,(map visit-cont conts) ,(visit-term body))) (($ $letk conts body)
(($ $continue k src exp) ($letk ,(map visit-cont conts) ,(visit-term body)))
,(match exp (($ $continue k src exp)
(($ $prim name) ,(match exp
(match (lookup-cont k conts) (($ $prim name)
(($ $kargs (_)) (match (lookup-cont k conts)
(cond (($ $kargs (_))
((builtin-name->index name) (cond
=> (lambda (idx) ((builtin-name->index name)
(builtin-ref idx k src))) => (lambda (idx)
(else (primitive-ref name k src)))) (builtin-ref idx k src)))
(_ (build-cps-term ($continue k src ($void)))))) (else (primitive-ref name k src))))
(($ $fun) (_ (build-cps-term ($continue k src ($void))))))
(build-cps-term ($continue k src ,(visit-fun exp)))) (($ $fun)
(($ $primcall 'call-thunk/no-inline (proc)) (build-cps-term ($continue k src ,(visit-fun exp))))
(build-cps-term (($ $primcall 'call-thunk/no-inline (proc))
($continue k src ($call proc ())))) (build-cps-term
(($ $primcall name args) ($continue k src ($call proc ()))))
(cond (($ $primcall name args)
((or (prim-instruction name) (branching-primitive? name)) (cond
;; Assume arities are correct. ((or (prim-instruction name) (branching-primitive? name))
term) ;; Assume arities are correct.
(else term)
(let-gensyms (k* v) (else
(build-cps-term (let-fresh (k*) (v)
($letk ((k* ($kargs (v) (v) (build-cps-term
($continue k src ($call v args))))) ($letk ((k* ($kargs (v) (v)
,(cond ($continue k src ($call v args)))))
((builtin-name->index name) ,(cond
=> (lambda (idx) ((builtin-name->index name)
(builtin-ref idx k* src))) => (lambda (idx)
(else (primitive-ref name k* src))))))))) (builtin-ref idx k* src)))
(_ term))))) (else (primitive-ref name k* src)))))))))
(_ term)))))
(visit-fun fun))) (visit-fun fun))))

153
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,81 +31,82 @@
#:export (specialize-primcalls)) #:export (specialize-primcalls))
(define (specialize-primcalls fun) (define (specialize-primcalls fun)
(let ((dfg (compute-dfg fun #:global? #t))) (with-fresh-name-state fun
(define (immediate-u8? sym) (let ((dfg (compute-dfg fun #:global? #t)))
(call-with-values (lambda () (find-constant-value sym dfg)) (define (immediate-u8? sym)
(lambda (has-const? val) (call-with-values (lambda () (find-constant-value sym dfg))
(and has-const? (integer? val) (exact? val) (<= 0 val 255))))) (lambda (has-const? val)
(define (visit-cont cont) (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
(rewrite-cps-cont cont (define (visit-cont cont)
(($ $cont sym ($ $kargs names syms body)) (rewrite-cps-cont cont
(sym ($kargs names syms ,(visit-term body)))) (($ $cont sym ($ $kargs names syms body))
(($ $cont sym ($ $kentry self tail clauses)) (sym ($kargs names syms ,(visit-term body))))
(sym ($kentry self ,tail ,(map visit-cont clauses)))) (($ $cont sym ($ $kentry self tail clauses))
(($ $cont sym ($ $kclause arity body)) (sym ($kentry self ,tail ,(map visit-cont clauses))))
(sym ($kclause ,arity ,(visit-cont body)))) (($ $cont sym ($ $kclause arity body))
(($ $cont) (sym ($kclause ,arity ,(visit-cont body))))
,cont))) (($ $cont)
(define (visit-term term) ,cont)))
(rewrite-cps-term term (define (visit-term term)
(($ $letk conts body) (rewrite-cps-term term
($letk ,(map visit-cont conts) (($ $letk conts body)
,(visit-term body))) ($letk ,(map visit-cont conts)
(($ $letrec names syms funs body) ,(visit-term body)))
($letrec names syms (map visit-fun funs) (($ $letrec names syms funs body)
,(visit-term body))) ($letrec names syms (map visit-fun funs)
(($ $continue k src (and fun ($ $fun))) ,(visit-term body)))
($continue k src ,(visit-fun fun))) (($ $continue k src (and fun ($ $fun)))
(($ $continue k src ($ $primcall name args)) ($continue k src ,(visit-fun fun)))
,(visit-primcall k src name args)) (($ $continue k src ($ $primcall name args))
(($ $continue) ,(visit-primcall k src name args))
,term))) (($ $continue)
(define (visit-primcall k src name args) ,term)))
;; If we introduce a VM op from a primcall without a VM op, we (define (visit-primcall k src name args)
;; will need to ensure that the return arity matches. Rely on the ;; If we introduce a VM op from a primcall without a VM op, we
;; elide-values pass to clean up. ;; will need to ensure that the return arity matches. Rely on the
(define-syntax-rule (adapt-void exp) ;; elide-values pass to clean up.
(let-gensyms (k* val kvoid) (define-syntax-rule (adapt-void exp)
(build-cps-term (let-fresh (k* kvoid) (val)
($letk ((k* ($kargs ('val) (val) (build-cps-term
($continue k src ($primcall 'values (val))))) ($letk ((k* ($kargs ('val) (val)
(kvoid ($kargs () () ($continue k src ($primcall 'values (val)))))
($continue k* src ($void))))) (kvoid ($kargs () ()
($continue kvoid src exp))))) ($continue k* src ($void)))))
(define-syntax-rule (adapt-val exp) ($continue kvoid src exp)))))
(let-gensyms (k* val) (define-syntax-rule (adapt-val exp)
(build-cps-term (let-fresh (k*) (val)
($letk ((k* ($kargs ('val) (val) (build-cps-term
($continue k src ($primcall 'values (val)))))) ($letk ((k* ($kargs ('val) (val)
($continue k* src exp))))) ($continue k src ($primcall 'values (val))))))
(match (cons name args) ($continue k* src exp)))))
(('make-vector (? immediate-u8? n) init) (match (cons name args)
(adapt-val ($primcall 'make-vector/immediate (n init)))) (('make-vector (? immediate-u8? n) init)
(('vector-ref v (? immediate-u8? n)) (adapt-val ($primcall 'make-vector/immediate (n init))))
(build-cps-term (('vector-ref v (? immediate-u8? n))
($continue k src ($primcall 'vector-ref/immediate (v n)))))
(('vector-set! v (? immediate-u8? n) x)
(build-cps-term
($continue k src ($primcall 'vector-set!/immediate (v n x)))))
(('allocate-struct v (? immediate-u8? n))
(adapt-val ($primcall 'allocate-struct/immediate (v n))))
(('struct-ref s (? immediate-u8? n))
(adapt-val ($primcall 'struct-ref/immediate (s n))))
(('struct-set! s (? immediate-u8? n) x)
;; Unhappily, and undocumentedly, struct-set! returns the value
;; that was set. There is code that relies on this. Hackety
;; hack...
(let-gensyms (k*)
(build-cps-term (build-cps-term
($letk ((k* ($kargs () () ($continue k src ($primcall 'vector-ref/immediate (v n)))))
($continue k src ($primcall 'values (x)))))) (('vector-set! v (? immediate-u8? n) x)
($continue k* src ($primcall 'struct-set!/immediate (s n x))))))) (build-cps-term
(_ ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
(build-cps-term ($continue k src ($primcall name args)))))) (('allocate-struct v (? immediate-u8? n))
(adapt-val ($primcall 'allocate-struct/immediate (v n))))
(('struct-ref s (? immediate-u8? n))
(adapt-val ($primcall 'struct-ref/immediate (s n))))
(('struct-set! s (? immediate-u8? n) x)
;; Unhappily, and undocumentedly, struct-set! returns the value
;; that was set. There is code that relies on this. Hackety
;; hack...
(let-fresh (k*) ()
(build-cps-term
($letk ((k* ($kargs () ()
($continue k src ($primcall 'values (x))))))
($continue k* src ($primcall 'struct-set!/immediate (s n x)))))))
(_
(build-cps-term ($continue k src ($primcall name args))))))
(define (visit-fun fun) (define (visit-fun fun)
(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)))))
(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