mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-23 03:54:12 +02:00
Replace all let-gensyms uses with let-fresh
* .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
parent
0534735314
commit
828ed94469
10 changed files with 378 additions and 320 deletions
|
|
@ -107,6 +107,7 @@
|
|||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:export (;; Helper.
|
||||
$arity
|
||||
make-$arity
|
||||
|
|
@ -126,7 +127,8 @@
|
|||
;; Fresh names.
|
||||
label-counter var-counter
|
||||
fresh-label fresh-var
|
||||
let-fresh let-gensyms
|
||||
with-fresh-name-state compute-max-label-and-var
|
||||
let-fresh
|
||||
|
||||
;; Building macros.
|
||||
build-cps-term build-cps-cont build-cps-exp
|
||||
|
|
@ -195,14 +197,16 @@
|
|||
(define var-counter (make-parameter #f))
|
||||
|
||||
(define (fresh-label)
|
||||
(let ((count (label-counter)))
|
||||
(let ((count (or (label-counter)
|
||||
(error "fresh-label outside with-fresh-name-state"))))
|
||||
(label-counter (1+ count))
|
||||
count))
|
||||
|
||||
;; FIXME: Currently vars and labels need to be unique, so we use the
|
||||
;; label counter.
|
||||
(define (fresh-var)
|
||||
(let ((count (label-counter)))
|
||||
(let ((count (or (label-counter)
|
||||
(error "fresh-var outside with-fresh-name-state"))))
|
||||
(label-counter (1+ count))
|
||||
count))
|
||||
|
||||
|
|
@ -211,11 +215,17 @@
|
|||
(var (fresh-var)) ...)
|
||||
body ...))
|
||||
|
||||
(define-syntax let-gensyms
|
||||
(syntax-rules ()
|
||||
((_ (sym ...) body body* ...)
|
||||
(let ((sym (gensym (symbol->string 'sym))) ...)
|
||||
body body* ...))))
|
||||
;; FIXME: Same FIXME as above.
|
||||
(define-syntax-rule (with-fresh-name-state fun body ...)
|
||||
(begin
|
||||
(when (or (label-counter) (var-counter))
|
||||
(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
|
||||
(syntax-rules (unquote)
|
||||
|
|
@ -432,42 +442,73 @@
|
|||
(_
|
||||
(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 (cont-folder cont 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))
|
||||
((make-cont-folder seed) proc fun seed))
|
||||
|
||||
(define (fold-local-conts proc seed cont)
|
||||
(define (cont-folder cont seed)
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term 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)
|
||||
,(visit-exp k src exp))))
|
||||
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
(0
|
||||
(rewrite-cps-term (lookup-cont k conts)
|
||||
(($ $ktail)
|
||||
,(let-gensyms (kvoid kunspec unspec)
|
||||
,(let-fresh (kvoid kunspec) (unspec)
|
||||
(build-cps-term
|
||||
($letk* ((kunspec ($kargs (unspec) (unspec)
|
||||
($continue k src
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
,(match arity
|
||||
(($ $arity () () rest () #f)
|
||||
(if rest
|
||||
(let-gensyms (knil)
|
||||
(let-fresh (knil) ()
|
||||
(build-cps-term
|
||||
($letk ((knil ($kargs () ()
|
||||
($continue kargs src ($const '())))))
|
||||
|
|
@ -70,7 +70,7 @@
|
|||
(build-cps-term
|
||||
($continue kargs src ,exp))))
|
||||
(_
|
||||
(let-gensyms (kvoid kvalues void)
|
||||
(let-fresh (kvoid kvalues) (void)
|
||||
(build-cps-term
|
||||
($letk* ((kvalues ($kargs ('void) (void)
|
||||
($continue k src
|
||||
|
|
@ -82,7 +82,7 @@
|
|||
(($ $kargs () () _)
|
||||
($continue k src ,exp))
|
||||
(_
|
||||
,(let-gensyms (k*)
|
||||
,(let-fresh (k*) ()
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs () () ($continue k src ($void)))))
|
||||
($continue k* src ,exp)))))))
|
||||
|
|
@ -93,7 +93,7 @@
|
|||
(($values (sym))
|
||||
($continue ktail src ($primcall 'return (sym))))
|
||||
(_
|
||||
,(let-gensyms (k* v)
|
||||
,(let-fresh (k*) (v)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs (v) (v)
|
||||
($continue k src
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
,(match arity
|
||||
(($ $arity (_) () rest () #f)
|
||||
(if rest
|
||||
(let-gensyms (kval val nil)
|
||||
(let-fresh (kval) (val nil)
|
||||
(build-cps-term
|
||||
($letk ((kval ($kargs ('val) (val)
|
||||
($letconst (('nil nil '()))
|
||||
|
|
@ -112,14 +112,14 @@
|
|||
($continue kval src ,exp))))
|
||||
(build-cps-term ($continue kargs src ,exp))))
|
||||
(_
|
||||
(let-gensyms (kvalues value)
|
||||
(let-fresh (kvalues) (value)
|
||||
(build-cps-term
|
||||
($letk ((kvalues ($kargs ('value) (value)
|
||||
($continue k src
|
||||
($primcall 'values (value))))))
|
||||
($continue kvalues src ,exp)))))))
|
||||
(($ $kargs () () _)
|
||||
,(let-gensyms (k* drop)
|
||||
,(let-fresh (k*) (drop)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs ('drop) (drop)
|
||||
($continue k src ($values ())))))
|
||||
|
|
@ -135,7 +135,7 @@
|
|||
($ $values (_)))
|
||||
,(adapt-exp 1 k src exp))
|
||||
(($ $fun)
|
||||
,(adapt-exp 1 k src (fix-arities exp)))
|
||||
,(adapt-exp 1 k src (fix-arities* exp)))
|
||||
((or ($ $call) ($ $callk))
|
||||
;; In general, calls have unknown return arity. For that
|
||||
;; reason every non-tail call has a $kreceive continuation to
|
||||
|
|
@ -158,7 +158,7 @@
|
|||
(if (and inst (not (eq? inst name)))
|
||||
(build-cps-exp ($primcall inst args))
|
||||
exp)))
|
||||
(let-gensyms (k* p*)
|
||||
(let-fresh (k*) (p*)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs ('prim) (p*)
|
||||
($continue k src ($call p* args)))))
|
||||
|
|
@ -183,7 +183,11 @@
|
|||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses)))))))
|
||||
|
||||
(define (fix-arities fun)
|
||||
(define (fix-arities* fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(fix-clause-arities body)))))
|
||||
|
||||
(define (fix-arities fun)
|
||||
(with-fresh-name-state fun
|
||||
(fix-arities* fun)))
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ called with @var{sym}.
|
|||
values in the term."
|
||||
(if (memq sym bound)
|
||||
(k sym)
|
||||
(let-gensyms (k* sym*)
|
||||
(let-fresh (k*) (sym*)
|
||||
(receive (exp free) (k sym*)
|
||||
(values (build-cps-term
|
||||
($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
|
||||
performed, and @var{outer-bound} is the list of bound variables there."
|
||||
(fold (lambda (free idx body)
|
||||
(let-gensyms (k idxsym)
|
||||
(let-fresh (k) (idxsym)
|
||||
(build-cps-term
|
||||
($letk ((k ($kargs () () ,body)))
|
||||
,(convert-free-var
|
||||
|
|
@ -157,7 +157,7 @@ convert functions to flat closures."
|
|||
(receive (fun-body fun-free) (cc fun-body #f '())
|
||||
(lp in
|
||||
(lambda (body)
|
||||
(let-gensyms (k)
|
||||
(let-fresh (k) ()
|
||||
(build-cps-term
|
||||
($letk ((k ($kargs (name) (sym) ,(bindings body))))
|
||||
($continue k src
|
||||
|
|
@ -180,7 +180,7 @@ convert functions to flat closures."
|
|||
free))
|
||||
(_
|
||||
(values
|
||||
(let-gensyms (kinit v)
|
||||
(let-fresh (kinit) (v)
|
||||
(build-cps-term
|
||||
($letk ((kinit ($kargs (v) (v)
|
||||
,(init-closure
|
||||
|
|
@ -241,7 +241,7 @@ convert functions to flat closures."
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $continue k src ($ $primcall 'free-ref (closure sym)))
|
||||
,(let-gensyms (idx)
|
||||
,(let-fresh () (idx)
|
||||
(build-cps-term
|
||||
($letconst (('idx idx (free-index sym)))
|
||||
($continue k src ($primcall 'free-ref (closure idx)))))))
|
||||
|
|
@ -268,10 +268,11 @@ 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."
|
||||
(match exp
|
||||
(($ $fun src meta () body)
|
||||
(receive (body free) (cc body #f '())
|
||||
(unless (null? free)
|
||||
(error "Expected no free vars in toplevel thunk" exp body free))
|
||||
(build-cps-exp
|
||||
($fun src meta free ,(convert-to-indices body free)))))))
|
||||
(with-fresh-name-state exp
|
||||
(match exp
|
||||
(($ $fun src meta () body)
|
||||
(receive (body free) (cc body #f '())
|
||||
(unless (null? free)
|
||||
(error "Expected no free vars in toplevel thunk" exp body free))
|
||||
(build-cps-exp
|
||||
($fun src meta free ,(convert-to-indices body free))))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -29,7 +29,7 @@
|
|||
#:use-module (language cps)
|
||||
#:export (inline-constructors))
|
||||
|
||||
(define (inline-constructors fun)
|
||||
(define (inline-constructors* fun)
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
|
|
@ -46,10 +46,10 @@
|
|||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map inline-constructors funs)
|
||||
($letrec names syms (map inline-constructors* funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src ($ $primcall 'list args))
|
||||
,(let-gensyms (kvalues val)
|
||||
,(let-fresh (kvalues) (val)
|
||||
(build-cps-term
|
||||
($letk ((kvalues ($kargs ('val) (val)
|
||||
($continue k src
|
||||
|
|
@ -60,21 +60,21 @@
|
|||
(build-cps-term
|
||||
($continue k src ($const '()))))
|
||||
((arg . args)
|
||||
(let-gensyms (ktail tail)
|
||||
(let-fresh (ktail) (tail)
|
||||
(build-cps-term
|
||||
($letk ((ktail ($kargs ('tail) (tail)
|
||||
($continue k src
|
||||
($primcall 'cons (arg tail))))))
|
||||
,(lp args ktail)))))))))))
|
||||
(($ $continue k src ($ $primcall 'vector args))
|
||||
,(let-gensyms (kalloc vec len init)
|
||||
,(let-fresh (kalloc) (vec len init)
|
||||
(define (initialize args n)
|
||||
(match args
|
||||
(()
|
||||
(build-cps-term
|
||||
($continue k src ($primcall 'values (vec)))))
|
||||
((arg . args)
|
||||
(let-gensyms (knext idx)
|
||||
(let-fresh (knext) (idx)
|
||||
(build-cps-term
|
||||
($letk ((knext ($kargs () ()
|
||||
,(initialize args (1+ n)))))
|
||||
|
|
@ -89,10 +89,14 @@
|
|||
($continue kalloc src
|
||||
($primcall 'make-vector (len init))))))))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(inline-constructors fun)))
|
||||
($continue k src ,(inline-constructors* fun)))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
|
||||
(define (inline-constructors fun)
|
||||
(with-fresh-name-state fun
|
||||
(inline-constructors* fun)))
|
||||
|
|
|
|||
|
|
@ -174,108 +174,109 @@
|
|||
(values fun-data-table live-vars)))
|
||||
|
||||
(define (eliminate-dead-code fun)
|
||||
(call-with-values (lambda () (compute-live-code fun))
|
||||
(lambda (fun-data-table live-vars)
|
||||
(define (value-live? sym)
|
||||
(hashq-ref live-vars sym))
|
||||
(define (make-adaptor name k defs)
|
||||
(let* ((names (map (lambda (_) 'tmp) defs))
|
||||
(syms (map (lambda (_) (gensym "tmp")) defs))
|
||||
(live (filter-map (lambda (def sym)
|
||||
(and (value-live? def)
|
||||
sym))
|
||||
defs syms)))
|
||||
(build-cps-cont
|
||||
(name ($kargs names syms
|
||||
($continue k #f ($values live)))))))
|
||||
(define (visit-fun fun)
|
||||
(match (hashq-ref fun-data-table fun)
|
||||
(($ $fun-data cfa effects contv live-conts defs)
|
||||
(define (must-visit-cont cont)
|
||||
(match (visit-cont cont)
|
||||
((cont) cont)
|
||||
(conts (error "cont must be reachable" cont conts))))
|
||||
(define (visit-cont cont)
|
||||
(match cont
|
||||
(($ $cont sym cont)
|
||||
(match (cfa-k-idx cfa sym #:default (lambda (k) #f))
|
||||
(#f '())
|
||||
(n
|
||||
(match cont
|
||||
(($ $kargs names syms body)
|
||||
(match (filter-map (lambda (name sym)
|
||||
(and (value-live? sym)
|
||||
(cons name sym)))
|
||||
names syms)
|
||||
(((names . syms) ...)
|
||||
(list
|
||||
(build-cps-cont
|
||||
(sym ($kargs names syms
|
||||
,(visit-term body n))))))))
|
||||
(($ $kentry self tail clauses)
|
||||
(list
|
||||
(build-cps-cont
|
||||
(sym ($kentry self ,tail
|
||||
,(visit-conts clauses))))))
|
||||
(($ $kclause arity body)
|
||||
(list
|
||||
(build-cps-cont
|
||||
(sym ($kclause ,arity
|
||||
,(must-visit-cont body))))))
|
||||
(($ $kreceive ($ $arity req () rest () #f) kargs)
|
||||
(let ((defs (vector-ref defs n)))
|
||||
(if (and-map value-live? defs)
|
||||
(list (build-cps-cont (sym ,cont)))
|
||||
(let-gensyms (adapt)
|
||||
(list (make-adaptor adapt kargs defs)
|
||||
(build-cps-cont
|
||||
(sym ($kreceive req rest adapt))))))))
|
||||
(_ (list (build-cps-cont (sym ,cont))))))))))
|
||||
(define (visit-conts conts)
|
||||
(append-map visit-cont conts))
|
||||
(define (visit-term term term-k-idx)
|
||||
(match term
|
||||
(($ $letk conts body)
|
||||
(let ((body (visit-term body term-k-idx)))
|
||||
(match (visit-conts conts)
|
||||
(() body)
|
||||
(conts (build-cps-term ($letk ,conts ,body))))))
|
||||
(($ $letrec names syms funs body)
|
||||
(let ((body (visit-term body term-k-idx)))
|
||||
(match (filter-map
|
||||
(lambda (name sym fun)
|
||||
(and (value-live? sym)
|
||||
(list name sym (visit-fun fun))))
|
||||
names syms funs)
|
||||
(() body)
|
||||
(((names syms funs) ...)
|
||||
(build-cps-term
|
||||
($letrec names syms funs ,body))))))
|
||||
(($ $continue k src ($ $values args))
|
||||
(match (vector-ref defs term-k-idx)
|
||||
(#f term)
|
||||
(defs
|
||||
(let ((args (filter-map (lambda (use def)
|
||||
(and (value-live? def) use))
|
||||
args defs)))
|
||||
(build-cps-term
|
||||
($continue k src ($values args)))))))
|
||||
(($ $continue k src exp)
|
||||
(if (bitvector-ref live-conts term-k-idx)
|
||||
(rewrite-cps-term exp
|
||||
(($ $fun) ($continue k src ,(visit-fun exp)))
|
||||
(_
|
||||
,(match (vector-ref defs term-k-idx)
|
||||
((or #f ((? value-live?) ...))
|
||||
(build-cps-term
|
||||
($continue k src ,exp)))
|
||||
(syms
|
||||
(let-gensyms (adapt)
|
||||
(with-fresh-name-state fun
|
||||
(call-with-values (lambda () (compute-live-code fun))
|
||||
(lambda (fun-data-table live-vars)
|
||||
(define (value-live? sym)
|
||||
(hashq-ref live-vars sym))
|
||||
(define (make-adaptor name k defs)
|
||||
(let* ((names (map (lambda (_) 'tmp) defs))
|
||||
(syms (map (lambda (_) (gensym "tmp")) defs))
|
||||
(live (filter-map (lambda (def sym)
|
||||
(and (value-live? def)
|
||||
sym))
|
||||
defs syms)))
|
||||
(build-cps-cont
|
||||
(name ($kargs names syms
|
||||
($continue k #f ($values live)))))))
|
||||
(define (visit-fun fun)
|
||||
(match (hashq-ref fun-data-table fun)
|
||||
(($ $fun-data cfa effects contv live-conts defs)
|
||||
(define (must-visit-cont cont)
|
||||
(match (visit-cont cont)
|
||||
((cont) cont)
|
||||
(conts (error "cont must be reachable" cont conts))))
|
||||
(define (visit-cont cont)
|
||||
(match cont
|
||||
(($ $cont sym cont)
|
||||
(match (cfa-k-idx cfa sym #:default (lambda (k) #f))
|
||||
(#f '())
|
||||
(n
|
||||
(match cont
|
||||
(($ $kargs names syms body)
|
||||
(match (filter-map (lambda (name sym)
|
||||
(and (value-live? sym)
|
||||
(cons name sym)))
|
||||
names syms)
|
||||
(((names . syms) ...)
|
||||
(list
|
||||
(build-cps-cont
|
||||
(sym ($kargs names syms
|
||||
,(visit-term body n))))))))
|
||||
(($ $kentry self tail clauses)
|
||||
(list
|
||||
(build-cps-cont
|
||||
(sym ($kentry self ,tail
|
||||
,(visit-conts clauses))))))
|
||||
(($ $kclause arity body)
|
||||
(list
|
||||
(build-cps-cont
|
||||
(sym ($kclause ,arity
|
||||
,(must-visit-cont body))))))
|
||||
(($ $kreceive ($ $arity req () rest () #f) kargs)
|
||||
(let ((defs (vector-ref defs n)))
|
||||
(if (and-map value-live? defs)
|
||||
(list (build-cps-cont (sym ,cont)))
|
||||
(let-fresh (adapt) ()
|
||||
(list (make-adaptor adapt kargs defs)
|
||||
(build-cps-cont
|
||||
(sym ($kreceive req rest adapt))))))))
|
||||
(_ (list (build-cps-cont (sym ,cont))))))))))
|
||||
(define (visit-conts conts)
|
||||
(append-map visit-cont conts))
|
||||
(define (visit-term term term-k-idx)
|
||||
(match term
|
||||
(($ $letk conts body)
|
||||
(let ((body (visit-term body term-k-idx)))
|
||||
(match (visit-conts conts)
|
||||
(() body)
|
||||
(conts (build-cps-term ($letk ,conts ,body))))))
|
||||
(($ $letrec names syms funs body)
|
||||
(let ((body (visit-term body term-k-idx)))
|
||||
(match (filter-map
|
||||
(lambda (name sym fun)
|
||||
(and (value-live? sym)
|
||||
(list name sym (visit-fun fun))))
|
||||
names syms funs)
|
||||
(() body)
|
||||
(((names syms funs) ...)
|
||||
(build-cps-term
|
||||
($letrec names syms funs ,body))))))
|
||||
(($ $continue k src ($ $values args))
|
||||
(match (vector-ref defs term-k-idx)
|
||||
(#f term)
|
||||
(defs
|
||||
(let ((args (filter-map (lambda (use def)
|
||||
(and (value-live? def) use))
|
||||
args defs)))
|
||||
(build-cps-term
|
||||
($continue k src ($values args)))))))
|
||||
(($ $continue k src exp)
|
||||
(if (bitvector-ref live-conts term-k-idx)
|
||||
(rewrite-cps-term exp
|
||||
(($ $fun) ($continue k src ,(visit-fun exp)))
|
||||
(_
|
||||
,(match (vector-ref defs term-k-idx)
|
||||
((or #f ((? value-live?) ...))
|
||||
(build-cps-term
|
||||
($letk (,(make-adaptor adapt k syms))
|
||||
($continue adapt src ,exp))))))))
|
||||
(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))))
|
||||
($continue k src ,exp)))
|
||||
(syms
|
||||
(let-fresh (adapt) ()
|
||||
(build-cps-term
|
||||
($letk (,(make-adaptor adapt k syms))
|
||||
($continue adapt src ,exp))))))))
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
#:use-module (language cps dfg)
|
||||
#:export (elide-values))
|
||||
|
||||
(define (elide-values fun)
|
||||
(define (elide-values* fun)
|
||||
(let ((conts (build-local-cont-table
|
||||
(match fun (($ $fun src meta free body) body)))))
|
||||
(define (visit-cont cont)
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map elide-values funs)
|
||||
($letrec names syms (map elide-values* funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src ($ $primcall 'values vals))
|
||||
,(rewrite-cps-term (lookup-cont k conts)
|
||||
|
|
@ -64,9 +64,9 @@
|
|||
,(cond
|
||||
((and (not rest) (= (length vals) (length req)))
|
||||
(build-cps-term
|
||||
($continue kargs src ($values vals))))
|
||||
($continue kargs src ($values vals))))
|
||||
((and rest (>= (length vals) (length req)))
|
||||
(let-gensyms (krest rest)
|
||||
(let-fresh (krest) (rest)
|
||||
(let ((vals* (append (list-head vals (length req))
|
||||
(list rest))))
|
||||
(build-cps-term
|
||||
|
|
@ -80,7 +80,7 @@
|
|||
(build-cps-term ($continue k src
|
||||
($const '()))))
|
||||
((v . tail)
|
||||
(let-gensyms (krest rest)
|
||||
(let-fresh (krest) (rest)
|
||||
(build-cps-term
|
||||
($letk ((krest ($kargs ('rest) (rest)
|
||||
($continue k src
|
||||
|
|
@ -95,10 +95,14 @@
|
|||
(build-cps-term
|
||||
($continue k src ($values vals))))))))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(elide-values fun)))
|
||||
($continue k src ,(elide-values* fun)))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body))))))
|
||||
|
||||
(define (elide-values fun)
|
||||
(with-fresh-name-state fun
|
||||
(elide-values* fun)))
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@
|
|||
#:export (reify-primitives))
|
||||
|
||||
(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
|
||||
($letconst (('module module-sym module)
|
||||
('name name-sym name)
|
||||
|
|
@ -81,14 +81,14 @@
|
|||
($continue k src ($primcall 'box-ref (box)))))))
|
||||
|
||||
(define (builtin-ref idx k src)
|
||||
(let-gensyms (idx-sym)
|
||||
(let-fresh () (idx-sym)
|
||||
(build-cps-term
|
||||
($letconst (('idx idx-sym idx))
|
||||
($continue k src
|
||||
($primcall 'builtin-ref (idx-sym)))))))
|
||||
|
||||
(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
|
||||
(kclause ($kclause ('() '() #f '() #f)
|
||||
(kbody
|
||||
|
|
@ -106,59 +106,60 @@
|
|||
|
||||
;; FIXME: Operate on one function at a time, for efficiency.
|
||||
(define (reify-primitives fun)
|
||||
(let ((conts (build-cont-table fun)))
|
||||
(define (visit-fun term)
|
||||
(rewrite-cps-exp term
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
|
||||
;; A case-lambda with no clauses. Reify a clause.
|
||||
(sym ($kentry self ,tail (,(reify-clause ktail)))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $continue k src exp)
|
||||
,(match exp
|
||||
(($ $prim name)
|
||||
(match (lookup-cont k conts)
|
||||
(($ $kargs (_))
|
||||
(cond
|
||||
((builtin-name->index name)
|
||||
=> (lambda (idx)
|
||||
(builtin-ref idx k src)))
|
||||
(else (primitive-ref name k src))))
|
||||
(_ (build-cps-term ($continue k src ($void))))))
|
||||
(($ $fun)
|
||||
(build-cps-term ($continue k src ,(visit-fun exp))))
|
||||
(($ $primcall 'call-thunk/no-inline (proc))
|
||||
(build-cps-term
|
||||
($continue k src ($call proc ()))))
|
||||
(($ $primcall name args)
|
||||
(cond
|
||||
((or (prim-instruction name) (branching-primitive? name))
|
||||
;; Assume arities are correct.
|
||||
term)
|
||||
(else
|
||||
(let-gensyms (k* v)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs (v) (v)
|
||||
($continue k src ($call v args)))))
|
||||
,(cond
|
||||
((builtin-name->index name)
|
||||
=> (lambda (idx)
|
||||
(builtin-ref idx k* src)))
|
||||
(else (primitive-ref name k* src)))))))))
|
||||
(_ term)))))
|
||||
(with-fresh-name-state fun
|
||||
(let ((conts (build-cont-table fun)))
|
||||
(define (visit-fun term)
|
||||
(rewrite-cps-exp term
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
|
||||
;; A case-lambda with no clauses. Reify a clause.
|
||||
(sym ($kentry self ,tail (,(reify-clause ktail)))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $continue k src exp)
|
||||
,(match exp
|
||||
(($ $prim name)
|
||||
(match (lookup-cont k conts)
|
||||
(($ $kargs (_))
|
||||
(cond
|
||||
((builtin-name->index name)
|
||||
=> (lambda (idx)
|
||||
(builtin-ref idx k src)))
|
||||
(else (primitive-ref name k src))))
|
||||
(_ (build-cps-term ($continue k src ($void))))))
|
||||
(($ $fun)
|
||||
(build-cps-term ($continue k src ,(visit-fun exp))))
|
||||
(($ $primcall 'call-thunk/no-inline (proc))
|
||||
(build-cps-term
|
||||
($continue k src ($call proc ()))))
|
||||
(($ $primcall name args)
|
||||
(cond
|
||||
((or (prim-instruction name) (branching-primitive? name))
|
||||
;; Assume arities are correct.
|
||||
term)
|
||||
(else
|
||||
(let-fresh (k*) (v)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs (v) (v)
|
||||
($continue k src ($call v args)))))
|
||||
,(cond
|
||||
((builtin-name->index name)
|
||||
=> (lambda (idx)
|
||||
(builtin-ref idx k* src)))
|
||||
(else (primitive-ref name k* src)))))))))
|
||||
(_ term)))))
|
||||
|
||||
(visit-fun fun)))
|
||||
(visit-fun fun))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -31,81 +31,82 @@
|
|||
#:export (specialize-primcalls))
|
||||
|
||||
(define (specialize-primcalls fun)
|
||||
(let ((dfg (compute-dfg fun #:global? #t)))
|
||||
(define (immediate-u8? sym)
|
||||
(call-with-values (lambda () (find-constant-value sym dfg))
|
||||
(lambda (has-const? val)
|
||||
(and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $primcall name args))
|
||||
,(visit-primcall k src name args))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
(define (visit-primcall k src name args)
|
||||
;; If we introduce a VM op from a primcall without a VM op, we
|
||||
;; will need to ensure that the return arity matches. Rely on the
|
||||
;; elide-values pass to clean up.
|
||||
(define-syntax-rule (adapt-void exp)
|
||||
(let-gensyms (k* val kvoid)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs ('val) (val)
|
||||
($continue k src ($primcall 'values (val)))))
|
||||
(kvoid ($kargs () ()
|
||||
($continue k* src ($void)))))
|
||||
($continue kvoid src exp)))))
|
||||
(define-syntax-rule (adapt-val exp)
|
||||
(let-gensyms (k* val)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs ('val) (val)
|
||||
($continue k src ($primcall 'values (val))))))
|
||||
($continue k* src exp)))))
|
||||
(match (cons name args)
|
||||
(('make-vector (? immediate-u8? n) init)
|
||||
(adapt-val ($primcall 'make-vector/immediate (n init))))
|
||||
(('vector-ref v (? immediate-u8? n))
|
||||
(build-cps-term
|
||||
($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*)
|
||||
(with-fresh-name-state fun
|
||||
(let ((dfg (compute-dfg fun #:global? #t)))
|
||||
(define (immediate-u8? sym)
|
||||
(call-with-values (lambda () (find-constant-value sym dfg))
|
||||
(lambda (has-const? val)
|
||||
(and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body))))
|
||||
(($ $cont sym ($ $kentry self tail clauses))
|
||||
(sym ($kentry self ,tail ,(map visit-cont clauses))))
|
||||
(($ $cont sym ($ $kclause arity body))
|
||||
(sym ($kclause ,arity ,(visit-cont body))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $primcall name args))
|
||||
,(visit-primcall k src name args))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
(define (visit-primcall k src name args)
|
||||
;; If we introduce a VM op from a primcall without a VM op, we
|
||||
;; will need to ensure that the return arity matches. Rely on the
|
||||
;; elide-values pass to clean up.
|
||||
(define-syntax-rule (adapt-void exp)
|
||||
(let-fresh (k* kvoid) (val)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs ('val) (val)
|
||||
($continue k src ($primcall 'values (val)))))
|
||||
(kvoid ($kargs () ()
|
||||
($continue k* src ($void)))))
|
||||
($continue kvoid src exp)))))
|
||||
(define-syntax-rule (adapt-val exp)
|
||||
(let-fresh (k*) (val)
|
||||
(build-cps-term
|
||||
($letk ((k* ($kargs ('val) (val)
|
||||
($continue k src ($primcall 'values (val))))))
|
||||
($continue k* src exp)))))
|
||||
(match (cons name args)
|
||||
(('make-vector (? immediate-u8? n) init)
|
||||
(adapt-val ($primcall 'make-vector/immediate (n init))))
|
||||
(('vector-ref v (? immediate-u8? n))
|
||||
(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))))))
|
||||
($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-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)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
(define (visit-fun fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun src meta free body)
|
||||
($fun src meta free ,(visit-cont body)))))
|
||||
|
||||
(visit-fun fun)))
|
||||
(visit-fun fun))))
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@
|
|||
#:use-module (language cps primitives)
|
||||
#:use-module (language tree-il analyze)
|
||||
#:use-module (language tree-il optimize)
|
||||
#:use-module ((language tree-il) #:hide (let-gensyms))
|
||||
#:use-module (language tree-il)
|
||||
#:export (compile-cps))
|
||||
|
||||
;;; Guile's semantics are that a toplevel lambda captures a reference on
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue