add continuation-mark-set->iterator

Support continuation-mark inspection proportional to the amount that
needs to be inspected, instead of having to build a list of length
propotional to the size of a continuation.

In Racket CS, use iteration to improve exception-handling chaining.
Traditional Racket already used similar functonality internally.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.5.0.6")
+(define version "7.5.0.7")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

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

@@ -0,0 +1,40 @@
+#lang racket/base
+(require racket/include)
+
+(include "config.rktl")
+
+'----------------------------------------
+
+'exn
+(time
+ (for/fold ([v #f]) ([i (in-range Q)])
+   (with-handlers ([(lambda (x) #t) (lambda (x) 'caught)])
+     (raise 'exn))))
+
+'exn-deep
+(time
+ (let loop ([n 1000])
+   (if (zero? n)
+       (for/fold ([v #f]) ([i (in-range Q)])
+         (with-handlers ([(lambda (x) #t) (lambda (x) 'caught)])
+           (raise 'exn)))
+       (with-continuation-mark
+        'key 'val
+        (values (loop (sub1 n)))))))
+
+;; Runs a chain of 1000 handlers
+'exn-chain
+(time
+ (for/fold ([v #f]) ([i (in-range (quotient Q 100))])
+   (let/ec esc
+     (call-with-exception-handler
+      (lambda (exn) (esc 'done))
+      (lambda ()
+        (let loop ([n 1000])
+          (if (zero? n)
+              (raise 'exn)
+              (call-with-exception-handler
+               (lambda (exn) exn)
+               (lambda ()
+                 (values (loop (sub1 n))))))))))))
+

pkgs/racket-doc/scribblings/reference/cont-marks.scrbl

@@ -85,7 +85,9 @@ Returns a newly-created list containing the marks for @racket[key-v]
 in @racket[mark-set], which is a set of marks returned by
 @racket[current-continuation-marks]. The result list is truncated at
 the first point, if any, where continuation frames were originally
-separated by a prompt tagged with @racket[prompt-tag].}
+separated by a prompt tagged with @racket[prompt-tag]. Producing the result
+takes time proportional to the size of the continuation reflected by
+@racket[mark-set].}
 
 @defproc*[([(make-continuation-mark-key) continuation-mark-key?]
            [(make-continuation-mark-key [sym symbol?]) continuation-mark-key?])]{
@@ -114,7 +116,30 @@ particular vector position is the value for the corresponding key in
 @racket[key-list]. Values for multiple keys appear in a single vector
 only when the marks are for the same continuation frame in
 @racket[mark-set]. The @racket[none-v] argument is used for vector
-elements to indicate the lack of a value.}
+elements to indicate the lack of a value. Producing the result
+takes time proportional to the size of the continuation reflected by
+@racket[mark-set] times the length of @racket[key-list].}
+
+@defproc[(continuation-mark-set->iterator
+          [mark-set continuation-mark-set?]
+          [key-list (listof any/c)]
+          [none-v any/c #f]
+          [prompt-tag continuation-prompt-tag? (default-continuation-prompt-tag)])
+         (-> (values (or/c vector? #f) procedure?))]{
+
+Like @racket[continuation-mark-set->list*], but instead of returning a
+list of values, returns a functional iterator in the form of a
+procedure that returns one element of the would-be list and a new
+iterator function for the rest of the would-be list. An iterator
+procedure returns @racket[#f] instead of a vector when no more
+elements are available; in that case, the returned iterator
+procedure is like the called one, producing no further values.
+The time required for each step is proportional to the length of
+@racket[key-list] times the size of the segment of the continuation
+reflected by @racket[mark-set] between frames that have keys in
+@racket[key-list].
+
+@history[#:added "7.5.0.7"]}
 
 @defproc[(continuation-mark-set-first 
           [mark-set (or/c continuation-mark-set? #f)]
@@ -125,10 +150,12 @@ elements to indicate the lack of a value.}
 Returns the first element of the list that would be returned by
 @racket[(continuation-mark-set->list (or mark-set
 (current-continuation-marks prompt-tag)) key-v prompt-tag)], or
-@racket[none-v] if the result would be the empty list. Typically, this
+@racket[none-v] if the result would be the empty list. The result
+is produced in (amortized) constant time. Typically, this
 result can be computed more quickly using
 @racket[continuation-mark-set-first] than using
-@racket[continuation-mark-set->list].}
+@racket[continuation-mark-set->list] or by using
+@racket[continuation-mark-set->iterator] and iterating just once.}
 
 @defproc[(call-with-immediate-continuation-mark
           [key-v any/c]

pkgs/racket-test-core/tests/racket/contmark.rktl

@@ -73,6 +73,23 @@
 		    x
 		    x)))))
 
+(wcm-test '(#(no 12) #(10 no))
+	  (lambda ()
+	    (with-continuation-mark 'key1 10
+	      (let ([x (with-continuation-mark 'key2 12
+                         (let loop ([iter (continuation-mark-set->iterator (current-continuation-marks) '(key1 key2) 'no)])
+                           (let-values ([(vec next) (iter)])
+                             (if (not vec)
+                                 (let*-values ([(false next-again) (next)]
+                                               [(false2 next-again-again) (next-again)])
+                                   (test #f values false)
+                                   (test #f values false2)
+                                   null)
+                                 (cons vec (loop next))))))])
+		(if (void? x)
+		    x
+		    x)))))
+
 (wcm-test '(11) (lambda ()
 		  (with-continuation-mark 'key 10 
 		    (with-continuation-mark 'key 11
@@ -101,7 +118,7 @@
 					 (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))
 					 (extract-current-continuation-marks 'key)))))
 
-(require (prefix-in unit: scheme/unit))
+(require (prefix-in unit: racket/unit))
 
 ;; ;; Hide keywords from scheme/unit.rkt:
 (define import #f)
@@ -995,6 +1012,14 @@
        (current-continuation-marks)
        (list mark))))
 
+  (define (do-test-iterate mark val)
+    (with-continuation-mark mark val
+      (let ([iter (continuation-mark-set->iterator (current-continuation-marks)
+                                                   (list mark))])
+        (let loop ([iter iter])
+          (let-values ([(v iter) (iter)])
+            (if v (cons v (loop iter)) null))))))
+
   (define (do-test/first mark val)
     (with-continuation-mark mark val
       (continuation-mark-set-first (current-continuation-marks) mark)))
@@ -1006,10 +1031,12 @@
 
   (wcm-test '(12) (lambda () (do-test imp-mark 5)))
   (wcm-test '(#(12)) (lambda () (do-test* imp-mark 5)))
+  (wcm-test '(#(12)) (lambda () (do-test-iterate imp-mark 5)))
   (wcm-test 12 (lambda () (do-test/first imp-mark 5)))
   (wcm-test 12 (lambda () (do-test/immediate imp-mark 5)))
   (wcm-test '(5) (lambda () (do-test cha-mark 5)))
   (wcm-test '(#(5)) (lambda () (do-test* cha-mark 5)))
+  (wcm-test '(#(5)) (lambda () (do-test-iterate cha-mark 5)))
   (wcm-test 5 (lambda () (do-test/first cha-mark 5)))
   (wcm-test 5 (lambda () (do-test/immediate cha-mark 5)))
   (err/rt-test (do-test cha-mark #t) exn:fail?)

racket/src/cs/primitive/kernel.ss

@@ -187,6 +187,7 @@
   [cons (known-procedure/pure 4)]
   [continuation-mark-key? (known-procedure/pure/folding 2)]
   [continuation-mark-set->context (known-procedure/no-prompt 2)]
+  [continuation-mark-set->iterator (known-procedure/no-prompt 28)]
   [continuation-mark-set->list (known-procedure/no-prompt 12)]
   [continuation-mark-set->list* (known-procedure/no-prompt 28)]
   [continuation-mark-set-first (known-procedure/no-prompt 28)]

racket/src/cs/rumble.sls

@@ -37,6 +37,7 @@
           continuation-mark-set-first
           continuation-mark-set->list
           continuation-mark-set->list*
+          continuation-mark-set->iterator
           continuation-mark-set->context
           current-continuation-marks
           (rename [continuation-marks rumble:continuation-marks]) ; wrapped at threads layer

racket/src/cs/rumble/control.ss

@@ -1366,6 +1366,26 @@
     [(marks keys) (continuation-mark-set->list* marks keys #f the-default-continuation-prompt-tag)]
     [(marks keys none-v) (continuation-mark-set->list* marks keys none-v the-default-continuation-prompt-tag)]
     [(marks keys none-v prompt-tag)
+     ((do-continuation-mark-set->list* who #f marks keys none-v prompt-tag))]))
+
+(define/who continuation-mark-set->iterator
+  (case-lambda
+    [(marks keys) (continuation-mark-set->iterator marks keys #f the-default-continuation-prompt-tag)]
+    [(marks keys none-v) (continuation-mark-set->iterator marks keys none-v the-default-continuation-prompt-tag)]
+    [(marks keys none-v prompt-tag)
+     (let ([next (do-continuation-mark-set->list* who #t marks keys none-v prompt-tag)])
+       ;; Each `next` call returns `null` when no more values are
+       ;; available, otherwise a vector and a new next
+       (lambda ()
+         (let loop ([next next])
+           (call-with-values next
+             (case-lambda
+              [(done)
+               (values #f (lambda () (loop (lambda () null))))]
+              [(v new-next)
+               (values v (lambda () (loop new-next)))])))))]))
+
+(define (do-continuation-mark-set->list* who iterator? marks keys none-v prompt-tag)
   (check who continuation-mark-set? :or-false marks)
   (check who list? keys)
   (check who continuation-prompt-tag? prompt-tag)
@@ -1373,8 +1393,9 @@
   (let ([prompt-tag (strip-impersonator prompt-tag)])
     (let-values ([(all-keys all-wrappers)
                   (map/2-values (lambda (k)
-                                     (extract-continuation-mark-key-and-wrapper 'continuation-mark-set->list* k))
+                                  (extract-continuation-mark-key-and-wrapper who k))
                                 keys)])
+      (lambda ()
         (let* ([n (length all-keys)]
                [tmp (#%make-vector n)])
           (let chain-loop ([mark-chain (or (and marks
@@ -1400,7 +1421,9 @@
                            [(null? keys)
                             (if found?
                                 (let ([vec (vector-copy tmp)])
-                                   (cons vec (loop (cdr marks))))
+                                  (if iterator?
+                                      (values vec (lambda () (loop (cdr marks))))
+                                      (cons vec (loop (cdr marks)))))
                                 (loop (cdr marks)))]
                            [else
                             (let ([v (extract-mark-from-frame* t (car keys) none (car wrappers))])
@@ -1410,7 +1433,7 @@
                                 (key-loop (cdr keys) (cdr wrappers) (add1 i) found?)]
                                [else
                                 (vector-set! tmp i v)
-                                 (key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))]))
+                                (key-loop (cdr keys) (cdr wrappers) (add1 i) #t)]))])))]))]))])))))))
 
 (define/who (continuation-mark-set->context marks)
   (check who continuation-mark-set? marks)

racket/src/cs/rumble/error.ss

@@ -10,8 +10,9 @@
          (do-raise v))]))
 
 (define (do-raise v)
-  (let ([hs (continuation-mark-set->list (current-continuation-marks/no-trace)
+  (let ([get-next-h (continuation-mark-set->iterator (current-continuation-marks/no-trace)
-                                         exception-handler-key
+                                                     (list exception-handler-key)
+                                                     #f
                                                      the-root-continuation-prompt-tag)]
         [init-v (condition->exn v)])
     (let ([call-with-nested-handler
@@ -20,20 +21,20 @@
               (make-nested-exception-handler "exception handler" init-v)
               (lambda ()
                 (call-with-break-disabled thunk))))])
-      (let loop ([hs hs] [v init-v])
+      (let loop ([get-next-h get-next-h] [v init-v])
+        (let-values ([(hv get-next-h) (get-next-h)])
           (cond
-         [(null? hs)
+           [(not hv)
             (call-with-nested-handler
              (lambda () (|#%app| (|#%app| uncaught-exception-handler) v)))
             ;; Use `nested-exception-handler` if the uncaught-exception
             ;; handler doesn't escape:
             ((make-nested-exception-handler #f v) #f)]
            [else
-          (let ([h (car hs)]
+            (let ([h (vector-ref hv 0)])
-                [hs (cdr hs)])
               (let ([new-v (call-with-nested-handler
                             (lambda () (|#%app| h v)))])
-              (loop hs new-v)))])))))
+                (loop get-next-h new-v)))]))))))
 
 ;; ----------------------------------------
 

racket/src/racket/src/fun.c

@@ -106,6 +106,7 @@ static Scheme_Object *cont_marks (int argc, Scheme_Object *argv[]);
 static Scheme_Object *cc_marks_p (int argc, Scheme_Object *argv[]);
 static Scheme_Object *extract_cc_marks (int argc, Scheme_Object *argv[]);
 static Scheme_Object *extract_cc_markses (int argc, Scheme_Object *argv[]);
+static Scheme_Object *extract_cc_iterator (int argc, Scheme_Object *argv[]);
 static Scheme_Object *extract_cc_proc_marks (int argc, Scheme_Object *argv[]);
 static Scheme_Object *extract_one_cc_mark (int argc, Scheme_Object *argv[]);
 static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[]);
@@ -415,6 +416,12 @@ scheme_init_fun (Scheme_Startup_Env *env)
 						      2, 4),
 			     env);
 
+  scheme_addto_prim_instance("continuation-mark-set->iterator",
+                             scheme_make_prim_w_arity(extract_cc_iterator,
+                                                      "continuation-mark-set->iterator",
+                                                      2, 4),
+                             env);
+
   o = scheme_make_prim_w_arity(extract_one_cc_mark,
                                "continuation-mark-set-first",
                                2, 4);
@@ -8137,59 +8144,23 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
 }
 
 static Scheme_Object *
-extract_cc_markses(int argc, Scheme_Object *argv[])
+iterate_cc_markses(const char *who,
+                   Scheme_Object *prompt_tag, Scheme_Object *none,
+                   intptr_t len, Scheme_Object **keys,
+                   Scheme_Cont_Mark_Chain **_chain)
 {
-  Scheme_Cont_Mark_Chain *chain;
+  Scheme_Cont_Mark_Chain *chain = *_chain;
-  Scheme_Object *first = scheme_null, *last = NULL;
+  intptr_t last_pos, i;
-  Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
+  Scheme_Object *vals = NULL;
-  int len, i;
-  intptr_t last_pos;
-
-  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
-    scheme_wrong_contract("continuation-mark-set->list*", "continuation-mark-set?", 0, argc, argv);
-    return NULL;
-  }
-  len = scheme_proper_list_length(argv[1]);
-  if (len < 0) {
-    scheme_wrong_contract("continuation-mark-set->list*", "list?", 1, argc, argv);
-    return NULL;
-  }
-  if (argc > 2)
-    none = argv[2];
-  else
-    none = scheme_false;
-  if (argc > 3) {
-    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
-      if (SCHEME_NP_CHAPERONEP(argv[3])
-          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
-        prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
-      else {
-        scheme_wrong_contract("continuation-mark-set->list*", "continuation-prompt-tag?",
-                              3, argc, argv);
-        return NULL;
-      }
-    } else
-      prompt_tag = argv[3];
-  } else
-    prompt_tag = scheme_default_prompt_tag;
-
-  keys = MALLOC_N(Scheme_Object *, len);
-  for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
-    keys[i] = SCHEME_CAR(pr);
-    if ((keys[i] == scheme_parameterization_key)
-	|| (keys[i] == scheme_break_enabled_key)
-	|| (keys[i] == scheme_exn_handler_key)) {
-      scheme_signal_error("continuation-mark-set->list: secret key leaked!");
-      return NULL;
-    }
-  }
   
   prompt_tag = SCHEME_PTR_VAL(prompt_tag);
 
-  chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
-  last_pos = -1;
-
   while (chain) {
+    if (vals && (last_pos != chain->pos)) {
+      *_chain = chain;
+      return vals;
+    }
+    
     for (i = 0; i < len; i++) {
       int is_chaperoned = 0;
       Scheme_Object *orig_key, *val;
@@ -8206,19 +8177,12 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
       if (SAME_OBJ(chain->key, keys[i])) {
 	intptr_t pos;
 	pos = (intptr_t)chain->pos;
-	if (pos != last_pos) {
+	if (!vals) {
 	  vals = scheme_make_vector(len, none);
 	  last_pos = pos;
-	  pr = scheme_make_pair(vals, scheme_null);
+        }
-	  if (last)
-	    SCHEME_CDR(last) = pr;
-	  else
-	    first = pr;
-	  last = pr;
-	} else
-	  vals = SCHEME_CAR(last);
         if (is_chaperoned) {
-          val = scheme_chaperone_do_continuation_mark("continuation-mark-set->list*",
+          val = scheme_chaperone_do_continuation_mark(who,
                                                       1, orig_key, chain->val);
           SCHEME_VEC_ELS(vals)[i] = val;
         } else
@@ -8232,8 +8196,126 @@ extract_cc_markses(int argc, Scheme_Object *argv[])
     chain = chain->next;
   }
 
+  *_chain = NULL;
+
+  return vals;
+}
+
+static Scheme_Object *iterate_step(void *data, int argc, Scheme_Object *argv[])
+{
+  Scheme_Cont_Mark_Chain *chain = ((void **)data)[0];
+  void **clos = ((void **)data)[1], **new_state;
+  Scheme_Object *vals, *a[2];
+  Scheme_Object *prompt_tag = ((Scheme_Object **)clos)[0];
+  Scheme_Object **keys = ((Scheme_Object ***)clos)[1];
+  intptr_t len = SCHEME_INT_VAL(((Scheme_Object **)clos)[2]);
+  Scheme_Object *none = ((Scheme_Object **)clos)[3];
+
+  if (!chain) {
+    a[0] = scheme_false;
+    new_state = data;
+  } else {
+    vals = iterate_cc_markses("mark-list*-iterator", prompt_tag, none, len, keys, &chain);
+    if (!vals)
+      a[0] = scheme_false;
+    else
+      a[0] = vals;
+    new_state = MALLOC_N(void*, 2);
+    new_state[0] = chain;
+    new_state[1] = clos;
+  }
+
+  a[1] = scheme_make_closed_prim_w_arity(iterate_step, new_state, "mark-list*-iterator", 0, 0);
+  return scheme_values(2, a);
+}
+
+static Scheme_Object *
+do_extract_cc_markses(const char *who, int argc, Scheme_Object *argv[], int iterator)
+{
+  Scheme_Cont_Mark_Chain *chain;
+  Scheme_Object *first = scheme_null, *last = NULL;
+  Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
+  intptr_t len, i;
+
+  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
+    scheme_wrong_contract(who, "continuation-mark-set?", 0, argc, argv);
+    return NULL;
+  }
+  len = scheme_proper_list_length(argv[1]);
+  if (len < 0) {
+    scheme_wrong_contract(who, "list?", 1, argc, argv);
+    return NULL;
+  }
+  if (argc > 2)
+    none = argv[2];
+  else
+    none = scheme_false;
+  if (argc > 3) {
+    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
+      if (SCHEME_NP_CHAPERONEP(argv[3])
+          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
+        prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
+      else {
+        scheme_wrong_contract(who, "continuation-prompt-tag?",
+                              3, argc, argv);
+        return NULL;
+      }
+    } else
+      prompt_tag = argv[3];
+  } else
+    prompt_tag = scheme_default_prompt_tag;
+
+  keys = MALLOC_N(Scheme_Object *, len);
+  for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
+    keys[i] = SCHEME_CAR(pr);
+    if ((keys[i] == scheme_parameterization_key)
+	|| (keys[i] == scheme_break_enabled_key)) {
+      scheme_signal_error("%s: misuse of primitive key", who);
+      return NULL;
+    }
+  }
+
+  chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
+
+  if (iterator) {
+    void **clos, **state;
+    clos = MALLOC_N(void*, 4);
+    clos[0] = prompt_tag;
+    clos[1] = keys;
+    clos[2] = scheme_make_integer(len);
+    clos[3] = none;
+    state = MALLOC_N(void*, 2);
+    state[0] = chain;
+    state[1] = clos;
+    return scheme_make_closed_prim_w_arity(iterate_step, state, "mark-list*-iterator", 0, 0);
+  } else {
+    while (chain) {
+      vals = iterate_cc_markses(who, prompt_tag, none, len, keys, &chain);
+      if (vals) {
+        pr = scheme_make_pair(vals, scheme_null);
+        if (last)
+          SCHEME_CDR(last) = pr;
+        else
+          first = pr;
+        last = pr;
+      }
+    }
+
     return first;
   }
+}
+
+static Scheme_Object *
+extract_cc_markses(int argc, Scheme_Object *argv[])
+{
+  return do_extract_cc_markses("continuation-mark-set->list*", argc, argv, 0);
+}
+
+static Scheme_Object *
+extract_cc_iterator(int argc, Scheme_Object *argv[])
+{
+  return do_extract_cc_markses("continuation-mark-set->iterator", argc, argv, 1);
+}
 
 Scheme_Object *
 scheme_get_stack_trace(Scheme_Object *mark_set)

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1458
+#define EXPECTED_PRIM_COUNT 1459
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 5
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 6
+#define MZSCHEME_VERSION_W 7
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x