mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-18 21:29:18 +02:00
142 lines
4.1 KiB
Scheme
142 lines
4.1 KiB
Scheme
;;; CTAK -- A version of the TAK procedure that uses continuations.
|
|
|
|
(import (scheme base) (scheme read) (scheme write) (scheme time) (srfi 18))
|
|
|
|
(define (ctak x y z)
|
|
(call-with-current-continuation
|
|
(lambda (k) (ctak-aux k x y z))))
|
|
|
|
(define (ctak-aux k x y z)
|
|
(if (not (< y x))
|
|
(k z)
|
|
(call-with-current-continuation
|
|
(lambda (k)
|
|
(ctak-aux
|
|
k
|
|
(call-with-current-continuation
|
|
(lambda (k) (ctak-aux k (- x 1) y z)))
|
|
(call-with-current-continuation
|
|
(lambda (k) (ctak-aux k (- y 1) z x)))
|
|
(call-with-current-continuation
|
|
(lambda (k) (ctak-aux k (- z 1) x y))))))))
|
|
|
|
(define (main)
|
|
(let* ((count (read))
|
|
(input1 (read))
|
|
(input2 (read))
|
|
(input3 (read))
|
|
(output (read))
|
|
(s4 (number->string count))
|
|
(s3 (number->string input3))
|
|
(s2 (number->string input2))
|
|
(s1 (number->string input1))
|
|
(name "ctak"))
|
|
;; Rounds to thousandths.
|
|
(define (rounded x)
|
|
(/ (round (* 1000 x)) 1000))
|
|
(display "Running ")
|
|
(display (string-append name ":" s1 ":" s2 ":" s3 ":" s4))
|
|
(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 ":" s4)
|
|
count
|
|
(lambda ()
|
|
(ctak (hide count input1) (hide count input2) (hide count input3))
|
|
)
|
|
(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)
|