mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-18 21:29:18 +02:00
Initial file
This commit is contained in:
Justin Ethier
parent
54051ead86
commit
7b2a4991a7
2 changed files with 369 additions and 0 deletions
109
examples/threading/benchmarks/ctak.scm
Normal file
109
examples/threading/benchmarks/ctak.scm
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
;;; CTAK -- A version of the TAK procedure that uses continuations.
|
||||
|
||||
(import (scheme base) (scheme read) (scheme write) (scheme time))
|
||||
|
||||
(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"))
|
||||
(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)))))
|
||||
|
||||
;;; 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?)
|
||||
|
||||
;; Rounds to thousandths.
|
||||
(define (rounded x)
|
||||
(/ (round (* 1000 x)) 1000))
|
||||
|
||||
(display "Running ")
|
||||
(display name)
|
||||
(newline)
|
||||
(flush-output-port (current-output-port))
|
||||
(let* ((j/s (jiffies-per-second))
|
||||
(t0 (current-second))
|
||||
(j0 (current-jiffy)))
|
||||
(let loop ((i 0)
|
||||
(result #f))
|
||||
(cond ((< i count)
|
||||
(loop (+ i 1) (thunk)))
|
||||
((ok? result)
|
||||
(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)))
|
||||
result)
|
||||
(else
|
||||
(display "ERROR: returned incorrect result: ")
|
||||
(write result)
|
||||
(newline)
|
||||
(flush-output-port (current-output-port))
|
||||
result)))))
|
||||
(define (this-scheme-implementation-name)
|
||||
(string-append "cyclone-" (Cyc-version)))
|
||||
(main)
|
||||
260
examples/threading/benchmarks/paraffins.scm
Normal file
260
examples/threading/benchmarks/paraffins.scm
Normal file
|
|
@ -0,0 +1,260 @@
|
|||
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
|
||||
|
||||
(import (scheme base) (scheme read) (scheme write) (scheme time))
|
||||
|
||||
;;; This benchmark uses the following R6RS procedures.
|
||||
|
||||
(define (div x y)
|
||||
(quotient x y))
|
||||
|
||||
;;; End of (faked) R6RS procedures.
|
||||
|
||||
(define (gen n)
|
||||
(let* ((n/2 (div n 2))
|
||||
(radicals (make-vector (+ n/2 1) '(H))))
|
||||
|
||||
(define (rads-of-size n)
|
||||
(let loop1 ((ps
|
||||
(three-partitions (- n 1)))
|
||||
(lst
|
||||
'()))
|
||||
(if (null? ps)
|
||||
lst
|
||||
(let* ((p (car ps))
|
||||
(nc1 (vector-ref p 0))
|
||||
(nc2 (vector-ref p 1))
|
||||
(nc3 (vector-ref p 2)))
|
||||
(let loop2 ((rads1
|
||||
(vector-ref radicals nc1))
|
||||
(lst
|
||||
(loop1 (cdr ps)
|
||||
lst)))
|
||||
(if (null? rads1)
|
||||
lst
|
||||
(let loop3 ((rads2
|
||||
(if (= nc1 nc2)
|
||||
rads1
|
||||
(vector-ref radicals nc2)))
|
||||
(lst
|
||||
(loop2 (cdr rads1)
|
||||
lst)))
|
||||
(if (null? rads2)
|
||||
lst
|
||||
(let loop4 ((rads3
|
||||
(if (= nc2 nc3)
|
||||
rads2
|
||||
(vector-ref radicals nc3)))
|
||||
(lst
|
||||
(loop3 (cdr rads2)
|
||||
lst)))
|
||||
(if (null? rads3)
|
||||
lst
|
||||
(cons (vector 'C
|
||||
(car rads1)
|
||||
(car rads2)
|
||||
(car rads3))
|
||||
(loop4 (cdr rads3)
|
||||
lst))))))))))))
|
||||
|
||||
(define (bcp-generator j)
|
||||
(if (odd? j)
|
||||
'()
|
||||
(let loop1 ((rads1
|
||||
(vector-ref radicals (div j 2)))
|
||||
(lst
|
||||
'()))
|
||||
(if (null? rads1)
|
||||
lst
|
||||
(let loop2 ((rads2
|
||||
rads1)
|
||||
(lst
|
||||
(loop1 (cdr rads1)
|
||||
lst)))
|
||||
(if (null? rads2)
|
||||
lst
|
||||
(cons (vector 'BCP
|
||||
(car rads1)
|
||||
(car rads2))
|
||||
(loop2 (cdr rads2)
|
||||
lst))))))))
|
||||
|
||||
(define (ccp-generator j)
|
||||
(let loop1 ((ps
|
||||
(four-partitions (- j 1)))
|
||||
(lst
|
||||
'()))
|
||||
(if (null? ps)
|
||||
lst
|
||||
(let* ((p (car ps))
|
||||
(nc1 (vector-ref p 0))
|
||||
(nc2 (vector-ref p 1))
|
||||
(nc3 (vector-ref p 2))
|
||||
(nc4 (vector-ref p 3)))
|
||||
(let loop2 ((rads1
|
||||
(vector-ref radicals nc1))
|
||||
(lst
|
||||
(loop1 (cdr ps)
|
||||
lst)))
|
||||
(if (null? rads1)
|
||||
lst
|
||||
(let loop3 ((rads2
|
||||
(if (= nc1 nc2)
|
||||
rads1
|
||||
(vector-ref radicals nc2)))
|
||||
(lst
|
||||
(loop2 (cdr rads1)
|
||||
lst)))
|
||||
(if (null? rads2)
|
||||
lst
|
||||
(let loop4 ((rads3
|
||||
(if (= nc2 nc3)
|
||||
rads2
|
||||
(vector-ref radicals nc3)))
|
||||
(lst
|
||||
(loop3 (cdr rads2)
|
||||
lst)))
|
||||
(if (null? rads3)
|
||||
lst
|
||||
(let loop5 ((rads4
|
||||
(if (= nc3 nc4)
|
||||
rads3
|
||||
(vector-ref radicals nc4)))
|
||||
(lst
|
||||
(loop4 (cdr rads3)
|
||||
lst)))
|
||||
(if (null? rads4)
|
||||
lst
|
||||
(cons (vector 'CCP
|
||||
(car rads1)
|
||||
(car rads2)
|
||||
(car rads3)
|
||||
(car rads4))
|
||||
(loop5 (cdr rads4)
|
||||
lst))))))))))))))
|
||||
|
||||
(let loop ((i 1))
|
||||
(if (> i n/2)
|
||||
(vector (bcp-generator n)
|
||||
(ccp-generator n))
|
||||
(begin
|
||||
(vector-set! radicals i (rads-of-size i))
|
||||
(loop (+ i 1)))))))
|
||||
|
||||
(define (three-partitions m)
|
||||
(let loop1 ((lst '())
|
||||
(nc1 (div m 3)))
|
||||
(if (< nc1 0)
|
||||
lst
|
||||
(let loop2 ((lst lst)
|
||||
(nc2 (div (- m nc1) 2)))
|
||||
(if (< nc2 nc1)
|
||||
(loop1 lst
|
||||
(- nc1 1))
|
||||
(loop2 (cons (vector nc1 nc2 (- m (+ nc1 nc2))) lst)
|
||||
(- nc2 1)))))))
|
||||
|
||||
(define (four-partitions m)
|
||||
(let loop1 ((lst '())
|
||||
(nc1 (div m 4)))
|
||||
(if (< nc1 0)
|
||||
lst
|
||||
(let loop2 ((lst lst)
|
||||
(nc2 (div (- m nc1) 3)))
|
||||
(if (< nc2 nc1)
|
||||
(loop1 lst
|
||||
(- nc1 1))
|
||||
(let ((start (max nc2 (- (div (+ m 1) 2) (+ nc1 nc2)))))
|
||||
(let loop3 ((lst lst)
|
||||
(nc3 (div (- m (+ nc1 nc2)) 2)))
|
||||
(if (< nc3 start)
|
||||
(loop2 lst (- nc2 1))
|
||||
(loop3 (cons (vector nc1 nc2 nc3 (- m (+ nc1 (+ nc2 nc3)))) lst)
|
||||
(- nc3 1))))))))))
|
||||
|
||||
(define (nb n)
|
||||
(let ((x (gen n)))
|
||||
(+ (length (vector-ref x 0))
|
||||
(length (vector-ref x 1)))))
|
||||
|
||||
(define (main)
|
||||
(let* ((count (read))
|
||||
(input1 (read))
|
||||
(output (read))
|
||||
(s2 (number->string count))
|
||||
(s1 (number->string input1))
|
||||
(name "paraffins"))
|
||||
(run-r7rs-benchmark
|
||||
(string-append name ":" s1 ":" s2)
|
||||
count
|
||||
(lambda () (nb (hide count input1)))
|
||||
(lambda (result) (= result output)))))
|
||||
|
||||
;;; 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?)
|
||||
|
||||
;; Rounds to thousandths.
|
||||
(define (rounded x)
|
||||
(/ (round (* 1000 x)) 1000))
|
||||
|
||||
(display "Running ")
|
||||
(display name)
|
||||
(newline)
|
||||
(flush-output-port (current-output-port))
|
||||
(let* ((j/s (jiffies-per-second))
|
||||
(t0 (current-second))
|
||||
(j0 (current-jiffy)))
|
||||
(let loop ((i 0)
|
||||
(result #f))
|
||||
(cond ((< i count)
|
||||
(loop (+ i 1) (thunk)))
|
||||
((ok? result)
|
||||
(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)))
|
||||
result)
|
||||
(else
|
||||
(display "ERROR: returned incorrect result: ")
|
||||
(write result)
|
||||
(newline)
|
||||
(flush-output-port (current-output-port))
|
||||
result)))))
|
||||
(define (this-scheme-implementation-name)
|
||||
(string-append "cyclone-" (Cyc-version)))
|
||||
(main)
|
||||
Loading…
Add table
Reference in a new issue