mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

Fix primcall return arities

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-10-23 15:07:34 +02:00
parent 6fb508da2a
commit 4fc6b4d2c5
1 changed files with 45 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

72
module/language/cps/arities.scm
View file

@ -58,8 +58,20 @@
(kvoid #f ($kargs () () (kvoid #f ($kargs () ()
($continue kunspec ($void))))) ($continue kunspec ($void)))))
($continue kvoid ,exp))))) ($continue kvoid ,exp)))))
(($ $ktrunc ($ $arity () () #f () #f) kseq) (($ $ktrunc arity kargs)
($continue kseq ,exp)) ,(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 () () _) (($ $kargs () () _)
($continue k ,exp)) ($continue k ,exp))
(_ (_
@ -68,31 +80,37 @@
($letk ((k* #f ($kargs () () ($continue k ($void))))) ($letk ((k* #f ($kargs () () ($continue k ($void)))))
($continue k* ,exp))))))) ($continue k* ,exp)))))))
(1 (1
(let ((drop-result (rewrite-cps-term (lookup-cont k conts)
(lambda (kseq) (($ $ktail)
(let-gensyms (k* drop) ,(rewrite-cps-term exp
(build-cps-term (($var sym)
($letk ((k* #f ($kargs ('drop) (drop) ($continue ktail ($primcall 'return (sym))))
($continue kseq ($values ()))))) (_
($continue k* ,exp))))))) ,(let-gensyms (k* v)
(rewrite-cps-term (lookup-cont k conts) (build-cps-term
(($ $ktail) ($letk ((k* #f ($kargs (v) (v)
,(rewrite-cps-term exp ($continue k
(($var sym) ($primcall 'return (v))))))
($continue ktail ($primcall 'return (sym)))) ($continue k* ,exp)))))))
(_ (($ $ktrunc arity kargs)
,(let-gensyms (k* v) ,(rewrite-cps-term arity
(build-cps-term (($ $arity (_) () #f () #f)
($letk ((k* #f ($kargs (v) (v) ($continue kargs ,exp))
($continue k (_
($primcall 'return (v)))))) ,(let-gensyms (kvalues value)
($continue k* ,exp))))))) (build-cps-term
(($ $ktrunc ($ $arity () () #f () #f) kseq) ($letk ((kvalues #f ($kargs ('value) (value)
,(drop-result kseq)) ($continue k
(($ $kargs () () _) ($primcall 'values (value))))))
,(drop-result k)) ($continue kvalues ,exp)))))))
(_ (($ $kargs () () _)
($continue k ,exp))))))) ,(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) (define (visit-exp k exp)
(rewrite-cps-term exp (rewrite-cps-term exp