add call-consuming-continuation-attachment
Also, rename `call-with-current-continuation-attachment` to `call-getting-continuation-attachment`. original commit: e2a00e6d641b92918c4911c27ba14949748fd291
This commit is contained in:
Matthew Flatt
parent
b842a134fd
commit
c57de26c1d
|
|
@ -17,7 +17,7 @@ m = ta6osx
|
|||
Cpu = X86_64
|
||||
|
||||
mdclib = -liconv -lm ${ncursesLib}
|
||||
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
|
||||
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -g -O2 -I/opt/X11/include/ ${CFLAGS}
|
||||
o = o
|
||||
mdsrc = i3le.c
|
||||
mdobj = i3le.o
|
||||
|
|
|
|||
|
|
@ -306,9 +306,10 @@ since an error or long-running computation can leave interrupts
|
|||
and automatic garbage collection disabled.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader\label{call-setting-continuation-attachment}\label{call-with-current-continuation-attachment}
|
||||
\entryheader\label{call-setting-continuation-attachment}\label{call-getting-current-continuation-attachment}\label{call-consuming-current-continuation-attachment}
|
||||
\formdef{call-setting-continuation-attachment}{\categoryprocedure}{(call-setting-continuation-attachment \var{val} \var{procedure})}
|
||||
\formdef{call-with-current-continuation-attachment}{\categoryprocedure}{(call-with-current-continuation-attachment \var{default-val} \var{procedure})}
|
||||
\formdef{call-getting-continuation-attachment}{\categoryprocedure}{(call-getting-continuation-attachment \var{default-val} \var{procedure})}
|
||||
\formdef{call-consuming-continuation-attachment}{\categoryprocedure}{(call-consuming-continuation-attachment \var{default-val} \var{procedure})}
|
||||
\returns the values returned by \var{procedure}
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
|
@ -321,7 +322,7 @@ current continuation to \var{val}. The continuation of the call to
|
|||
current continuation). If the current continuation already has an
|
||||
attachment, it is replaced by \var{val}.
|
||||
|
||||
\scheme{call-with-current-continuation-attachment} calls
|
||||
\scheme{call-getting-continuation-attachment} calls
|
||||
\var{procedure} with one argument: the current continuation's
|
||||
attachment, if any, or the value of \var{default-val} if the current
|
||||
continuation has no attachment. The continuation of the call to
|
||||
|
|
@ -329,11 +330,24 @@ continuation has no attachment. The continuation of the call to
|
|||
\scheme{call-with-current-continuation-attachment} (i.e., it is still
|
||||
the current continuation).
|
||||
|
||||
\scheme{call-consuming-continuation-attachment} is like
|
||||
\scheme{call-getting-continuation-attachment}, but if the
|
||||
current continuation has an attachment, the attachment is
|
||||
removed.
|
||||
|
||||
\schemedisplay
|
||||
(call-getting-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a)))) ; => nothing
|
||||
|
||||
(call-consuming-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a)))) ; => nothing
|
||||
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a)))) ; => milk
|
||||
|
||||
|
|
@ -341,7 +355,8 @@ the current continuation).
|
|||
'milk
|
||||
(lambda ()
|
||||
(list
|
||||
(call-with-current-continuation-attachment
|
||||
; not in tail position:
|
||||
(call-getting-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a))))) ; => (nothing)
|
||||
|
||||
|
|
@ -349,7 +364,7 @@ the current continuation).
|
|||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a))))) ; => (milk)
|
||||
|
||||
|
|
@ -359,9 +374,19 @@ the current continuation).
|
|||
(call-setting-continuation-attachment
|
||||
'water
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'nothing
|
||||
(lambda (a) a)))))) ; => water
|
||||
|
||||
(call-setting-continuation-attachment
|
||||
'milk
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'water
|
||||
(lambda (a)
|
||||
(call-getting-continuation-attachment
|
||||
'nothing
|
||||
(lambda (b) (list a b))))))) ; => (milk nothing)
|
||||
\endschemedisplay
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
|
|
|
|||
163
mats/4.ms
163
mats/4.ms
|
|
@ -3185,10 +3185,15 @@
|
|||
(error? (call-setting-continuation-attachment 'any void 'bad-more))
|
||||
(error? (call-setting-continuation-attachment 'any (lambda (x) x)))
|
||||
|
||||
(error? (call-with-current-continuation-attachment 'none))
|
||||
(error? (call-with-current-continuation-attachment 'none 10))
|
||||
(error? (call-with-current-continuation-attachment 'none (lambda (a) a) 'bad-more))
|
||||
(error? (call-with-current-continuation-attachment 'none void))
|
||||
(error? (call-getting-continuation-attachment 'none))
|
||||
(error? (call-getting-continuation-attachment 'none 10))
|
||||
(error? (call-getting-continuation-attachment 'none (lambda (a) a) 'bad-more))
|
||||
(error? (call-getting-continuation-attachment 'none void))
|
||||
|
||||
(error? (call-consuming-continuation-attachment 'none))
|
||||
(error? (call-consuming-continuation-attachment 'none 10))
|
||||
(error? (call-consuming-continuation-attachment 'none (lambda (a) a) 'bad-more))
|
||||
(error? (call-consuming-continuation-attachment 'none void))
|
||||
|
||||
(error? (continuation-next-attachments))
|
||||
(error? (continuation-next-attachments 10))
|
||||
|
|
@ -3196,7 +3201,8 @@
|
|||
(error? (continuation-next-attachments (call/cc (lambda (x) x)) 'bad-more))
|
||||
|
||||
(equal? (void) (call-setting-continuation-attachment 'any void))
|
||||
(equal? 'none (call-with-current-continuation-attachment 'none (lambda (a) a)))
|
||||
(equal? 'none (call-getting-continuation-attachment 'none (lambda (a) a)))
|
||||
(equal? 'none (call-consuming-continuation-attachment 'none (lambda (a) a)))
|
||||
(equal? '() (continuation-next-attachments (call/cc (lambda (x) x))))
|
||||
|
||||
(equal? '() (current-continuation-attachments))
|
||||
|
|
@ -3232,14 +3238,28 @@
|
|||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
(lambda (v) v)))))
|
||||
(equal? 'yes
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-with-current-continuation-attachment
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (v) v)))))
|
||||
(equal? 'yes
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
values))))
|
||||
(equal? 'yes
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
values))))
|
||||
(equal? '(no)
|
||||
|
|
@ -3247,7 +3267,7 @@
|
|||
'yes
|
||||
(lambda ()
|
||||
(list
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
(lambda (v) v))))))
|
||||
(equal? '(no)
|
||||
|
|
@ -3255,9 +3275,86 @@
|
|||
'yes
|
||||
(lambda ()
|
||||
(list
|
||||
(call-with-current-continuation-attachment
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (v) v))))))
|
||||
(equal? '(no)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(list
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
values)))))
|
||||
(equal? '(no)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(list
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
values)))))
|
||||
(equal? '(yes yes)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
(lambda (a)
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
(lambda (b)
|
||||
(list a b))))))))
|
||||
(equal? '(yes no)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (a)
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (b)
|
||||
(list a b))))))))
|
||||
(equal? '(yes again)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
(lambda (a)
|
||||
(call-setting-continuation-attachment
|
||||
'again
|
||||
(lambda ()
|
||||
(call-getting-continuation-attachment
|
||||
'no
|
||||
(lambda (b)
|
||||
(list a b))))))))))
|
||||
(equal? '(yes again)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (a)
|
||||
(call-setting-continuation-attachment
|
||||
'again
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (b)
|
||||
(list a b))))))))))
|
||||
(equal? '(no again)
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (a)
|
||||
(call-setting-continuation-attachment
|
||||
'again
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (b)
|
||||
(list a b))))))))
|
||||
(begin
|
||||
(define (call-with-yep f)
|
||||
(call-setting-continuation-attachment
|
||||
|
|
@ -3267,6 +3364,14 @@
|
|||
(call-setting-continuation-attachment
|
||||
'yeah
|
||||
f))
|
||||
(define (call-with-nothing f)
|
||||
(#%$value
|
||||
(f)))
|
||||
(define (call-with-nothing-in-split f)
|
||||
((call/cc
|
||||
(lambda (k)
|
||||
(#%$split-continuation k 0)
|
||||
f))))
|
||||
(define-syntax call-with-yeah*
|
||||
(syntax-rules ()
|
||||
[(_ f)
|
||||
|
|
@ -3274,9 +3379,18 @@
|
|||
'yeah
|
||||
f)]))
|
||||
(define (get-or-nope)
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'nope
|
||||
(lambda (x) x)))
|
||||
(define (consume-or-nope)
|
||||
(call-consuming-continuation-attachment
|
||||
'nope
|
||||
(lambda (x) x)))
|
||||
(define (consume-or-nope-cps k)
|
||||
(lambda ()
|
||||
(call-consuming-continuation-attachment
|
||||
'nope
|
||||
(lambda (x) (k x)))))
|
||||
(define (return-one) 1)
|
||||
(define (act-like-list . l) l)
|
||||
(define not-a-procedure 'something-else)
|
||||
|
|
@ -3290,6 +3404,7 @@
|
|||
r)))
|
||||
#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))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (call-with-yeah current-continuation-attachments))))
|
||||
(equal? '((yeah yep)) (call-with-yep (lambda () (list (call-with-yeah current-continuation-attachments)))))
|
||||
|
|
@ -3308,6 +3423,10 @@
|
|||
(equal? '(yeah) (call-with-yep (lambda () (list (call-with-yeah* (lambda () (get-or-nope)))))))
|
||||
(equal? '(yeah) (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (get-or-nope)))))))
|
||||
|
||||
(equal? 'nope (call-with-yep (consume-or-nope-cps
|
||||
(lambda (v)
|
||||
(get-or-nope)))))
|
||||
|
||||
(error? (call-with-yep (lambda () (call-with-yeah* (lambda () (not-a-procedure))))))
|
||||
(error? (call-with-yep (lambda () (list (call-with-yeah* (lambda () (not-a-procedure)))))))
|
||||
(error? (call-with-yep (lambda () (act-like-list (call-with-yeah* (lambda () (not-a-procedure)))))))
|
||||
|
|
@ -3390,7 +3509,7 @@
|
|||
(call-with-values (lambda () (return-three-values))
|
||||
(case-lambda
|
||||
[(x y z)
|
||||
(call-with-current-continuation-attachment
|
||||
(call-getting-continuation-attachment
|
||||
'nope
|
||||
(lambda (a) (list a x y z)))])))))
|
||||
|
||||
|
|
@ -3455,6 +3574,28 @@
|
|||
(lambda ()
|
||||
;; Not detected as a loop, but as a direct call
|
||||
(loop (add1 i)))))])))))
|
||||
(equal? 'yes
|
||||
(call-with-nothing
|
||||
(lambda ()
|
||||
;; This "consuming" will need to reify the continuation
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (v)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(get-or-nope))))))))
|
||||
(equal? 'yes
|
||||
(call-with-nothing-in-split
|
||||
(lambda ()
|
||||
;; This "consuming" will need to reify the continuation
|
||||
(call-consuming-continuation-attachment
|
||||
'no
|
||||
(lambda (v)
|
||||
(call-setting-continuation-attachment
|
||||
'yes
|
||||
(lambda ()
|
||||
(get-or-nope))))))))
|
||||
)
|
||||
|
||||
;;; section 4-7:
|
||||
|
|
|
|||
165
s/cpnanopass.ss
165
s/cpnanopass.ss
|
|
@ -1559,19 +1559,36 @@
|
|||
|
||||
(define-pass np-recognize-attachment : L4.875 (ir) -> L4.9375 ()
|
||||
(definitions
|
||||
;; Modes:
|
||||
;; - 'tail => in tail position, unknown whether continuation is reified
|
||||
;; or whether attachment exists
|
||||
;; - 'tail/some => in tail position, continuation is reified,
|
||||
;; attachment definitely exists
|
||||
;; - 'tail/none => in tail position, continuation is reified,
|
||||
;; attachment definitely does not exist
|
||||
;; - 'non/none => not in tail position, no attachment pushed
|
||||
;; - 'non/some => not in tail position, attachment pushed and needs
|
||||
;; to be popped when leaving the nested context (which
|
||||
;; may involve transferring to a reified continuation
|
||||
;; if a function is called in relative tail position)
|
||||
(define return
|
||||
(lambda (mode x)
|
||||
(case mode
|
||||
[(pop) (with-output-language (L4.9375 Expr)
|
||||
[(non/some) (with-output-language (L4.9375 Expr)
|
||||
`(seq
|
||||
(attachment-set pop)
|
||||
,x))]
|
||||
[else x])))
|
||||
(define ->in-wca
|
||||
(define ->in-set
|
||||
(lambda (mode)
|
||||
(case mode
|
||||
[(non-tail pop) 'pop]
|
||||
[(tail tail/reified) 'tail/reified])))
|
||||
[(non/none non/some) 'non/some]
|
||||
[(tail tail/some tail/none) 'tail/some])))
|
||||
(define ->in-consume
|
||||
(lambda (mode)
|
||||
(case mode
|
||||
[(non/none non/some) 'non/none]
|
||||
[(tail tail/some tail/none) 'tail/none])))
|
||||
(define info-call->shifting-info-call
|
||||
(lambda (info)
|
||||
(make-info-call (info-call-src info) (info-call-sexpr info)
|
||||
|
|
@ -1585,60 +1602,82 @@
|
|||
(CaseLambdaClause : CaseLambdaClause (cl) -> CaseLambdaClause ()
|
||||
[(clause (,x* ...) ,interface ,[Expr : body 'tail -> body])
|
||||
`(clause (,x* ...) ,interface ,body)])
|
||||
(Expr : Expr (ir [mode 'non-tail]) -> Expr ()
|
||||
;; See start of pass for description of `mode`
|
||||
(Expr : Expr (ir [mode 'non/none]) -> Expr ()
|
||||
[,x (return mode x)]
|
||||
[(letrec ([,x* ,[le* 'non-tail -> le*]] ...) ,[body])
|
||||
[(letrec ([,x* ,[le* 'non/none -> le*]] ...) ,[body])
|
||||
`(letrec ([,x* ,le*] ...) ,body)]
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non-tail -> e1]
|
||||
(case-lambda ,info2 (clause () ,interface ,[body (->in-wca mode) -> body])))
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non/none -> e1]
|
||||
(case-lambda ,info2 (clause () ,interface ,[body (->in-set mode) -> body])))
|
||||
(guard (and (eq? (primref-name pr) 'call-setting-continuation-attachment)
|
||||
(= interface 0)))
|
||||
(case mode
|
||||
[(pop tail/reified)
|
||||
[(non/some tail/some)
|
||||
;; Definitely an attachment in place
|
||||
`(seq (attachment-set set ,e1) ,body)]
|
||||
[(tail/none)
|
||||
;; Definitely not an attachment in place; continuation is reified
|
||||
`(seq (attachment-set push ,e1) ,body)]
|
||||
[(tail)
|
||||
;; Check dynamically for reified continuation and attachment
|
||||
`(seq (attachment-set reify-and-set ,e1) ,body)]
|
||||
[(non-tail)
|
||||
[(non/none)
|
||||
;; Push attachment; `body` has been adjusted to pop
|
||||
`(seq (attachment-set push ,e1) ,body)])]
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non-tail -> e1]
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non/none -> e1]
|
||||
(case-lambda ,info2 (clause (,x) ,interface ,[body])))
|
||||
(guard (and (eq? (primref-name pr) 'call-with-current-continuation-attachment)
|
||||
(guard (and (eq? (primref-name pr) 'call-getting-continuation-attachment)
|
||||
(= interface 1)))
|
||||
(case mode
|
||||
[(non-tail)
|
||||
;; No surrounding `with-continuation-attachment`
|
||||
[(non/none tail/none)
|
||||
;; No surrounding `call-setting-continuation-attachment`
|
||||
`(let ([,x ,e1]) ,body)]
|
||||
[(pop tail/reified)
|
||||
;; Defintely an attachment in place
|
||||
[(non/some tail/some)
|
||||
;; Definitely an attachment in place
|
||||
`(seq ,e1 (let ([,x (attachment-get)]) ,body))]
|
||||
[else
|
||||
;; Check dynamically for attachment
|
||||
`(let ([,x (attachment-get ,e1)]) ,body)])]
|
||||
[(call ,info ,mdcl ,[e 'non-tail -> e] ,[e* 'non-tail -> e*] ...)
|
||||
[(call ,info ,mdcl ,pr ,[e1 'non/none -> e1]
|
||||
(case-lambda ,info2 (clause (,x) ,interface ,[body (->in-consume mode) -> body])))
|
||||
(guard (and (eq? (primref-name pr) 'call-consuming-continuation-attachment)
|
||||
(= interface 1)))
|
||||
;; Currently, `call-consuming-continuation-attachment` in tail position
|
||||
;; reifies the continuation, because we expect it to be combined with
|
||||
;; `call-setting-continuation-attachment` in `body`. Since the continuation
|
||||
;; is reified here, `call-setting-continuation-attachment` can simply push.
|
||||
(case mode
|
||||
[(non/none tail/none)
|
||||
;; No surrounding `call-setting-continuation-attachment`, but reified if tail
|
||||
`(let ([,x ,e1]) ,body)]
|
||||
[(non/some tail/some)
|
||||
;; Definitely an attachment in place
|
||||
`(seq ,e1 (let ([,x (attachment-consume)]) ,body))]
|
||||
[else
|
||||
;; Check dynamically for attachment, and also reify for tail
|
||||
`(let ([,x (attachment-consume ,e1)]) ,body)])]
|
||||
[(call ,info ,mdcl ,[e 'non/none -> e] ,[e* 'non/none -> e*] ...)
|
||||
(let ([info (case mode
|
||||
[(pop) (info-call->shifting-info-call info)]
|
||||
[(non/some) (info-call->shifting-info-call info)]
|
||||
[else info])])
|
||||
`(call ,info ,mdcl ,e ,e* ...))]
|
||||
[(foreign-call ,info ,[e 'non-tail -> e] ,[e* 'non-tail -> e*] ...)
|
||||
[(foreign-call ,info ,[e 'non/none -> e] ,[e* 'non/none -> e*] ...)
|
||||
(return mode `(foreign-call ,info ,e ,e* ...))]
|
||||
[(fcallable ,info) (return mode `(fcallable ,info))]
|
||||
[(label ,l ,[body]) `(label ,l ,body)]
|
||||
[(mvlet ,[e 'non-tail -> e] ((,x** ...) ,interface* ,[body*]) ...)
|
||||
[(mvlet ,[e 'non/none -> e] ((,x** ...) ,interface* ,[body*]) ...)
|
||||
`(mvlet ,e ((,x** ...) ,interface* ,body*) ...)]
|
||||
[(mvcall ,info ,[e1 'non-tail -> e1] ,[e2 'non-tail -> e2])
|
||||
[(mvcall ,info ,[e1 'non/none -> e1] ,[e2 'non/none -> e2])
|
||||
(let ([info (case mode
|
||||
[(pop) (info-call->consumer-shifting-info-call info #t)]
|
||||
[(non/some) (info-call->consumer-shifting-info-call info #t)]
|
||||
[else (info-call->consumer-shifting-info-call info #f)])])
|
||||
`(mvcall ,info ,e1 ,e2))]
|
||||
[(let ([,x* ,[e* 'non-tail -> e*]] ...) ,[body])
|
||||
[(let ([,x* ,[e* 'non/none -> e*]] ...) ,[body])
|
||||
`(let ([,x* ,e*] ...) ,body)]
|
||||
[(case-lambda ,info ,[cl] ...) (return mode `(case-lambda ,info ,cl ...))]
|
||||
[(quote ,d) (return mode `(quote ,d))]
|
||||
[(if ,[e0 'non-tail -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
|
||||
[(seq ,[e0 'non-tail -> e0] ,[e1]) `(seq ,e0 ,e1)]
|
||||
[(if ,[e0 'non/none -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
|
||||
[(seq ,[e0 'non/none -> e0] ,[e1]) `(seq ,e0 ,e1)]
|
||||
[(profile ,src) `(profile ,src)]
|
||||
[(pariah) `(pariah)]
|
||||
[,pr (return mode pr)]
|
||||
|
|
@ -10042,6 +10081,10 @@
|
|||
(Triv* e*
|
||||
(lambda (t*)
|
||||
(k `(attachment-get ,t* ...))))]
|
||||
[(attachment-consume ,e* ...)
|
||||
(Triv* e*
|
||||
(lambda (t*)
|
||||
(k `(attachment-consume ,t* ...))))]
|
||||
[(attachment-set ,aop ,e* ...)
|
||||
(Triv* e*
|
||||
(lambda (t*)
|
||||
|
|
@ -10405,6 +10448,8 @@
|
|||
`(tail (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...)))]
|
||||
[(set! ,[lvalue] (attachment-get ,[t*] ...))
|
||||
`(set! ,lvalue (attachment-get ,t* ...))]
|
||||
[(set! ,[lvalue] (attachment-consume ,[t*] ...))
|
||||
`(set! ,lvalue (attachment-consume ,t* ...))]
|
||||
[(label ,l ,[ebody]) `(seq (label ,l) ,ebody)]
|
||||
[(trap-check ,ioc ,[ebody]) `(seq (trap-check ,ioc) ,ebody)]
|
||||
[(overflow-check ,[ebody]) `(seq (overflow-check) ,ebody)]
|
||||
|
|
@ -11710,7 +11755,44 @@
|
|||
,(%seq
|
||||
(set! ,(%mref ,%xp ,(constant continuation-stack-length-disp)) ,%ac0)
|
||||
(set! ,%xp ,(%mref ,%xp ,(constant continuation-link-disp)))
|
||||
(goto ,Ltop))))))))))))
|
||||
(goto ,Ltop)))))))))))
|
||||
(define (build-attachment-get lvalue t consume? reify?)
|
||||
(let ([uf (make-tmp 'uf)]
|
||||
[sl (make-tmp 'sl)]
|
||||
[ats (make-tmp 'ats)])
|
||||
(with-output-language (L13 Effect)
|
||||
(%seq
|
||||
(set! ,uf (literal ,(make-info-literal #f 'library-code
|
||||
(lookup-libspec dounderflow)
|
||||
(fx+ (constant code-data-disp) (constant size-rp-header)))))
|
||||
(if ,(%inline eq? ,%ref-ret ,uf)
|
||||
;; Maybe reified, so maybe an attachment
|
||||
,(%seq
|
||||
(set! ,sl ,(%tc-ref stack-link))
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(if ,(%inline eq? ,(%mref ,sl ,(constant continuation-attachments-disp)) ,ats)
|
||||
;; Reified, no attachment
|
||||
(set! ,lvalue ,t)
|
||||
(if ,(%inline eq? ,(%mref ,sl ,(constant continuation-attachments-disp)) ,(%constant sfalse))
|
||||
;; Not reified, so no attachment
|
||||
,(if (not reify?)
|
||||
`(set! ,lvalue ,t)
|
||||
(%seq
|
||||
(set! ,lvalue ,t)
|
||||
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))))
|
||||
;; Reified with attachment
|
||||
,(let ([get `(set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))])
|
||||
(if consume?
|
||||
(%seq
|
||||
(set! ,(%tc-ref attachments) ,(%mref ,ats ,(constant pair-cdr-disp)))
|
||||
,get)
|
||||
get)))))
|
||||
;; Not reified, so no attachment
|
||||
,(if (not reify?)
|
||||
`(set! ,lvalue ,t)
|
||||
(%seq
|
||||
(set! ,lvalue ,t)
|
||||
(set! ,%td (inline ,(intrinsic-info-asmlib reify-cc #f) ,%asmlibcall))))))))))
|
||||
(Program : Program (ir) -> Program ()
|
||||
[(labels ([,l* ,le*] ...) ,l)
|
||||
`(labels ([,l* ,(map CaseLambdaExpr le* l*)] ...) ,l)])
|
||||
|
|
@ -11904,7 +11986,9 @@
|
|||
[(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))
|
||||
($oops who "Effect is responsible for handling mvcalls")]
|
||||
[(attachment-get ,t* ...)
|
||||
($oops who "Effect is responsible for handling attachment-gets")])
|
||||
($oops who "Effect is responsible for handling attachment-gets")]
|
||||
[(attachment-consume ,t* ...)
|
||||
($oops who "Effect is responsible for handling attachment-consumes")])
|
||||
(Effect : Effect (ir) -> Effect ()
|
||||
[(do-rest ,fixed-args)
|
||||
(if (fx<= fixed-args dorest-intrinsic-max)
|
||||
|
|
@ -11963,25 +12047,18 @@
|
|||
[(set! ,[lvalue] (attachment-get ,[t]))
|
||||
;; Default expression => need to check for reified continuation
|
||||
;; and attachment beyond it
|
||||
(let ([uf (make-tmp 'uf)]
|
||||
[sl (make-tmp 'sl)]
|
||||
[ats (make-tmp 'ats)])
|
||||
(build-attachment-get lvalue t #f #f)]
|
||||
[(set! ,[lvalue] (attachment-consume))
|
||||
;; No default expression => an attachment is certainly available
|
||||
(let ([ats (make-tmp 'ats)])
|
||||
(%seq
|
||||
(set! ,uf (literal ,(make-info-literal #f 'library-code
|
||||
(lookup-libspec dounderflow)
|
||||
(fx+ (constant code-data-disp) (constant size-rp-header)))))
|
||||
(if ,(%inline eq? ,%ref-ret ,uf)
|
||||
;; Reified, so maybe an attachment
|
||||
,(%seq
|
||||
(set! ,sl ,(%tc-ref stack-link))
|
||||
(set! ,ats ,(%tc-ref attachments))
|
||||
(if (if ,(%inline eq? ,(%mref ,sl ,(constant continuation-attachments-disp)) ,ats)
|
||||
(true)
|
||||
,(%inline eq? ,(%mref ,sl ,(constant continuation-attachments-disp)) ,(%constant sfalse)))
|
||||
(set! ,lvalue ,t)
|
||||
(set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))))
|
||||
;; Not reified, so no attachment
|
||||
(set! ,lvalue ,t))))]
|
||||
(set! ,(%tc-ref attachments) ,(%mref ,ats ,(constant pair-cdr-disp)))
|
||||
(set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))))]
|
||||
[(set! ,[lvalue] (attachment-consume ,[t]))
|
||||
;; Default expression => need to check for reified continuation
|
||||
;; and attachment beyond it
|
||||
(build-attachment-get lvalue t #t #t)]
|
||||
[(attachment-set ,aop)
|
||||
(case aop
|
||||
[(pop)
|
||||
|
|
|
|||
|
|
@ -393,7 +393,8 @@
|
|||
(entry CaseLambdaExpr)
|
||||
(Expr (e body)
|
||||
(+ (attachment-set aop e* ...)
|
||||
(attachment-get e* ...))))
|
||||
(attachment-get e* ...)
|
||||
(attachment-consume e* ...))))
|
||||
|
||||
; moves all case lambda expressions into rhs of letrec
|
||||
(define-language L5 (extends L4.9375)
|
||||
|
|
@ -669,7 +670,8 @@
|
|||
(inline info prim t* ...) => (inline info prim t* ...)
|
||||
(mvcall info e t) => (mvcall e t)
|
||||
(foreign-call info t t* ...)
|
||||
(attachment-get t* ...)))
|
||||
(attachment-get t* ...)
|
||||
(attachment-consume t* ...)))
|
||||
(Expr (e body)
|
||||
(- lvalue
|
||||
(values info e* ...)
|
||||
|
|
@ -683,7 +685,8 @@
|
|||
(set! lvalue e)
|
||||
(mvcall info e1 e2)
|
||||
(foreign-call info e e* ...)
|
||||
(attachment-get e* ...))
|
||||
(attachment-get e* ...)
|
||||
(attachment-consume e* ...))
|
||||
(+ rhs
|
||||
(values info t* ...)
|
||||
(set! lvalue rhs))))
|
||||
|
|
|
|||
|
|
@ -1181,7 +1181,8 @@
|
|||
(bytevector-compress [sig [(ptr) -> (ptr)]] [flags])
|
||||
(bytevector-uncompress [sig [(ptr) -> (ptr)]] [flags])
|
||||
(call/1cc [sig [(procedure) -> (ptr ...)]] [flags])
|
||||
(call-with-current-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-consuming-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-getting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
(call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
|
||||
(call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument
|
||||
(call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags])
|
||||
|
|
|
|||
10
s/prims.ss
10
s/prims.ss
|
|
@ -389,11 +389,17 @@
|
|||
($oops who "~s is not a procedure" p))
|
||||
(#3%call-setting-continuation-attachment v (lambda () (p)))))
|
||||
|
||||
(define-who call-with-current-continuation-attachment
|
||||
(define-who call-getting-continuation-attachment
|
||||
(lambda (default-val p)
|
||||
(unless (procedure? p)
|
||||
($oops who "~s is not a procedure" p))
|
||||
(#3%call-with-current-continuation-attachment default-val (lambda (x) (p x)))))
|
||||
(#3%call-getting-continuation-attachment default-val (lambda (x) (p x)))))
|
||||
|
||||
(define-who call-consuming-continuation-attachment
|
||||
(lambda (default-val p)
|
||||
(unless (procedure? p)
|
||||
($oops who "~s is not a procedure" p))
|
||||
(#3%call-consuming-continuation-attachment default-val (lambda (x) (p x)))))
|
||||
|
||||
(define $code? (lambda (x) ($code? x)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user