From 6d7ae5e1d297e4def1feb85b48e855c35ccf52b3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 23 Sep 2019 15:25:07 -0600
Subject: [PATCH] racket-benchmarks: some microbenchmarks for continuations.
 etc.

---
 .../racket/benchmarks/control/README.txt      |   3 +
 .../racket/benchmarks/control/attach.scm      | 212 ++++++++++++++++++
 .../racket/benchmarks/control/baseline.rkt    |  52 +++++
 .../racket/benchmarks/control/baseline.scm    |  71 ++++++
 .../benchmarks/control/capture-mark.rkt       |  89 ++++++++
 .../tests/racket/benchmarks/control/cell.rkt  |  32 +++
 .../racket/benchmarks/control/config.rktl     |  22 ++
 .../tests/racket/benchmarks/control/get.rkt   | 153 +++++++++++++
 .../racket/benchmarks/control/immediate.rkt   |  30 +++
 .../tests/racket/benchmarks/control/mark.rkt  |  84 +++++++
 .../tests/racket/benchmarks/control/param.rkt |  92 ++++++++
 .../racket/benchmarks/control/setup.rktl      |  26 +++
 .../racket/benchmarks/control/thread.rkt      | 109 +++++++++
 13 files changed, 975 insertions(+)
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/README.txt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/attach.scm
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.scm
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/capture-mark.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/cell.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/config.rktl
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/get.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/immediate.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/mark.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/param.rkt
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/setup.rktl
 create mode 100644 pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt

diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/README.txt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/README.txt
new file mode 100644
index 0000000000..462db4f7b5
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/README.txt
@@ -0,0 +1,3 @@
+Microbenchmarks to help explain and improve the performance of
+continuaations, threads, continuation marks, thread cells, and
+parameters.
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/attach.scm b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/attach.scm
new file mode 100644
index 0000000000..ac8dabffb5
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/attach.scm
@@ -0,0 +1,212 @@
+;; This file is meant to be run in Scheme
+
+(load "setup.rktl")
+(load "config.rktl")
+
+;; Not inlined:
+(define (f x) x)
+
+(show '----------------------------------------)
+
+;; Compare to 'pair-loop; the difference is the time to check
+;;  that the continuation is reified and pop the old attachementt
+(show 'attachment-set-loop)
+(show
+ (times
+  (let loop ([i N])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (call-setting-continuation-attachment
+         i
+         (lambda ()
+           (loop (sub1 i))))))))
+
+;; Compare to 'loop; the diffrenmce is the time to check
+;;  for an attachment that is never there
+(show 'attachment-get-loop)
+(show
+ (times
+  (let loop ([i N])
+    (if (zero? i)
+        0
+        (call-getting-continuation-attachment
+         1
+         (lambda (v)
+           (loop (- i v))))))))
+
+;; Compare to 'loop; the diffrenmce is the time to check
+;;  for an attachment --- discovering the reified continuation
+;;  that indicates that the attachment is there
+(show 'attachment-get-loop/has-attachment)
+(show
+ (times
+  (call-setting-continuation-attachment
+   1
+   (lambda ()
+     (let loop ([i N])
+       (if (zero? i)
+           0
+           (call-getting-continuation-attachment
+            1
+            (lambda (v)
+              (loop (- i v))))))))))
+
+;; Combines the overheads of 'attachment-get-loop and 'attachment-set-loop
+(show 'attachment-get-set-loop)
+(show
+ (times
+  (let loop ([i N])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (call-getting-continuation-attachment
+         1
+         (lambda (v)
+           (call-setting-continuation-attachment
+            i
+            (lambda ()
+              (loop (sub1 i))))))))))
+
+;; Like 'attachment-get-loop and 'attachment-set-loop, but
+;;  "cosume" insteda of "get" sets up a faster "set" because
+;;  it doesn't have to re-check for reified or attachment
+(show 'attachment-consume-set-loop)
+(show
+ (times
+  (let loop ([i N])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (call-consuming-continuation-attachment
+         0
+         (lambda (v)
+           (call-setting-continuation-attachment
+            i
+            (lambda ()
+              (loop (sub1 i))))))))))
+
+;; Simulate `with-continuation-mark`
+(show 'attachment-consume-pair-set-loop)
+(show
+ (times
+  (let loop ([i N])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (call-consuming-continuation-attachment
+         #f
+         (lambda (v)
+           (call-setting-continuation-attachment
+            (if v
+                (cons i (cdr v))
+                (cons i #f))
+            (lambda ()
+              (loop (sub1 i))))))))))
+
+;; Build a long chain of attachments, where the continuation
+;;  doesn't have to be reified because the compiler can add
+;;  a "push" and "pop" around the `add1` call
+;; Most of the time here is GC time to deal with the growing
+;;  chain of attachments
+(show 'attachment-set-nontail-easy)
+(show
+ (times
+  (let loop ([i M])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (add1
+         (call-setting-continuation-attachment
+          i
+          (lambda ()
+            (add1 (loop (sub1 i))))))))))
+
+;; Build a long chain of attachments *and* continuaiton frames;
+;;  the continuation frame is reified for the current `loop`
+;;  call, since `call-setting-continuation-attachment` is in
+;;  tail position
+;; Most of the time here is GC time, because
+;;  this creates a chain of continuation records;
+;;  compare to 'k-nontail
+(show 'attachment-set-nontail-outside)
+(show
+ (times
+  (let loop ([i M])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (call-setting-continuation-attachment
+         i
+         (lambda ()
+           (add1 (loop (sub1 i)))))))))
+
+;; Like the "outside" version, but the continuation frame is
+;;  reified on the previous `loop` call to move the attachment
+;;  to the frame
+;; Most of the time here is GC time, still
+(show 'attachment-set-nontail-inside)
+(show
+ (times
+  (let loop ([i M])
+    (if (zero? i)
+        (car (current-continuation-attachments))
+        (add1
+         (call-setting-continuation-attachment
+          i
+          (lambda ()
+            (loop (sub1 i)))))))))
+
+;; Like 'attachment-set-nontail-inside in that the attachment
+;;  is moved to a reified frame for a non-tail call, but
+;;  no chain of frames is created
+;; A frame cache pays off here, because the reified frame is
+;;  short-lived
+(show 'attachment-nontail-argument-loop)
+(show
+ (times
+  (let ([f f])
+    (let loop ([i N])
+      (if (zero? i)
+          0
+          (loop (call-setting-continuation-attachment
+                 i
+                 (lambda ()
+                   (f (sub1 i))))))))))
+
+;; Like 'attachment-nontail-argument-loop, but with a
+;;  `cons` to simulate a key--value mapping
+(show 'attachment-nontail-argument-pair-loop)
+(show
+ (times
+  (let ([f f])
+    (let loop ([i N])
+      (if (zero? i)
+          0
+          (loop (call-setting-continuation-attachment
+                 (cons 'key i)
+                 (lambda ()
+                   (f (sub1 i))))))))))
+
+;; Since the compiler knows about `sub1`, it doesn't have
+;;  to reify the continuation frame
+(show 'attachment-nontail-argument-loop-easy)
+(show
+ (times
+  (let ([f f])
+    (let loop ([i N])
+      (if (zero? i)
+          0
+          (loop (f (call-setting-continuation-attachment
+                    i
+                    (lambda ()
+                      (sub1 i))))))))))
+
+
+;; Like 'attachment-nontail-argument-loop-easy, but
+;;  with a pair for the attachment
+(show 'attachment-nontail-argument-pair-loop-easy)
+(show
+ (times
+  (let ([f f])
+    (let loop ([i N])
+      (if (zero? i)
+          0
+          (loop (f (call-setting-continuation-attachment
+                    (cons 'key i)
+                    (lambda ()
+                      (sub1 i))))))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.rkt
new file mode 100644
index 0000000000..c1d0ddeb51
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.rkt
@@ -0,0 +1,52 @@
+#lang racket/base
+(require racket/include)
+
+(include "config.rktl")
+
+(define (f x) x)
+(set! f f)
+
+'----------------------------------------
+
+;; Baseline loop performance
+'loop
+(times
+ (let loop ([i N])
+   (if (zero? i)
+       0
+       (loop (sub1 i)))))
+
+;; How much does it const to allocate a pair each time?
+;;  See "attach.scm"
+'pair-loop
+(times
+ (let loop ([i N] [p #f])
+   (if (zero? i)
+       p
+       (loop (sub1 i) (cons i i)))))
+
+;; Baseline for continuation-growing non-tail recursion (note `M` instead of `N`)
+'nontail
+(times
+ (let loop ([i M])
+   (if (zero? i)
+       0
+       (add1 (loop (sub1 i))))))
+
+;; How much more does it add to allocate pairs?
+'pairs-nontail
+(times
+ (let loop ([i M] [p #f])
+   (if (zero? i)
+       (car p)
+       (add1 (loop (sub1 i) (cons i (cons i p)))))))
+
+;; Racket CS time is 12% slower than CS time due to
+;;  the extra code generated by `#%app`
+'indirect-nontail-argument-loop
+(times
+ (let ([f f])
+   (let loop ([i N])
+     (if (zero? i)
+         0
+         (loop (f (sub1 i)))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.scm b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.scm
new file mode 100644
index 0000000000..1fd7d28daa
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/baseline.scm
@@ -0,0 +1,71 @@
+;; This file is meant to be run in Scheme
+
+(load "setup.rktl")
+(load "config.rktl")
+
+;; Not inlined:
+(define (f x) x)
+
+(show '----------------------------------------)
+
+;; Baseline loop performance
+(show 'loop)
+(show
+ (times
+  (let loop ([i N])
+    (if (zero? i)
+        0
+        (loop (sub1 i))))))
+
+;; How much does it const to allocate a pair each time, since
+;;  pushing a continuation attachment will do that?
+;; Answer: makes the loop about 25% slower
+(show 'pair-loop)
+(show
+ (times
+  (let loop ([i N] [p #f])
+    (if (zero? i)
+        p
+        (loop (sub1 i) (cons i i))))))
+
+;; Baseline for continuation-growing non-tail recursion (note `M` instead of `N`)
+(show 'nontail)
+(show
+ (times
+  (let loop ([i M])
+    (if (zero? i)
+        0
+        (add1 (loop (sub1 i)))))))
+
+;; Baseline for instantiating the continuation in a non-tail recursion
+;; Most of the time here is GC time, because
+;;  this creates a chain of continuation records
+(show 'k-nontail)
+(show
+ (times
+  (let loop ([i M])
+    (if (zero? i)
+        0
+        (add1
+         (call/cc
+          (lambda (k)
+            (loop (sub1 i)))))))))
+
+;; How much more does it add to allocate pairs?
+(show 'pairs-nontail)
+(show
+ (times
+  (let loop ([i M] [p #f])
+    (if (zero? i)
+        (car p)
+        (add1 (loop (sub1 i) (cons i (cons i p))))))))
+
+;; Baseline for non-tail calls to an unknown function `f`
+(show 'indirect-nontail-argument-loop)
+(show
+ (times
+  (let ([f f])
+    (let loop ([i N])
+      (if (zero? i)
+          0
+          (loop (f (sub1 i))))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/capture-mark.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/capture-mark.rkt
new file mode 100644
index 0000000000..327bfcc79d
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/capture-mark.rkt
@@ -0,0 +1,89 @@
+#lang racket/base
+
+(require racket/include)
+
+(include "config.rktl")
+
+(define my-prompt (make-continuation-prompt-tag 'mine))
+
+'----------------------------------------
+
+'compose-baseline
+(times
+ (let ([k (let/ec esc
+            (call-with-continuation-prompt
+             (lambda ()
+               (let loop ([j 100])
+                 (if (zero? j)
+                     (call-with-composable-continuation
+                      (lambda (k)
+                        (esc k)))
+                     (add1 (loop (sub1 j))))))))])
+   (let loop ([i Q] [v #f])
+     (if (zero? i)
+        v
+        (loop (sub1 i) (k 0))))))
+
+'compose-deep-marks
+(times
+ (let ([k (let/ec esc
+            (call-with-continuation-prompt
+             (lambda ()
+               (let loop ([j 100])
+                 (if (zero? j)
+                     (call-with-composable-continuation
+                      (lambda (k)
+                        (esc k)))
+                     (with-continuation-mark
+                      'key j
+                      (add1 (loop (sub1 j)))))))))])
+   (let loop ([i Q] [v #f])
+     (if (zero? i)
+        v
+        (loop (sub1 i) (k 0))))))
+
+'compose-deep/prompt-marks
+(times
+ (let ([k (let/ec esc
+            (call-with-continuation-prompt
+             (lambda ()
+               (let loop ([j 100])
+                 (if (zero? j)
+                     (call-with-composable-continuation
+                      (lambda (k)
+                        (esc k)))
+                     (call-with-continuation-prompt
+                      (lambda ()
+                        (with-continuation-mark
+                         'key j
+                         (add1 (loop (sub1 j)))))
+                      my-prompt))))))])
+   (let loop ([i Q] [v #f])
+     (if (zero? i)
+        v
+        (loop (sub1 i) (k 0))))))
+
+;; Like the previous case, but the composable
+;;  continuation doesn't start with a mark
+;;  that needs to be spliced
+'compose-deep/prompt/nosplice-marks
+(times
+ (let ([k (let/ec esc
+            (call-with-continuation-prompt
+             (lambda ()
+               (add1
+                (let loop ([j 100])
+                  (if (zero? j)
+                      (call-with-composable-continuation
+                       (lambda (k)
+                         (esc k)))
+                      (call-with-continuation-prompt
+                       (lambda ()
+                         (with-continuation-mark
+                          'key j
+                          (add1 (loop (sub1 j)))))
+                       my-prompt)))))))])
+   (let loop ([i Q] [v #f])
+     (if (zero? i)
+        v
+        (loop (sub1 i) (k 0))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/cell.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/cell.rkt
new file mode 100644
index 0000000000..b1b2442d4c
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/cell.rkt
@@ -0,0 +1,32 @@
+#lang racket/base
+
+(require racket/include)
+
+(include "config.rktl")
+
+'----------------------------------------
+
+(define c (make-thread-cell #f))
+
+'cell-ref
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (thread-cell-ref c)))))
+
+'cell-set!
+(times
+ (let loop ([i L])
+   (if (zero? i)
+       (thread-cell-ref c)
+       (begin
+         (thread-cell-set! c i)
+         (loop (sub1 i))))))
+
+'cell-ref-after-set
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (thread-cell-ref c)))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/config.rktl b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/config.rktl
new file mode 100644
index 0000000000..93ac8acbbf
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/config.rktl
@@ -0,0 +1,22 @@
+;; Iterations for slow things:
+(define Q 1000000)
+
+;; The depth used for non-tail recursion, typically:
+(define M (* Q 10))
+
+;; Intermediate count:
+(define L (* M 10))
+
+;; Number of iteraitons used for a loop, typically
+(define N (* L 10))
+
+;; Number of times to run each benchamrk:
+(define I 3)
+
+(define-syntax times
+  (syntax-rules ()
+    [(_ e)
+     (let loop ([v #f] [i I])
+       (if (zero? i)
+           v
+           (loop (time e) (sub1 i))))]))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/get.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/get.rkt
new file mode 100644
index 0000000000..7e104d1558
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/get.rkt
@@ -0,0 +1,153 @@
+ #lang racket/base
+(require racket/include)
+
+(include "config.rktl")
+
+(define my-prompt (make-continuation-prompt-tag 'mine))
+
+'----------------------------------------
+
+;; This is relatively slow, because it collects backtrace information
+'marks-loop
+(times
+ (let loop ([i M] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (current-continuation-marks)))))
+
+;; Lookup with key not found
+'first-none-loop
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (continuation-mark-set-first #f 'key)))))
+
+;; Lookup with key found
+'first-some-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (let loop ([i L] [a #f])
+    (if (zero? i)
+        a
+        (loop (sub1 i) (continuation-mark-set-first #f 'key))))))
+
+;; Lookup with key found on the other side of a prompt
+'first-some/prompt-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (call-with-continuation-prompt
+   (lambda ()
+     (let loop ([i L] [a #f])
+       (if (zero? i)
+           a
+           (loop (sub1 i) (continuation-mark-set-first #f 'key)))))
+   my-prompt)))
+
+;; Lookup with key found in distant frame
+'first-some/deep-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (let loop ([j 100])
+    (cond
+      [(zero? j)
+       (let loop ([i L] [a #f])
+         (if (zero? i)
+             a
+             (loop (sub1 i) (continuation-mark-set-first #f 'key))))]
+      [(odd? j)
+       (list (loop (sub1 j)))]
+      [else
+       (car (loop (sub1 j)))]))))
+
+;; Lookup with key found in distant frame with lots of other
+;;  keys on frames in between
+'first-some/deep/push-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (let loop ([j 100])
+    (cond
+      [(zero? j)
+       (let loop ([i L] [a #f])
+         (if (zero? i)
+             a
+             (loop (sub1 i) (continuation-mark-set-first #f 'key))))]
+      [(odd? j)
+       (list  (with-continuation-mark
+               'other 'val
+               (loop (sub1 j))))]
+      [else
+       (car (loop (sub1 j)))]))))
+
+;; Lookup with key *not* found with lots of other
+;;  keys on frames
+'first-none/deep/push-loop
+(times
+ (let loop ([j 100])
+   (cond
+     [(zero? j)
+      (let loop ([i L] [a #f])
+        (if (zero? i)
+            a
+            (loop (sub1 i) (continuation-mark-set-first #f 'key))))]
+     [(odd? j)
+      (list  (with-continuation-mark
+              'other 'val
+              (loop (sub1 j))))]
+     [else
+      (car (loop (sub1 j)))])))
+
+;; Lookup with key found in distant frame with lots of prompts
+;;  and other keys on frames in between
+'first-some/deep/prompt/push-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (let k-loop ([k 100])
+    (let loop ([j 100])
+      (cond
+        [(zero? j)
+         (if (zero? k)
+             (let loop ([i M] [a #f])
+               (if (zero? i)
+                   a
+                   (loop (sub1 i) (continuation-mark-set-first #f 'key))))
+             (call-with-continuation-prompt
+              (lambda ()
+                (k-loop (sub1 k)))
+              my-prompt))]
+        [(odd? j)
+         (list  (with-continuation-mark
+                 'other 'val
+                 (loop (sub1 j))))]
+        [else
+         (car (loop (sub1 j)))])))))
+
+;; Like the previous one, but prompt makes only marks within
+;;  the last prompt relevant
+'first-some/deep/stop-prompt/push-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (let k-loop ([k 100])
+    (let loop ([j 100])
+      (cond
+        [(zero? j)
+         (if (zero? k)
+             (let loop ([i M] [a #f])
+               (if (zero? i)
+                   a
+                   (loop (sub1 i) (continuation-mark-set-first #f 'key))))
+             (call-with-continuation-prompt
+              (lambda ()
+                (k-loop (sub1 k)))))]
+        [(odd? j)
+         (list  (with-continuation-mark
+                 'other 'val
+                 (loop (sub1 j))))]
+        [else
+         (car (loop (sub1 j)))])))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/immediate.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/immediate.rkt
new file mode 100644
index 0000000000..89355e887e
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/immediate.rkt
@@ -0,0 +1,30 @@
+#lang racket/base
+(require racket/include)
+
+(include "config.rktl")
+
+'----------------------------------------
+
+;; Key not found
+'none-loop
+(times
+ (let loop ([i N] [a #f])
+   (if (zero? i)
+       a
+       (call-with-immediate-continuation-mark
+        'key
+        (lambda (a)
+          (loop (sub1 i) a))))))
+
+;; Key found
+'some-loop
+(times
+ (with-continuation-mark
+  'key 'val
+  (let loop ([i N] [a #f])
+    (if (zero? i)
+        a
+        (call-with-immediate-continuation-mark
+         'key
+         (lambda (a)
+           (loop (sub1 i) a)))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/mark.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/mark.rkt
new file mode 100644
index 0000000000..7f953c0d70
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/mark.rkt
@@ -0,0 +1,84 @@
+#lang racket/base
+(require racket/include)
+
+(include "config.rktl")
+
+(define (f x) x)
+(set! f f)
+
+'----------------------------------------
+
+;; Continuation marks around tail call for a loop
+;; Should be similar to 'attachment-consume-pair-set-loop
+;;  from "attach.ss", but extra overhead is call to an "update"
+;;  function instead of an inline `cons`
+'mark-set-loop
+(times
+ (let loop ([i N])
+   (if (zero? i)
+       (continuation-mark-set-first #f 'key)
+       (with-continuation-mark
+        'key i
+        (loop (sub1 i))))))
+
+;; Analogous to 'attachment-set-nontail-easy
+;; Racket CS: in large-M configuration, nearly all
+;;  time is GC due grouping attachment list
+'mark-set-nontail-easy
+(times
+ (let loop ([i M])
+   (if (zero? i)
+       (continuation-mark-set-first #f 'key)
+       (add1
+        (with-continuation-mark
+         'key i
+         (add1 (loop (sub1 i))))))))
+
+;; Racket: 1/3 time is GC
+;; Racket CS: nearly all time is GC, because
+;;  this creates a chain of continuation records
+'mark-set-nontail-outside
+(times
+ (let loop ([i M])
+   (if (zero? i)
+       (continuation-mark-set-first #f 'key)
+       ;; Note: traditional Racket uses a kind of `begin0` here
+       (with-continuation-mark
+        'key i
+        (add1 (loop (sub1 i)))))))
+
+;; Racket: 1/2 time is GC
+;; Racket CS: nearly all time is GC, because
+;;  this creates a chain of continuation records
+'mark-set-nontail-inside
+(times
+ (let loop ([i M])
+   (if (zero? i)
+       (continuation-mark-set-first #f 'key)
+       (add1
+        (with-continuation-mark
+         'key i
+         (loop (sub1 i)))))))
+
+;; Racket CS time is 25% slower than CS time due to
+;;  `#%app` plus the `cons` of 'key and `i`
+'mark-nontail-argument-loop
+(times
+ (let ([f f])
+   (let loop ([i N])
+     (if (zero? i)
+         0
+         (loop (with-continuation-mark
+                'key i
+                (f (sub1 i))))))))
+ 
+;; Racket CS time is 45% slower than CS time...
+'mark-nontail-argument-loop-easy
+(times
+ (let ([f f])
+   (let loop ([i N])
+     (if (zero? i)
+         0
+         (loop (f (with-continuation-mark
+                   'key i
+                   (sub1 i))))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/param.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/param.rkt
new file mode 100644
index 0000000000..9cb1722612
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/param.rkt
@@ -0,0 +1,92 @@
+#lang racket/base
+(require racket/include
+         (only-in '#%paramz
+                  parameterization-key))
+
+(include "config.rktl")
+
+(define p (make-parameter #f))
+
+'----------------------------------------
+
+;; Twice as long as a typical key, because we look for the
+;; root prompt (never there) instead of the default prompt
+'get-paramz
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (continuation-mark-set-first
+                       #f
+                       parameterization-key)))))
+
+'current-paramz
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (current-parameterization)))))
+
+'current-paramz/local
+(times
+ (parameterize ([p 10])
+   (let loop ([i L] [a #f])
+     (if (zero? i)
+         a
+         (loop (sub1 i) (current-parameterization))))))
+
+'param-ref
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (p)))))
+
+'param-ref/local
+(times
+ (parameterize ([p 10])
+   (let loop ([i L] [a #f])
+     (if (zero? i)
+         a
+         (loop (sub1 i) (p))))))
+
+'param-set!
+(times
+ (let loop ([i L])
+   (if (zero? i)
+       (p)
+       (begin
+         (p i)
+         (loop (sub1 i))))))
+
+'param-ref-after-set
+(times
+ (let loop ([i L] [a #f])
+   (if (zero? i)
+       a
+       (loop (sub1 i) (p)))))
+
+'param-bind-loop
+(times
+ (let loop ([i M])
+   (if (zero? i)
+       (p)
+       (parameterize ([p i])
+         (loop (sub1 i))))))
+
+'param-bind-prim-loop
+(times
+ (let ([insp (make-inspector)])
+   (let loop ([i M])
+     (if (zero? i)
+         (p)
+         (parameterize ([current-inspector insp])
+           (loop (sub1 i)))))))
+
+'param-bind-nontail
+(times
+ (let loop ([i M])
+   (if (zero? i)
+       (p)
+       (parameterize ([p i])
+         (add1 (loop (sub1 i)))))))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/setup.rktl b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/setup.rktl
new file mode 100644
index 0000000000..e01dd26081
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/setup.rktl
@@ -0,0 +1,26 @@
+;; Racket-style outtput for timing informatiton:
+(define-syntax time
+  (syntax-rules ()
+    [(_ e)
+     (let ([pre (statistics)])
+       (let ([r e])
+         (let ([post (statistics)])
+           (print-delta pre post)
+           r)))]))
+
+(define (print-delta pre post)
+  (define (msecs a b)
+    (quotient (- (+ (* 1000000000 (time-second a)) (time-nanosecond a))
+                 (+ (* 1000000000 (time-second b)) (time-nanosecond b)))
+              1000000))
+  (printf "cpu time: ~a real time: ~a gc time: ~a\n"
+          (msecs (sstats-cpu post) (sstats-cpu pre))
+          (msecs (sstats-real post) (sstats-real pre))
+          (msecs (sstats-gc-cpu post) (sstats-gc-cpu pre))))
+
+(print-extended-identifiers #t)
+
+(define (show v)
+  (when (symbol? v) (display "'"))
+  (write v)
+  (newline))
diff --git a/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt
new file mode 100644
index 0000000000..4ebcb824ea
--- /dev/null
+++ b/pkgs/racket-benchmarks/tests/racket/benchmarks/control/thread.rkt
@@ -0,0 +1,109 @@
+#lang racket/base
+
+(require racket/include)
+
+(include "config.rktl")
+
+'----------------------------------------
+
+'spin-ping-pong
+(times
+ (let ([s1 (box #t)]
+       [s2 (box #t)])
+   (define (box-wait b)
+     (unless (box-cas! b #t #f)
+       (sleep)
+       (box-wait b)))
+   (define (box-post b)
+     (unless (box-cas! b #f #t)
+       (sleep)
+       (box-post b)))
+   (define (make s1 s2)
+     (thread (lambda ()
+               (let loop ([i Q])
+                 (box-wait s1)
+                 (unless (zero? i)
+                   (box-post s2)
+                   (loop (sub1 i)))))))
+   (define t1 (make s1 s2))
+   (define t2 (make s2 s1))
+   (thread-wait t1)
+   (thread-wait t2)))
+
+'channel-ping-pong
+(times
+ (let ([c1 (make-channel)]
+       [c2 (make-channel)])
+   (define (make first?)
+     (thread (lambda ()
+               (let loop ([i Q])
+                 (if first?
+                     (channel-put c2 (channel-get c1))
+                     (begin
+                       (channel-put c1 'ok)
+                       (channel-get c2)))
+                 (unless (zero? i)
+                   (loop (sub1 i)))))))
+   (define t1 (make #t))
+   (define t2 (make #f))
+   (thread-wait t1)
+   (thread-wait t2)))
+
+'sema-ping-pong
+(times
+ (let ([s1 (make-semaphore 1)]
+       [s2 (make-semaphore 1)])
+   (define (make s1 s2)
+     (thread (lambda ()
+               (let loop ([i Q])
+                 (semaphore-wait s1)
+                 (unless (zero? i)
+                   (semaphore-post s2)
+                   (loop (sub1 i)))))))
+   (define t1 (make s1 s2))
+   (define t2 (make s2 s1))
+   (thread-wait t1)
+   (thread-wait t2)))
+
+'sema-ping-pong/prompts
+(times
+ (let ([s1 (make-semaphore 1)]
+       [s2 (make-semaphore 1)])
+   (define (make s1 s2)
+     (thread (lambda ()
+               (let loop ([j 100])
+                 (if (zero? j)
+                     (let loop ([i Q])
+                       (semaphore-wait s1)
+                       (unless (zero? i)
+                         (semaphore-post s2)
+                         (loop (sub1 i))))
+                     (call-with-continuation-prompt
+                      (lambda ()
+                        (loop (sub1 j)))))))))
+   (define t1 (make s1 s2))
+   (define t2 (make s2 s1))
+   (thread-wait t1)
+   (thread-wait t2)))
+
+'sema-ping-pong/marks
+(times
+ (let ([s1 (make-semaphore 1)]
+       [s2 (make-semaphore 1)])
+   (define (make s1 s2)
+     (thread (lambda ()
+               (let loop ([j 100])
+                 (if (zero? j)
+                     (let loop ([i Q])
+                       (semaphore-wait s1)
+                       (unless (zero? i)
+                         (semaphore-post s2)
+                         (loop (sub1 i))))
+                     (with-continuation-mark
+                      'key j
+                      (loop (sub1 j))))))))
+   (define t1 (make s1 s2))
+   (define t2 (make s2 s1))
+   (thread-wait t1)
+   (thread-wait t2)))
+