add call-consuming-continuation-attachment

Also, rename `call-with-current-continuation-attachment` to
`call-getting-continuation-attachment`.

original commit: e2a00e6d641b92918c4911c27ba14949748fd291

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

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
 
 %----------------------------------------------------------------------------

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-getting-continuation-attachment 'none))
-  (error? (call-with-current-continuation-attachment 'none 10))
+  (error? (call-getting-continuation-attachment 'none 10))
-  (error? (call-with-current-continuation-attachment 'none (lambda (a) a) 'bad-more))
+  (error? (call-getting-continuation-attachment 'none (lambda (a) a) 'bad-more))
-  (error? (call-with-current-continuation-attachment 'none void))
+  (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:

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
+                           `(seq
-                          (attachment-set pop)
+                             (attachment-set pop)
-                          ,x))]
+                             ,x))]
               [else x])))
-        (define ->in-wca
+        (define ->in-set
           (lambda (mode)
             (case mode
-              [(non-tail pop) 'pop]
+              [(non/none non/some) 'non/some]
-              [(tail tail/reified) 'tail/reified])))
+              [(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]
+        [(call ,info ,mdcl ,pr ,[e1 'non/none -> e1]
-               (case-lambda ,info2 (clause () ,interface ,[body (->in-wca mode) -> body])))
+               (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)
+           [(non/none tail/none)
-            ;; No surrounding `with-continuation-attachment`
+            ;; No surrounding `call-setting-continuation-attachment`
             `(let ([,x ,e1]) ,body)]
-           [(pop tail/reified)
+           [(non/some tail/some)
-            ;; Defintely an attachment in place
+            ;; 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)]
+        [(if ,[e0 'non/none -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
-        [(seq ,[e0 'non-tail -> e0] ,[e1]) `(seq ,e0 ,e1)]
+        [(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)]
+         (build-attachment-get lvalue t #f #f)]
-               [sl (make-tmp 'sl)]
+        [(set! ,[lvalue] (attachment-consume))
-               [ats (make-tmp 'ats)])
+         ;; No default expression => an attachment is certainly available
+         (let ([ats (make-tmp 'ats)])
            (%seq
-            (set! ,uf (literal ,(make-info-literal #f 'library-code
+            (set! ,ats ,(%tc-ref attachments))
-                                      (lookup-libspec dounderflow)
+            (set! ,(%tc-ref attachments)  ,(%mref ,ats ,(constant pair-cdr-disp)))
-                                      (fx+ (constant code-data-disp) (constant size-rp-header)))))
+            (set! ,lvalue ,(%mref ,ats ,(constant pair-car-disp)))))]
-            (if ,(%inline eq? ,%ref-ret ,uf)
+        [(set! ,[lvalue] (attachment-consume ,[t]))
-                ;; Reified, so maybe an attachment
+         ;; Default expression => need to check for reified continuation
-                ,(%seq
+         ;; and attachment beyond it
-                  (set! ,sl ,(%tc-ref stack-link))
+         (build-attachment-get lvalue t #t #t)]
-                  (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))))]
         [(attachment-set ,aop)
          (case aop
            [(pop)

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))))

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])

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)))