diff options
author | Andy Wingo <wingo@pobox.com> | 2013-10-23 15:07:34 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-10-26 14:38:11 +0200 |
commit | 4fc6b4d2c5566aa54393c3124def2d7759dd447a (patch) | |
tree | ca9fa5d584a3c460bac6afb747c14bf4b271407e | |
parent | 6fb508da2abdfeb7be1415b9d9561ed74bd75292 (diff) | |
download | guile-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.scm | 72 |
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 |