suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix call/cc inside call-...-continuation-attachment

Browse Source 
Can't simply use a continuation reified by an attachment
operation, because it is probably a 1-shot continuation
that needs to be promoted.

original commit: 8201aff06df8011ffbc41f217d50e4c430d75bb5
This commit is contained in:
Matthew Flatt 2019-10-24 05:40:55 -06:00
parent f52283de7e
commit 9ae0e9b971
3 changed files with 29 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
mats/4.ms
View File

@ -3402,7 +3402,16 @@
(and (pair? ats)
(equal? (car ats) v)
r)))
#t)
(define (callcc-after-attachment proc)
(call-setting-continuation-attachment
'attach
(lambda ()
;; Expect this `call/cc` to be inlined, but most promote
;; the continuation created by `call-setting-continuation-attachment`
(call/cc
(lambda (k)
(proc k))))))
#t)
(equal? 'yep (call-with-yep get-or-nope))
(equal? 'yep (call-with-yep consume-or-nope))
(equal? 'yeah (call-with-yep (lambda () (call-with-yeah get-or-nope))))
@ -3616,6 +3625,11 @@
(if (procedure? v)
(v)
'no))))
(let ([proc (callcc-after-attachment
(lambda (k)
(lambda ()
(k (lambda () #t)))))])
(proc))
)
;;; section 4-7:

29
s/cpnanopass.ss
View File

@ -1665,12 +1665,7 @@
(= interface 1)))
;; Since we're in tail position, we can just reify the continuation and
;; put the stack link in the argument variable.
(let ([cop (case mode
[(tail/some tail/none)
;; Already reified
'get]
[else 'reify])])
`(let ([,x (continuation-get ,cop)]) ,body))]
`(let ([,x (continuation-get)]) ,body)]
[(call ,info ,mdcl ,[e 'non/none -> e] ,[e* 'non/none -> e*] ...)
(let ([info (case mode
[(non/some) (info-call->shifting-info-call info)]
@ -10104,7 +10099,7 @@
(Triv* e*
(lambda (t*)
(k `(attachment-set ,aop ,t* ...))))]
[(continuation-get ,cop) (k `(continuation-get ,cop))]
[(continuation-get) (k `(continuation-get))]
[(foreign-call ,info ,e0 ,e1* ...)
(Triv* (cons e0 e1*)
(lambda (t*)
@ -10466,8 +10461,8 @@
`(set! ,lvalue (attachment-get ,t* ...))]
[(set! ,[lvalue] (attachment-consume ,[t*] ...))
`(set! ,lvalue (attachment-consume ,t* ...))]
[(set! ,[lvalue] (continuation-get ,cop))
`(set! ,lvalue (continuation-get ,cop))]
[(set! ,[lvalue] (continuation-get))
`(set! ,lvalue (continuation-get))]
[(label ,l ,[ebody]) `(seq (label ,l) ,ebody)]
[(trap-check ,ioc ,[ebody]) `(seq (trap-check ,ioc) ,ebody)]
[(overflow-check ,[ebody]) `(seq (overflow-check) ,ebody)]
@ -10487,7 +10482,7 @@
(label ,join)))]
[(values ,info ,t* ...) `(nop)]
[(attachment-get ,t* ...) `(nop)]
[(continuation-get ,cop) `(nop)])
[(continuation-get) `(nop)])
(Tail : Expr (ir) -> Tail ()
[(inline ,info ,prim ,[t*] ...)
(guard (pred-primitive? prim))
@ -12017,7 +12012,7 @@
($oops who "Effect is responsible for handling attachment-gets")]
[(attachment-consume ,t* ...)
($oops who "Effect is responsible for handling attachment-consumes")]
[(continuation-get ,cop)
[(continuation-get)
($oops who "Effect is responsible for handling continuatio-get")])
(Effect : Effect (ir) -> Effect ()
[(do-rest ,fixed-args)
@ -12140,14 +12135,10 @@
,(make-push)))]
[else
($oops who "unexpected attachment-set mode ~s" aop)]))]
[(set! ,[lvalue] (continuation-get ,cop))
(case cop
[(get) `(set! ,lvalue ,(%tc-ref stack-link))]
[(reify) (%seq
(set! ,%td (inline ,(intrinsic-info-asmlib maybe-reify-cc #f) ,%asmlibcall))
(set! ,lvalue ,%td))]
[else
($oops who "unexpected continuation-set mode ~s" cop)])])
[(set! ,[lvalue] (continuation-get))
(%seq
(set! ,%td (inline ,(intrinsic-info-asmlib maybe-reify-cc #f) ,%asmlibcall))
(set! ,lvalue ,%td))])
(Tail : Tail (ir) -> Tail ()
[(entry-point (,x* ...) ,dcl ,mcp ,tlbody)
(unless (andmap (lambda (x) (eq? (uvar-type x) 'ptr)) x*)

13
s/np-languages.ss
View File

@ -387,21 +387,16 @@
(lambda (x)
(memq x '(push pop set reify-and-set))))
(define continuation-op?
(lambda (x)
(memq x '(get reify))))
; exposes continuation-attachment operations
(define-language L4.9375 (extends L4.875)
(terminals
(+ (attachment-op (aop))
(continuation-op (cop))))
(+ (attachment-op (aop))))
(entry CaseLambdaExpr)
(Expr (e body)
(+ (attachment-set aop e* ...)
(attachment-get e* ...)
(attachment-consume e* ...)
(continuation-get cop))))
(continuation-get))))
; moves all case lambda expressions into rhs of letrec
(define-language L5 (extends L4.9375)
@ -679,7 +674,7 @@
(foreign-call info t t* ...)
(attachment-get t* ...)
(attachment-consume t* ...)
(continuation-get cop)))
(continuation-get)))
(Expr (e body)
(- lvalue
(values info e* ...)
@ -695,7 +690,7 @@
(foreign-call info e e* ...)
(attachment-get e* ...)
(attachment-consume e* ...)
(continuation-get cop))
(continuation-get))
(+ rhs
(values info t* ...)
(set! lvalue rhs))))