(define (fix-clause-arities clause)
(let ((conts (build-local-cont-table clause))
(ktail (match clause
- (($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+ (($ $cont _ ($ $kentry _ ($ $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)))
- (($ $continue k exp)
- ,(visit-exp k exp))))
+ (($ $continue k src exp)
+ ,(visit-exp k src exp))))
- (define (adapt-exp nvals k exp)
+ (define (adapt-exp nvals k src exp)
(match nvals
(0
(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
,(let-gensyms (kvoid kunspec unspec)
(build-cps-term
- ($letk* ((kunspec #f ($kargs (unspec) (unspec)
- ($continue k
- ($primcall 'return (unspec)))))
- (kvoid #f ($kargs () ()
- ($continue kunspec ($void)))))
- ($continue kvoid ,exp)))))
+ ($letk* ((kunspec ($kargs (unspec) (unspec)
+ ($continue k src
+ ($primcall 'return (unspec)))))
+ (kvoid ($kargs () ()
+ ($continue kunspec src ($void)))))
+ ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity () () #f () #f)
- ($continue kargs ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvoid kvalues void)
(build-cps-term
- ($letk* ((kvalues #f ($kargs ('void) (void)
- ($continue k
- ($primcall 'values (void)))))
- (kvoid #f ($kargs () ()
- ($continue kvalues
- ($void)))))
- ($continue kvoid ,exp)))))))
+ ($letk* ((kvalues ($kargs ('void) (void)
+ ($continue k src
+ ($primcall 'values (void)))))
+ (kvoid ($kargs () ()
+ ($continue kvalues src
+ ($void)))))
+ ($continue kvoid src ,exp)))))))
(($ $kargs () () _)
- ($continue k ,exp))
+ ($continue k src ,exp))
(_
,(let-gensyms (k*)
(build-cps-term
- ($letk ((k* #f ($kargs () () ($continue k ($void)))))
- ($continue k* ,exp)))))))
+ ($letk ((k* ($kargs () () ($continue k src ($void)))))
+ ($continue k* src ,exp)))))))
(1
(rewrite-cps-term (lookup-cont k conts)
(($ $ktail)
,(rewrite-cps-term exp
- (($var sym)
- ($continue ktail ($primcall 'return (sym))))
+ (($values (sym))
+ ($continue ktail src ($primcall 'return (sym))))
(_
,(let-gensyms (k* v)
(build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k
- ($primcall 'return (v))))))
- ($continue k* ,exp)))))))
+ ($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 ,exp))
+ ($continue kargs src ,exp))
(_
,(let-gensyms (kvalues value)
(build-cps-term
- ($letk ((kvalues #f ($kargs ('value) (value)
- ($continue k
- ($primcall 'values (value))))))
- ($continue kvalues ,exp)))))))
+ ($letk ((kvalues ($kargs ('value) (value)
+ ($continue k src
+ ($primcall 'values (value))))))
+ ($continue kvalues src ,exp)))))))
(($ $kargs () () _)
,(let-gensyms (k* drop)
(build-cps-term
- ($letk ((k* #f ($kargs ('drop) (drop)
- ($continue k ($values ())))))
- ($continue k* ,exp)))))
+ ($letk ((k* ($kargs ('drop) (drop)
+ ($continue k src ($values ())))))
+ ($continue k* src ,exp)))))
(_
- ($continue k ,exp))))))
+ ($continue k src ,exp))))))
- (define (visit-exp k exp)
+ (define (visit-exp k src exp)
(rewrite-cps-term exp
((or ($ $void)
($ $const)
($ $prim)
- ($ $var))
- ,(adapt-exp 1 k exp))
+ ($ $values (_)))
+ ,(adapt-exp 1 k src exp))
(($ $fun)
- ,(adapt-exp 1 k (fix-arities exp)))
+ ,(adapt-exp 1 k src (fix-arities exp)))
(($ $call)
;; 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.
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $primcall 'return (arg))
;; Primcalls to return are in tail position.
- ($continue ktail ,exp))
+ ($continue ktail src ,exp))
(($ $primcall (? (lambda (name)
- (and (not (prim-rtl-instruction name))
+ (and (not (prim-instruction name))
(not (branching-primitive? name))))))
- ($continue k ,exp))
+ ($continue k src ,exp))
(($ $primcall name args)
,(match (prim-arity name)
((out . in)
(if (= in (length args))
- (adapt-exp out k exp)
+ (adapt-exp out k src
+ (let ((inst (prim-instruction name)))
+ (if (and inst (not (eq? inst name)))
+ (build-cps-exp ($primcall inst args))
+ exp)))
(let-gensyms (k* p*)
(build-cps-term
- ($letk ((k* #f ($kargs ('prim) (p*)
- ($continue k ($call p* args)))))
- ($continue k* ($prim name)))))))))
+ ($letk ((k* ($kargs ('prim) (p*)
+ ($continue k src ($call p* args)))))
+ ($continue k* src ($prim name)))))))))
(($ $values)
- ;; Values nodes are inserted by CPS optimization passes, so
- ;; we assume they are correct.
- ($continue k ,exp))
+ ;; Non-unary values nodes are inserted by CPS optimization
+ ;; passes, so we assume they are correct.
+ ($continue k src ,exp))
(($ $prompt)
- ($continue k ,exp))))
+ ($continue k src ,exp))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $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)
,cont)))
(rewrite-cps-cont clause
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
(define (fix-arities fun)
(rewrite-cps-exp fun
- (($ $fun meta free body)
- ($fun meta free ,(fix-clause-arities body)))))
+ (($ $fun src meta free body)
+ ($fun src meta free ,(fix-clause-arities body)))))
HCoop / bpt / guile.git / blobdiff