diff --git a/c/Mf-ta6osx b/c/Mf-ta6osx index 10335a8673..85c57c986c 100644 --- a/c/Mf-ta6osx +++ b/c/Mf-ta6osx @@ -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 diff --git a/csug/control.stex b/csug/control.stex index a6750cc420..fa9b6106c9 100644 --- a/csug/control.stex +++ b/csug/control.stex @@ -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 %---------------------------------------------------------------------------- diff --git a/mats/4.ms b/mats/4.ms index 729f221a38..a4dd35df3e 100644 --- a/mats/4.ms +++ b/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: diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 27e7d22e40..ba5f73dda0 100644 --- a/s/cpnanopass.ss +++ b/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) - `(seq - (attachment-set pop) - ,x))] + [(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! ,ats ,(%tc-ref attachments)) + (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) diff --git a/s/np-languages.ss b/s/np-languages.ss index 45ea70c9bd..4e4ef290e6 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -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)))) diff --git a/s/primdata.ss b/s/primdata.ss index bc66c982d8..85517d2771 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -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]) diff --git a/s/prims.ss b/s/prims.ss index 2db816550a..409fe01e6b 100644 --- a/s/prims.ss +++ b/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)))