mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 19:20:23 +02:00
Code Activity

$primcall always continues to $kargs

Browse source 
* module/language/cps/devirtualize-integers.scm (peel-trace): Update
  comment.
* module/language/cps/contification.scm (apply-contification): Update to
  never contify a return of $primcall to $kreceive.
* module/language/cps/verify.scm (check-arities): Require that primcalls
  continue to $kargs.
This commit is contained in:
Andy Wingo 2018-01-03 21:23:51 +01:00
parent 8248649966
commit 118f516a8b
3 changed files with 6 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

11
module/language/cps/contification.scm
View file

@ -413,19 +413,14 @@ function set."
(let ((k* (lookup-return-cont k))) (let ((k* (lookup-return-cont k)))
(if (eq? k k*) (if (eq? k k*)
(with-cps cps (build-term ($continue k src ,exp))) (with-cps cps (build-term ($continue k src ,exp)))
;; We are contifying this return. It must be a call, a ;; We are contifying this return. It must be a call or a
;; $primcall that can continue to $ktail (basically this is ;; $values expression. k* will be either a $ktail or a
;; only "throw" and friends), or a $values expression. k* ;; $kreceive continuation.
;; will be either a $ktail or a $kreceive continuation.
(match (intmap-ref conts k*) (match (intmap-ref conts k*)
(($ $kreceive ($ $arity req () rest () #f) kargs) (($ $kreceive ($ $arity req () rest () #f) kargs)
(match exp (match exp
(($ $call) (($ $call)
(with-cps cps (build-term ($continue k* src ,exp)))) (with-cps cps (build-term ($continue k* src ,exp))))
;; A primcall that can continue to $ktail can also
;; continue to $kreceive.
(($ $primcall)
(with-cps cps (build-term ($continue k* src ,exp))))
;; We need to punch through the $kreceive; otherwise we'd ;; We need to punch through the $kreceive; otherwise we'd
;; have to rewrite as a call to the 'values primitive. ;; have to rewrite as a call to the 'values primitive.
(($ $values vals) (($ $values vals)

3
module/language/cps/devirtualize-integers.scm
View file

@ -123,7 +123,8 @@ the trace should be referenced outside of it."
(match (intmap-ref cps label) (match (intmap-ref cps label)
;; We know the initial label is a $kargs, and we won't follow the ;; We know the initial label is a $kargs, and we won't follow the
;; graph to get to $kreceive etc, so we can stop with these two ;; graph to get to $kreceive etc, so we can stop with these two
;; continuation kinds. ;; continuation kinds. (For our purposes, only $values can
;; continue to $ktail.)
(($ $ktail) (fail)) (($ $ktail) (fail))
(($ $kargs names vars term) (($ $kargs names vars term)
(let* ((vars-of-interest (let* ((vars-of-interest

7
module/language/cps/verify.scm
View file

@ -282,12 +282,7 @@ definitions that are available at LABEL."
(assert-kreceive-or-ktail)) (assert-kreceive-or-ktail))
(($ $primcall name param args) (($ $primcall name param args)
(match cont (match cont
(($ $kargs) #t) (($ $kargs) #t)))))
;; FIXME: Remove this case; instead use $prim and $call.
(($ $kreceive) #t)
(($ $ktail)
(unless (memv name '(throw throw/value throw/value+data))
(error "primitive should continue to $kargs, not $ktail" name)))))))
(define (check-term term) (define (check-term term)
(match term (match term
(($ $continue k src exp) (($ $continue k src exp)