summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-10-23 15:07:34 +0200
committerAndy Wingo <wingo@pobox.com>2013-10-26 14:38:11 +0200
commit4fc6b4d2c5566aa54393c3124def2d7759dd447a (patch)
treeca9fa5d584a3c460bac6afb747c14bf4b271407e
parent6fb508da2abdfeb7be1415b9d9561ed74bd75292 (diff)
downloadguile-4fc6b4d2c5566aa54393c3124def2d7759dd447a.tar.gz
Fix primcall return arities
* module/language/cps/arities.scm (fix-clause-arities): Primcalls of known arity that continue to ktrunc should, if their return arity does not match the ktrunc, adapt via a call to `values'. This call may later get removed.
-rw-r--r--module/language/cps/arities.scm72
1 files changed, 45 insertions, 27 deletions
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index b697ec02e..877750278 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -58,8 +58,20 @@
(kvoid #f ($kargs () ()
($continue kunspec ($void)))))
($continue kvoid ,exp)))))
- (($ $ktrunc ($ $arity () () #f () #f) kseq)
- ($continue kseq ,exp))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity () () #f () #f)
+ ($continue kargs ,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)))))))
(($ $kargs () () _)
($continue k ,exp))
(_
@@ -68,31 +80,37 @@
($letk ((k* #f ($kargs () () ($continue k ($void)))))
($continue k* ,exp)))))))
(1
- (let ((drop-result
- (lambda (kseq)
- (let-gensyms (k* drop)
- (build-cps-term
- ($letk ((k* #f ($kargs ('drop) (drop)
- ($continue kseq ($values ())))))
- ($continue k* ,exp)))))))
- (rewrite-cps-term (lookup-cont k conts)
- (($ $ktail)
- ,(rewrite-cps-term exp
- (($var sym)
- ($continue ktail ($primcall 'return (sym))))
- (_
- ,(let-gensyms (k* v)
- (build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k
- ($primcall 'return (v))))))
- ($continue k* ,exp)))))))
- (($ $ktrunc ($ $arity () () #f () #f) kseq)
- ,(drop-result kseq))
- (($ $kargs () () _)
- ,(drop-result k))
- (_
- ($continue k ,exp)))))))
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(rewrite-cps-term exp
+ (($var sym)
+ ($continue ktail ($primcall 'return (sym))))
+ (_
+ ,(let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k
+ ($primcall 'return (v))))))
+ ($continue k* ,exp)))))))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity (_) () #f () #f)
+ ($continue kargs ,exp))
+ (_
+ ,(let-gensyms (kvalues value)
+ (build-cps-term
+ ($letk ((kvalues #f ($kargs ('value) (value)
+ ($continue k
+ ($primcall 'values (value))))))
+ ($continue kvalues ,exp)))))))
+ (($ $kargs () () _)
+ ,(let-gensyms (k* drop)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('drop) (drop)
+ ($continue k ($values ())))))
+ ($continue k* ,exp)))))
+ (_
+ ($continue k ,exp))))))
(define (visit-exp k exp)
(rewrite-cps-term exp