* .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).
(eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms 'scheme-indent-function 1))
(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-exp 'scheme-indent-function 0))
(eval . (put 'build-cps-cont 'scheme-indent-function 0))
#: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
;; 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
(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))
(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)
(_
(error "unexpected cps" exp))))
-(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-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 (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-conts proc seed fun)
+ ((make-cont-folder seed) proc fun seed))
(define (fold-local-conts proc seed cont)
(define (cont-folder cont seed)
(($ $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))))
(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
,(match arity
(($ $arity () () rest () #f)
(if rest
- (let-gensyms (knil)
+ (let-fresh (knil) ()
(build-cps-term
($letk ((knil ($kargs () ()
($continue kargs src ($const '())))))
(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
(($ $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)))))))
(($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
,(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 '()))
($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 ())))))
($ $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
(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)))))
(($ $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)))
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)))
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
(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
free))
(_
(values
- (let-gensyms (kinit v)
+ (let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
(($ $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)))))))
(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))))))))
;;; 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
#: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))
($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
(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)))))
($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)))
(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)))))
#: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)
($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)
,(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
(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
(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)))
#: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)
($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
;; 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)))))
-
- (visit-fun fun)))
+ (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))))
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Commentary:
-;;;
-;;; Some bytecode operations can encode an immediate as an operand.
-;;; This pass tranforms generic primcalls to these specialized
-;;; primcalls, if possible.
-;;;
-;;; Code:
-
-(define-module (language cps specialize-primcalls)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #: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*)
- (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)))))
-
- (visit-fun fun)))
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; Some bytecode operations can encode an immediate as an operand.
+;;; This pass tranforms generic primcalls to these specialized
+;;; primcalls, if possible.
+;;;
+;;; Code:
+
+(define-module (language cps specialize-primcalls)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (specialize-primcalls))
+
+(define (specialize-primcalls fun)
+ (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
+ ($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)))))
+
+ (visit-fun fun))))
#: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
HCoop / bpt / guile.git / commitdiff