From 5e0fb7edc7cb185b114be66cbd4d239ca89046e4 Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Thu, 15 Jun 2017 18:57:54 -0400
Subject: [PATCH] Threaded bv2string

---
 examples/threading/benchmarks/bv2string.scm | 243 ++++++++++++++++++++
 1 file changed, 243 insertions(+)
 create mode 100644 examples/threading/benchmarks/bv2string.scm

diff --git a/examples/threading/benchmarks/bv2string.scm b/examples/threading/benchmarks/bv2string.scm
new file mode 100644
index 00000000..35408bbd
--- /dev/null
+++ b/examples/threading/benchmarks/bv2string.scm
@@ -0,0 +1,243 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Copyright 2007 William D Clinger.
+;;
+;; Permission to copy this software, in whole or in part, to use this
+;; software for any lawful purpose, and to redistribute this software
+;; is granted subject to the restriction that all copies made of this
+;; software must include this copyright notice in full.
+;;
+;; I also request that you send me a copy of any improvements that you
+;; make to this software so that they may be incorporated within it to
+;; the benefit of the Scheme community.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Tests of string <-> bytevector conversions.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(import (scheme base) (scheme read) (scheme write) (scheme time) (srfi 18))
+
+;; Crude test rig, just for benchmarking.
+
+(define failed-tests '())
+
+(define (test name actual expected)
+  (unless (equal? actual expected)
+    (display "******** FAILED TEST ******** ")
+    (display name)
+    (newline)
+    (set! failed-tests (cons name failed-tests))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; We're limited to Ascii strings here because the R7RS doesn't
+;; actually require anything beyond Ascii.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Basic sanity tests, followed by stress tests on random inputs.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (string-bytevector-tests
+         *random-stress-tests* *random-stress-test-max-size*)
+
+  (define (test-roundtrip bvec tostring tobvec)
+    (let* ((s1 (tostring bvec))
+           (b2 (tobvec s1))
+           (s2 (tostring b2)))
+      (test "round trip of string conversion" (string=? s1 s2) #t)))
+
+  ;; This random number generator doesn't have to be good.
+  ;; It just has to be fast.
+
+  (define random
+    (letrec ((random14
+              (lambda (n)
+                (set! x (remainder (+ (* a x) c) (+ m 1)))
+                (remainder (quotient x 8) n)))
+             (a 701)
+             (x 1)
+             (c 743483)
+             (m 524287)
+             (loop
+              (lambda (q r n)
+                (if (zero? q)
+                    (remainder r n)
+                    (loop (quotient q 16384)
+                          (+ (* 16384 r) (random14 16384))
+                          n)))))
+      (lambda (n)
+        (if (< n 16384)
+            (random14 n)
+            (loop (quotient n 16384) (random14 16384) n)))))
+
+  ;; Returns a random bytevector of length up to n,
+  ;; with all elements less than 128.
+
+  (define (random-bytevector n)
+    (let* ((n (random n))
+           (bv (make-bytevector n)))
+      (do ((i 0 (+ i 1)))
+          ((= i n) bv)
+        (bytevector-u8-set! bv i (random 128)))))
+
+  ;; Returns a random bytevector of even length up to n.
+
+  (define (random-bytevector2 n)
+    (let* ((n (random n))
+           (n (if (odd? n) (+ n 1) n))
+           (bv (make-bytevector n)))
+      (do ((i 0 (+ i 1)))
+          ((= i n) bv)
+        (bytevector-u8-set! bv i (random 128)))))
+
+  ;; Returns a random bytevector of multiple-of-4 length up to n.
+
+  (define (random-bytevector4 n)
+    (let* ((n (random n))
+           (n (* 4 (round (/ n 4))))
+           (bv (make-bytevector n)))
+      (do ((i 0 (+ i 1)))
+          ((= i n) bv)
+        (bytevector-u8-set! bv i (random 128)))))
+
+  (test-roundtrip (random-bytevector 10) utf8->string string->utf8)
+
+  (do ((i 0 (+ i 1)))
+      ((= i *random-stress-tests*))
+    (test-roundtrip (random-bytevector *random-stress-test-max-size*)
+                    utf8->string string->utf8))
+
+  )
+
+(define (main)
+  (let* ((count (read))
+         (input1 (read))
+         (input2 (read))
+         (output (read))
+         (s3 (number->string count))
+         (s2 (number->string input2))
+         (s1 (number->string input1))
+         (name "bv2string"))
+;    (run-r7rs-benchmark
+;     (string-append name ":" s1 ":" s2 ":" s3)
+;     count
+;     (lambda ()
+;       (string-bytevector-tests (hide count input1) (hide count input2))
+;       (length failed-tests))
+;     (lambda (result) (equal? result output)))))
+
+  ;; Rounds to thousandths.
+  (define (rounded x)
+    (/ (round (* 1000 x)) 1000))
+  (display "Running ")
+  (display (string-append name ":" s1 ":" s2 ":" s3 ))
+  (newline)
+  (flush-output-port (current-output-port))
+  (let* ((j/s (jiffies-per-second))
+         (t0 (current-second))
+         (j0 (current-jiffy)))
+(async-exec-multi! 1 (lambda () 
+    (run-r7rs-benchmark
+     (string-append name ":" s1 ":" s2 ":" s3 )
+     count
+     (lambda ()
+       (string-bytevector-tests (hide count input1) (hide count input2))
+       (length failed-tests)
+     )
+     (lambda (result) (equal? result output)))
+))
+(wait-for-all-async) ;; TODO: thread-join
+
+             (let* ((j1 (current-jiffy))
+                    (t1 (current-second))
+                    (jifs (- j1 j0))
+                    (secs (inexact (/ jifs j/s)))
+                    (secs2 (rounded (- t1 t0))))
+               (display "Elapsed time: ")
+               (write secs)
+               (display " seconds (")
+               (write secs2)
+               (display ") for ")
+               (display name)
+               (newline)
+               (display "+!CSVLINE!+")
+               (display (this-scheme-implementation-name))
+               (display ",")
+               (display name)
+               (display ",")
+               (display secs)
+               (newline)
+               (flush-output-port (current-output-port)))
+
+    )))
+(define *running-threads* 0)
+(define m (make-mutex))
+
+(define (async-exec-multi! n thunk)
+  (do ((i 0 (+ i 1)))
+      ((>= i n)) 
+    (async-exec! thunk)))
+
+(define (async-exec! thunk)
+  (set! *running-threads* (+ *running-threads* 1)) ;; On main thread, so no lock
+  (thread-start!
+    (make-thread
+      (lambda ()
+        (thunk)
+        (mutex-lock! m)
+        (set! *running-threads* (- *running-threads* 1))
+        (mutex-unlock! m)))))
+
+(define (wait-for-all-async)
+  (let loop ((done #f))
+    (thread-sleep! 0)
+    (mutex-lock! m)
+    (if (= *running-threads* 0) (set! done #t))
+    (mutex-unlock! m)
+    (if (not done) (loop #f))))
+  
+;;; The following code is appended to all benchmarks.
+
+;;; Given an integer and an object, returns the object
+;;; without making it too easy for compilers to tell
+;;; the object will be returned.
+
+(define (hide r x)
+  (call-with-values
+   (lambda ()
+     (values (vector values (lambda (x) x))
+             (if (< r 100) 0 1)))
+   (lambda (v i)
+     ((vector-ref v i) x))))
+
+;;; Given the name of a benchmark,
+;;; the number of times it should be executed,
+;;; a thunk that runs the benchmark once,
+;;; and a unary predicate that is true of the
+;;; correct results the thunk may return,
+;;; runs the benchmark for the number of specified iterations.
+
+(define (run-r7rs-benchmark name count thunk ok?)
+
+
+    (let loop ((i 0)
+               (result #f))
+      (cond ((< i count)
+             (loop (+ i 1) (thunk)))
+            ((ok? result)
+             result)
+            (else
+             (display "ERROR: returned incorrect result: ")
+             (write result)
+             (newline)
+             (flush-output-port (current-output-port))
+             (exit 1)))))
+(define (this-scheme-implementation-name)
+  (string-append "cyclone-" (Cyc-version)))
+(main)