mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

$prompt is now its own kind of CPS term.

Browse source 
* module/language/cps.scm ($prompt): Rework to be its own term kind.
  Now $continue always continues to a single continuation.  Adapt
  callers.
This commit is contained in:
Andy Wingo 2018-01-03 17:17:23 +01:00
parent 29fee39c2a
commit ee15ca1455
22 changed files with 198 additions and 195 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/language/cps/licm.scm
View file

@ -68,7 +68,6 @@
loop-effects #t))
(match exp
((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ?
(($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args))
@ -137,14 +136,6 @@
((not (loop-invariant? label exp loop-vars loop-effects
always-reached?))
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
(loop-vars (match exp
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive arity kargs)
(match (intmap-ref cps kargs)
(($ $kargs names vars)
(adjoin-loop-vars loop-vars vars))))))
(_ loop-vars)))
(cont (build-cont
($kargs names vars
($continue k src ,exp))))
@ -216,6 +207,16 @@
(($ $branch)
(let* ((cont (build-cont ($kargs names vars ,term)))
(always-reached? #f))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?)))
(($ $prompt k kh src escape? tag)
(let* ((loop-vars (match (intmap-ref cps kh)
(($ $kreceive arity kargs)
(match (intmap-ref cps kargs)
(($ $kargs names vars)
(adjoin-loop-vars loop-vars vars))))))
(cont (build-cont ($kargs names vars ,term)))
(always-reached? #f))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?))))))
(($ $kreceive ($ $arity req () rest) kargs)
@ -259,6 +260,9 @@
(($ $kargs names vars ($ $branch kf kt src op param args))
($kargs names vars
($branch (rename kf) (rename kt) src op param args)))
(($ $kargs names vars ($ $prompt k kh src escape? tag))
($kargs names vars
($prompt (rename k) (rename kh) src escape? tag)))
(($ $kargs names vars ($ $continue k src exp))
($kargs names vars
($continue (rename k) src ,exp)))