cs: more direct application of continuations

pkgs/racket-benchmarks/tests/racket/benchmarks/control/cont.rkt

@@ -0,0 +1,31 @@
+#lang racket/base
+(require racket/include)
+
+(include "config.rktl")
+
+(define (f x) x)
+(set! f f)
+
+'----------------------------------------
+
+;; Capturing continuations
+'capture
+(times
+ (let loop ([i M] [k #f])
+   (if (zero? i)
+       k
+       (loop (sub1 i) (call/cc (lambda (k) k))))))
+
+;; Applying a continuation
+'apply
+(times
+ (let ([loop #f])
+   (let ([i (call/cc
+             (lambda (k)
+               (set! loop k)
+               M))])
+     (if (zero? i)
+         0
+         (loop (sub1 i))))))
+
+

pkgs/racket-benchmarks/tests/racket/benchmarks/control/cont.sch

@@ -0,0 +1,30 @@
+;; This file is meant to be run in Scheme
+
+(load "setup.rktl")
+(load "config.rktl")
+
+(show '----------------------------------------)
+
+;; Capturing continuations
+(show 'capture)
+(show
+ (times
+  (let loop ([i M] [k #f])
+    (if (zero? i)
+        k
+        (loop (sub1 i) (call/cc (lambda (k) k)))))))
+
+
+;; Applying a continuation
+(show 'apply)
+(show
+ (times
+  (let ([loop #f])
+    (let ([i (call/cc
+              (lambda (k)
+                (set! loop k)
+                M))])
+      (if (zero? i)
+          0
+          (loop (sub1 i)))))))
+

racket/src/cs/rumble/control.ss

@@ -183,7 +183,7 @@
       (eq-hashtable-set! avail-cache tag (if avail? 'yes 'no))))
   avail?)
 
-(define/who (maybe-future-barricade tag)
+(define (maybe-future-barricade tag)
   (when (current-future)
     (let ([fp (strip-impersonator (current-future-prompt))]
           [tag (strip-impersonator tag)])
@@ -516,44 +516,59 @@
      tag
      values)))
 
-;; Applying a continuation calls this internal function:
 (define (apply-continuation c args)
-  (start-uninterrupted 'continue)
   (cond
    [(composable-continuation? c)
-    ;; To compose the metacontinuation, first make sure the current
+    (apply-composable-continuation c args)]
-    ;; continuation is reified in `(current-metacontinuation)`:
-    (call-in-empty-metacontinuation-frame-for-compose
-     (lambda ()
-       ;; The current metacontinuation frame has an
-       ;; empty continuation, so we can "replace" that
-       ;; with the composable one:
-       (cond
-        [(and (null? (full-continuation-mc c))
-              (null? (full-continuation-winders c))
-              (eq? (current-mark-splice) (full-continuation-mark-splice c))
-              (let ([marks (continuation-next-attachments (full-continuation-k c))])
-                (or (null? marks)
-                    (and (null? (cdr marks))
-                         (eq? (car marks) 'empty)))))
-         ;; Shortcut for no winds and no change to break status:
-         (end-uninterrupted 'cc)
-         (#%apply (full-continuation-k c) args)]
-        [(not (composable-continuation-wind? c))
-         (apply-immediate-continuation/no-wind c args)]
-        [else
-         (apply-immediate-continuation c (reverse (full-continuation-mc c)) args)])))]
    [(non-composable-continuation? c)
     (apply-non-composable-continuation c args)]
    [(escape-continuation? c)
-    (let ([tag (escape-continuation-tag c)])
+    (apply-escape-continuation c args)]
-      (unless (continuation-prompt-available? tag)
+   [else
-        (end-uninterrupted 'escape-fail)
+    (raise-argument-error 'apply-continuation "continuation?" c)]))
-        (raise-continuation-error '|continuation application|
-                                  "attempt to jump into an escape continuation"))
-      (do-abort-current-continuation '|continuation application| tag args #t))]))
 
+;; Applying a composable continuation calls this internal function:
+(define (apply-composable-continuation c args)
+  (start-uninterrupted 'continue)
+  ;; To compose the metacontinuation, first make sure the current
+  ;; continuation is reified in `(current-metacontinuation)`:
+  (call-in-empty-metacontinuation-frame-for-compose
+   (lambda ()
+     ;; The current metacontinuation frame has an
+     ;; empty continuation, so we can "replace" that
+     ;; with the composable one:
+     (cond
+      [(and (null? (full-continuation-mc c))
+            (null? (full-continuation-winders c))
+            (eq? (current-mark-splice) (full-continuation-mark-splice c))
+            (let ([marks (continuation-next-attachments (full-continuation-k c))])
+              (or (null? marks)
+                  (and (null? (cdr marks))
+                       (eq? (car marks) 'empty)))))
+       ;; Shortcut for no winds and no change to break status:
+       (end-uninterrupted 'cc)
+       (#%apply (full-continuation-k c) args)]
+      [(not (composable-continuation-wind? c))
+       (apply-immediate-continuation/no-wind c args)]
+      [else
+       (apply-immediate-continuation c (reverse (full-continuation-mc c)) args)]))))
+
+;; Applying an escape continuation calls this internal function:
+(define (apply-escape-continuation c args)
+  (start-uninterrupted 'continue)
+  (let ([tag (escape-continuation-tag c)])
+    (unless (continuation-prompt-available? tag)
+      (end-uninterrupted 'escape-fail)
+      (raise-continuation-error '|continuation application|
+                                "attempt to jump into an escape continuation"))
+    (do-abort-current-continuation '|continuation application| tag args #t)))
+
+;; Applying a non-composable continuation calls this internal function:
 (define (apply-non-composable-continuation c args)
+  (start-uninterrupted 'continue)
+  (apply-non-composable-continuation* c args))
+
+(define (apply-non-composable-continuation* c args)
   (assert-in-uninterrupted)
   (let ([mc (current-metacontinuation)]
         [c-mc (full-continuation-mc c)]
@@ -598,7 +613,7 @@
              ;; If a winder changes the metacontinuation, then
              ;; start again:
              (lambda ()
-               (apply-non-composable-continuation c args)))])))])))
+               (apply-non-composable-continuation* c args)))])))])))
 
 ;; Apply a continuation within the current metacontinuation frame:
 (define (apply-immediate-continuation c rmc args)
@@ -627,7 +642,7 @@
      ;; non-composable continuation:
      (and (non-composable-continuation? c)
           (lambda ()
-            (apply-non-composable-continuation c args))))))
+            (apply-non-composable-continuation* c args))))))
 
 ;; Like `apply-immediate-continuation`, but don't run winders
 (define (apply-immediate-continuation/no-wind c args)
@@ -711,14 +726,17 @@
                             "attempt to cross a continuation barrier"))
 
 (define (set-continuation-applicables!)
-  (let ([add (lambda (rtd)
+  ;; These procedure registrations may be short-circuited by a special
-               (struct-property-set! prop:procedure
+  ;; case that dispatches directly to `apply-continuation`
-                                     rtd
+  (struct-property-set! prop:procedure
-                                     (lambda (c . args)
+                        (record-type-descriptor composable-continuation)
-                                       (apply-continuation c args))))])
+                        (lambda (c . args) (apply-composable-continuation c args)))
-    (add (record-type-descriptor composable-continuation))
+  (struct-property-set! prop:procedure
-    (add (record-type-descriptor non-composable-continuation))
+                        (record-type-descriptor non-composable-continuation)
-    (add (record-type-descriptor escape-continuation))))
+                        (lambda (c . args) (apply-non-composable-continuation c args)))
+  (struct-property-set! prop:procedure
+                        (record-type-descriptor escape-continuation)
+                        (lambda (c . args) (apply-escape-continuation c args))))
 
 ;; ----------------------------------------
 ;; Metacontinuation operations for continutions
@@ -789,7 +807,7 @@
          ;; for a non-composable continuation:
          (and (non-composable-continuation? dest-c)
               (lambda ()
-                (apply-non-composable-continuation dest-c dest-args)))))])))
+                (apply-non-composable-continuation* dest-c dest-args)))))])))
 
 (define (metacontinuation-frame-clear-cache mf)
   (metacontinuation-frame-update-mark-splice mf

racket/src/cs/rumble/procedure.ss

@@ -95,6 +95,12 @@
             (success-k f)
             f)
         (wrong-arity-wrapper orig-f))]
+   [(continuation? f)
+    (let ([p (lambda args
+               (apply-continuation f args))])
+      (if success-k
+          (success-k p)
+          p))]
    [(record? f)
     (let* ([rtd (record-rtd f)]
            [v (struct-property-ref prop:procedure rtd none)])