;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 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 primitives)
#:export (fix-arities))
-(define (fix-clause-arities clause)
- (let ((conts (build-local-cont-table clause))
- (ktail (match clause
- (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+(define (fix-arities* clause dfg)
+ (let ((ktail (match clause
+ (($ $cont _
+ ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
(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 fix-arities funs) ,(visit-term body)))
+ ($letrec names syms (map (lambda (fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(fix-arities* body dfg)))))
+ funs)
+ ,(visit-term body)))
(($ $continue k src exp)
,(visit-exp k src exp))))
(define (adapt-exp nvals k src exp)
(match nvals
(0
- (rewrite-cps-term (lookup-cont k conts)
+ (rewrite-cps-term (lookup-cont k dfg)
(($ $ktail)
- ,(let-gensyms (kvoid kunspec unspec)
+ ,(let-fresh (kvoid kunspec) (unspec)
(build-cps-term
($letk* ((kunspec ($kargs (unspec) (unspec)
($continue k src
($primcall 'return (unspec)))))
(kvoid ($kargs () ()
- ($continue kunspec src ($void)))))
+ ($continue kunspec src
+ ($const *unspecified*)))))
($continue kvoid src ,exp)))))
- (($ $ktrunc arity kargs)
- ,(rewrite-cps-term arity
- (($ $arity () () #f () #f)
- ($continue kargs src ,exp))
+ (($ $kreceive arity kargs)
+ ,(match arity
+ (($ $arity () () rest () #f)
+ (if rest
+ (let-fresh (knil) ()
+ (build-cps-term
+ ($letk ((knil ($kargs () ()
+ ($continue kargs src ($const '())))))
+ ($continue knil src ,exp))))
+ (build-cps-term
+ ($continue kargs src ,exp))))
(_
- ,(let-gensyms (kvoid kvalues void)
- (build-cps-term
- ($letk* ((kvalues ($kargs ('void) (void)
- ($continue k src
- ($primcall 'values (void)))))
- (kvoid ($kargs () ()
- ($continue kvalues src
- ($void)))))
- ($continue kvoid src ,exp)))))))
+ (let-fresh (kvoid kvalues) (void)
+ (build-cps-term
+ ($letk* ((kvalues ($kargs ('void) (void)
+ ($continue k src
+ ($primcall 'values (void)))))
+ (kvoid ($kargs () ()
+ ($continue kvalues src
+ ($const *unspecified*)))))
+ ($continue kvoid src ,exp)))))))
(($ $kargs () () _)
($continue k src ,exp))
(_
- ,(let-gensyms (k*)
+ ,(let-fresh (k*) ()
(build-cps-term
- ($letk ((k* ($kargs () () ($continue k src ($void)))))
+ ($letk ((k* ($kargs () () ($continue k src
+ ($const *unspecified*)))))
($continue k* src ,exp)))))))
(1
- (rewrite-cps-term (lookup-cont k conts)
+ (rewrite-cps-term (lookup-cont k dfg)
(($ $ktail)
,(rewrite-cps-term exp
- (($values (sym))
+ (($ $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
($primcall 'return (v))))))
($continue k* src ,exp)))))))
- (($ $ktrunc arity kargs)
- ,(rewrite-cps-term arity
- (($ $arity (_) () #f () #f)
- ($continue kargs src ,exp))
+ (($ $kreceive arity kargs)
+ ,(match arity
+ (($ $arity (_) () rest () #f)
+ (if rest
+ (let-fresh (kval) (val nil)
+ (build-cps-term
+ ($letk ((kval ($kargs ('val) (val)
+ ($letconst (('nil nil '()))
+ ($continue kargs src
+ ($values (val nil)))))))
+ ($continue kval src ,exp))))
+ (build-cps-term ($continue kargs src ,exp))))
(_
- ,(let-gensyms (kvalues value)
- (build-cps-term
- ($letk ((kvalues ($kargs ('value) (value)
- ($continue k src
- ($primcall 'values (value))))))
- ($continue kvalues src ,exp)))))))
+ (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 ())))))
(define (visit-exp k src exp)
(rewrite-cps-term exp
- ((or ($ $void)
- ($ $const)
+ ((or ($ $const)
($ $prim)
($ $values (_)))
,(adapt-exp 1 k src exp))
- (($ $fun)
- ,(adapt-exp 1 k src (fix-arities exp)))
- (($ $call)
+ (($ $fun free body)
+ ,(adapt-exp 1 k src (build-cps-exp
+ ($fun free ,(fix-arities* body dfg)))))
+ ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that
- ;; reason every non-tail call has an implicit adaptor
- ;; continuation to adapt the return to the target
- ;; continuation, and we don't need to do any adapting here.
+ ;; reason every non-tail call has a $kreceive continuation to
+ ;; adapt the return to the target continuation, and we don't
+ ;; need to do any adapting here.
+ ($continue k src ,exp))
+ (($ $branch)
+ ;; Assume branching primcalls have the correct arity.
($continue k src ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.
($continue ktail src ,exp))
(($ $primcall (? (lambda (name)
- (and (not (prim-rtl-instruction name))
+ (and (not (prim-instruction name))
(not (branching-primitive? name))))))
($continue k src ,exp))
(($ $primcall name args)
((out . in)
(if (= in (length args))
(adapt-exp out k src
- (let ((inst (prim-rtl-instruction name)))
+ (let ((inst (prim-instruction name)))
(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)))))
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(rewrite-cps-cont clause
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
(define (fix-arities fun)
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(fix-clause-arities body)))))
+ (let ((dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (fix-arities* fun dfg))))
HCoop / bpt / guile.git / blobdiff