mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +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

51
module/language/cps/compile-bytecode.scm
View file

@ -307,28 +307,6 @@
(define (compile-effect label exp k)
(match exp
(($ $values ()) #f)
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args)
(emit-j asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size)
(emit-j asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (scope) (mod))
(emit-cache-current-module! asm (from-sp (slot mod)) scope))
(($ $primcall 'scm-set! annotation (obj idx val))
@ -428,6 +406,29 @@
(($ $primcall 'throw/value+data param (val))
(emit-throw/value+data asm (from-sp (slot val)) param))))
(define (compile-prompt label k kh escape? tag)
(match (intmap-ref cps kh)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args)
(emit-j asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves kh allocation))
(emit-reset-frame asm frame-size)
(emit-j asm (forward-label khandler-body))))))
(define (compile-values label exp syms)
(match exp
(($ $values args)
@ -627,7 +628,11 @@
(emit-source asm src))
(compile-test label (skip-elided-conts (1+ label))
(forward-label kf) (forward-label kt)
op param args))))
op param args))
(($ $prompt k kh src escape? tag)
(when src
(emit-source asm src))
(compile-prompt label (skip-elided-conts k) kh escape? tag))))
(define (compile-cont label cont)
(match cont