From 6ccfab617ea367672d7a65cc8ce8639a509921ae Mon Sep 17 00:00:00 2001 From: Izaak Walton Date: Fri, 9 Aug 2024 16:10:32 -0700 Subject: [PATCH 1/2] Benchmark sanitization and minor additions --- benchmarks/README.md | 8 +- benchmarks/benchmarks-game/mandelbrot.lisp | 179 +++ benchmarks/benchmarks-game/package.lisp | 4 + benchmarks/benchmarks-game/too-simple.lisp | 41 + benchmarks/big-float.lisp | 104 +- benchmarks/fibonacci.lisp | 113 +- benchmarks/gabriel-benchmarks/package.lisp | 6 + benchmarks/gabriel-benchmarks/stak.lisp | 80 +- benchmarks/gabriel-benchmarks/tak.lisp | 49 +- benchmarks/gabriel-benchmarks/takl.lisp | 102 +- benchmarks/gabriel-benchmarks/takr.lisp | 1635 ++++++++++---------- benchmarks/package.lisp | 83 +- coalton.asd | 16 +- 13 files changed, 1366 insertions(+), 1054 deletions(-) create mode 100644 benchmarks/benchmarks-game/mandelbrot.lisp create mode 100644 benchmarks/benchmarks-game/package.lisp create mode 100644 benchmarks/benchmarks-game/too-simple.lisp create mode 100644 benchmarks/gabriel-benchmarks/package.lisp diff --git a/benchmarks/README.md b/benchmarks/README.md index 2feb099e6..801157237 100644 --- a/benchmarks/README.md +++ b/benchmarks/README.md @@ -1,7 +1,9 @@ -# To run Coalton Benchmarks: +# To load Coalton Benchmarks: `(ql:quickload :coalton/benchmarks)` or `(asdf:load-system :coalton/benchmarks)` -`(in-package #:coalton-benchmarks)` +## Current status: -`(run-benchmarks)` \ No newline at end of file +Due to dependency issues, currently all benchmarks are packaged and run separately. + +They are intended to be incorporated into a cohesive benchmark suite using a coalton benchmarking framework at a later date. diff --git a/benchmarks/benchmarks-game/mandelbrot.lisp b/benchmarks/benchmarks-game/mandelbrot.lisp new file mode 100644 index 000000000..6902f65cf --- /dev/null +++ b/benchmarks/benchmarks-game/mandelbrot.lisp @@ -0,0 +1,179 @@ +(defpackage #:coalton/benchmarks/benchmarks-game/mandelbrot + (:use #:coalton + #:coalton-prelude) + (:local-nicknames (#:math #:coalton-library/math) + (#:vec #:coalton-library/vector) + (#:cell #:coalton-library/cell) + (#:file #:coalton-library/file) + (#:iter #:coalton-library/iterator) + (#:char #:coalton-library/char) + (#:str #:coalton-library/string) + (#:bits #:coalton-library/bits)) + (:export + #:mandelbrot-main + #:mandelbrot-small)) + +(in-package #:coalton/benchmarks/benchmarks-game/mandelbrot) + +(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:setf coalton-impl/settings:*coalton-heuristic-inlining* cl:t)) + +(cl:declaim (cl:optimize (cl:speed 3) + (cl:space 0) + (cl:compilation-speed 0) + (cl:safety 0) + (cl:debug 0))) + +(coalton-toplevel + + (declare mandelbrot-function ((Num (Complex :a)) + => (Complex :a) + -> (Complex :a) + -> (Complex :a))) + (define (mandelbrot-function c z) + (+ (^ z 2) c)) + + (declare mandelbrot-div? ((Ord :a) (Complex :a) + => (Complex :a) + -> Boolean)) + (define (mandelbrot-div? z) + "Is Z guaranteed to diverge in the implementation of the mandelbrot function. True means it is guaranteed, False means it's unsure." + (> (math:square-magnitude z) 4)) + + (declare escapes? (Integer + -> ((Complex :a) -> (Complex :a)) + -> ((Complex :a) -> Boolean) + -> (Complex :a) + -> Integer)) + (define (escapes? limit fc div? z0) + "Returns the number of iterations of the function F " + (let count = (cell:new 0)) + (let result = (cell:new z0)) + + (while :escape (< (cell:read count) limit) + (cell:update! fc result) + (if (div? (cell:read result)) + (break :escape) + (progn (cell:increment! count) Unit))) + (if (== limit (cell:read count)) + -1 + (cell:read count))) + + (declare sample ((Reciprocable :a) (Ord :a) (Complex :a) + => (Complex :a) + -> (Complex :a) + -> Integer + -> Integer + -> ((Complex :a) -> (Complex :a) -> (Complex :a)) + -> ((Complex :a) -> Boolean) + -> (Complex :a) + -> (Vector Integer))) + (define (sample negbound posbound steps limit f div? z0) + (let v = (vec:new)) + (let steps-num = (fromint steps)) + (let width = (- (real-part posbound) (real-part negbound))) + (let height = (- (imag-part posbound) (imag-part negbound))) + (let real-offset = (real-part negbound)) + (let imag-offset = (imag-part negbound)) + (for bi in (iter:up-to steps-num) + (lisp Unit (bi) + (cl:when (cl:zerop (cl:mod bi 100)) + (cl:format cl:t ";; ~D~%" bi)) + Unit) + (for ai in (iter:up-to steps-num) + (let a = (+ real-offset (* width (/ ai steps-num))) + ) + (let b = (+ imag-offset (* height (/ bi steps-num))) + ) + (let c = (Complex a b)) + (vec:push! (escapes? limit (f c) div? z0) v) + Unit)) + v) + + (define (mandelbrot negbound posbound steps limit) + (sample negbound posbound steps limit mandelbrot-function mandelbrot-div? 0))) + +;;; +;;; Writing the header +;;; + +(coalton-toplevel + + (define magic-number + (map (fn (c) + (the U8 (unwrap (tryinto + (char:char-code c))))) + (vec:make #\P #\4 #\Newline))) + + (declare width-height-data (String -> (Vector U8))) + (define (width-height-data n) + (map (fn (c) + (unwrap (tryinto (char:char-code c)))) + (as (Vector Char) + (as (List Char) + (str:concat n + (str:concat " " + (str:concat n + (into (make-list #\Newline)))))))))) + +(coalton-toplevel + + (declare bit-vector ((Vector Integer) -> (Vector U8))) + (define (bit-vector iterated) + "Converts a list of Integers to a bit vector of U8's." + (let out = (vec:new)) + (let current-byte = (cell:new (the U8 0))) + (let bitnum = (cell:new 0)) + (for el in iterated + + (when (== (cell:read bitnum) 8) + (vec:push! (cell:read current-byte) out) + (cell:write! bitnum 0) + (cell:write! current-byte 0) + Unit) + + (cell:update! (bits:shift 1) current-byte) + (cell:increment! bitnum) + (when (== -1 el) + (cell:increment! current-byte) + Unit) + Unit) + + (when (positive? (cell:read bitnum)) + (vec:push! (cell:read current-byte) out) + Unit) + + out)) + +(coalton-toplevel + + (monomorphize) + (declare benchmark-mandelbrot (Integer -> (Vector Integer))) + (define (benchmark-mandelbrot n) + (mandelbrot + (Complex -1.5d0 -1.0d0) + (Complex 0.5d0 1.0d0) + n + 50)) + + (declare mandelbrot-benchmark ((Into :a file:Pathname) => :a -> String -> (Result file:FileError Unit))) + (define (mandelbrot-benchmark filename arg-n) + (file:with-open-file + (file:Output (into filename) + file:Supersede) + (fn (stream) + ;; write the header + (file:write-vector stream magic-number) + (file:write-vector stream (width-height-data arg-n)) + ;; write the raster + (file:write-vector stream (bit-vector + (benchmark-mandelbrot (unwrap (str:parse-int arg-n))))) + (Ok Unit))))) + +(coalton-toplevel + + (define (mandelbrot-small) + (time (fn () (mandelbrot-benchmark "/dev/stdout" "1000")))) + + (define (mandelbrot-main) + (time (fn () (mandelbrot-benchmark "/dev/stdout" "16000"))))) diff --git a/benchmarks/benchmarks-game/package.lisp b/benchmarks/benchmarks-game/package.lisp new file mode 100644 index 000000000..1900176de --- /dev/null +++ b/benchmarks/benchmarks-game/package.lisp @@ -0,0 +1,4 @@ +(uiop:define-package #:coalton/benchmarks/benchmarks-game + (:mix-reexport + #:coalton/benchmarks/benchmarks-game/mandelbrot + #:coalton/benchmarks/benchmarks-game/too-simple)) diff --git a/benchmarks/benchmarks-game/too-simple.lisp b/benchmarks/benchmarks-game/too-simple.lisp new file mode 100644 index 000000000..7748d02a6 --- /dev/null +++ b/benchmarks/benchmarks-game/too-simple.lisp @@ -0,0 +1,41 @@ +(defpackage #:coalton/benchmarks/benchmarks-game/too-simple + (:use #:coalton + #:coalton-prelude) + (:local-nicknames (#:sys #:coalton-library/system) + (#:iter #:coalton-library/iterator) + (#:cell #:coalton-library/cell) + (#:string #:coalton-library/string) + (#:list #:coalton-library/list)) + (:export + #:too-simple-main + #:too-simple-main2)) + +(in-package #:coalton/benchmarks/benchmarks-game/too-simple) + +(cl:declaim (cl:optimize cl:speed (cl:safety 0) (cl:debug 0))) +(coalton-toplevel + + (define (too-simple-main n) + (time (fn () + (let sum = (cell:new 0.0d0)) + (let flip = (cell:new -1.0d0)) + (for i in (map 1+ (iter:up-to n)) + (cell:update! negate flip) + (cell:update! (fn (x) (+ x + (/ (cell:read flip) + (1- (* 2 i))))) + sum)) + (traceobject "Sum" (* (cell:read sum) 4))))) + + (define (too-simple-main2 n) + (time (fn () + (let ((declare run (Double-Float -> Double-Float -> Double-Float -> Double-Float)) + (run (fn (i sum flip) + (if (< n i) + (* 4 sum) + (run (1+ i) + (+ sum + (/ flip + (1- (* 2 i)))) + (negate flip)))))) + (traceobject "Sum:" (run 1.0d0 0.0d0 1.0d0))))))) diff --git a/benchmarks/big-float.lisp b/benchmarks/big-float.lisp index f044ee3aa..b7417888a 100644 --- a/benchmarks/big-float.lisp +++ b/benchmarks/big-float.lisp @@ -1,17 +1,68 @@ ;;;; big-float.lisp ;;;; ;;;; Benchmarks for arbitrary precision floats +(defpackage #:coalton/benchmarks/big-float + (:use #:coalton + #:coalton-prelude + #:coalton-library/math + #:coalton-library/big-float) + (:export + #:big-trig + #:big-inv-trig + #:big-ln-exp + #:big-sqrt + #:big-mult-constants)) -(cl:in-package #:coalton-benchmarks) +(cl:in-package #:coalton/benchmarks/big-float) +(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 1))) + +(coalton-toplevel + (declare big-trig (UFix -> Double-Float -> Big-Float)) + (define (big-trig n x) + (with-precision n + (fn () + (let x = (into x)) + (tan (sin (cos x)))))) + + (declare big-inv-trig (UFix -> Double-Float -> Big-Float)) + (define (big-inv-trig n x) + (with-precision n + (fn () + (let x = (into x)) + (atan (+ (asin x) (acos x)))))) + + (declare big-ln-exp (UFix -> Double-Float -> Big-Float)) + (define (big-ln-exp n x) + (with-precision n + (fn () + (let x = (into x)) + (ln (exp x))))) + + (declare big-sqrt (UFix -> Double-Float -> Big-Float)) + (define (big-sqrt n x) + (with-precision n + (fn () + (let x = (into x)) + (sqrt x)))) + + (define (big-mult-constants n x) + (with-precision n + (fn () + (let x = (into x)) + (* x (* pi ee)))))) + +;;(cl:in-package #:coalton-benchmarks) + +#+ig (cl:defvar *big-float-bench-precision* #-coalton-portable-bigfloat 10000 #+coalton-portable-bigfloat 100) -(cl:defvar *big-float-bench-iterations* +#+ig(cl:defvar *big-float-bench-iterations* #-coalton-portable-bigfloat 1000 #+coalton-portable-bigfloat 10) -(define-benchmark big-trig () +#+ig(define-benchmark big-trig () "Benchmark at N precision big-float trigonometric functions." (declare (optimize speed)) (loop :repeat *big-float-bench-iterations* @@ -21,7 +72,7 @@ (* (- (random 2)) (random 100.0d0))))) (report trivial-benchmark::*current-timer*)) -(define-benchmark big-inv-trig () +#+ig(define-benchmark big-inv-trig () "Benchmark at N precision big-float inverse trigonometric functions." (declare (optimize speed)) (loop :repeat *big-float-bench-iterations* @@ -31,7 +82,7 @@ (* (- (random 2)) (random 1.0d0))))) (report trivial-benchmark::*current-timer*)) -(define-benchmark big-ln-exp () +#+ig(define-benchmark big-ln-exp () "Benchmark at N precision big-float ln and exp." (declare (optimize speed)) (loop :repeat *big-float-bench-iterations* @@ -41,7 +92,7 @@ (* (- (random 2)) (random 100.0d0))))) (report trivial-benchmark::*current-timer*)) -(define-benchmark big-sqrt () +#+ig(define-benchmark big-sqrt () "Benchmark at N precision big-float square roots." (declare (optimize speed)) (loop :repeat *big-float-bench-iterations* @@ -51,7 +102,7 @@ (random 100.0d0)))) (report trivial-benchmark::*current-timer*)) -(define-benchmark big-mult-constants () +#+ig(define-benchmark big-mult-constants () "Benchmark at N precision big-float multiplication of pi and euler's number." (declare (optimize speed)) (loop :repeat *big-float-bench-iterations* @@ -60,42 +111,3 @@ *big-float-bench-precision* (* (- (random 2)) (random 100.0d0))))) (report trivial-benchmark::*current-timer*)) - -(cl:in-package #:coalton-benchmarks/native) - -(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 1))) - -(coalton-toplevel - (declare big-trig (UFix -> Double-Float -> Big-Float)) - (define (big-trig n x) - (with-precision n - (fn () - (let x = (into x)) - (tan (sin (cos x)))))) - - (declare big-inv-trig (UFix -> Double-Float -> Big-Float)) - (define (big-inv-trig n x) - (with-precision n - (fn () - (let x = (into x)) - (atan (+ (asin x) (acos x)))))) - - (declare big-ln-exp (UFix -> Double-Float -> Big-Float)) - (define (big-ln-exp n x) - (with-precision n - (fn () - (let x = (into x)) - (ln (exp x))))) - - (declare big-sqrt (UFix -> Double-Float -> Big-Float)) - (define (big-sqrt n x) - (with-precision n - (fn () - (let x = (into x)) - (sqrt x)))) - - (define (big-mult-constants n x) - (with-precision n - (fn () - (let x = (into x)) - (* x (* pi ee)))))) diff --git a/benchmarks/fibonacci.lisp b/benchmarks/fibonacci.lisp index 222c1c68f..60ba765e9 100644 --- a/benchmarks/fibonacci.lisp +++ b/benchmarks/fibonacci.lisp @@ -2,23 +2,81 @@ ;;;; ;;;; Benchmarks for different methods of generating fibonacci numbers -(cl:in-package #:coalton-benchmarks) +(defpackage #:coalton/benchmarks/fibonacci + (:use #:coalton + #:coalton-prelude) + (:export + #:fib + #:fib-generic + #:fib-generic-wrapped + #:fib-monomorphized + #:fib-generic-optional + #:fib-monomorphized-optional)) + +(in-package #:coalton/benchmarks/fibonacci) -(define-benchmark recursive-fib () +(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) + +(coalton-toplevel + (declare fib (Integer -> Integer)) + (define (fib n) + (when (== n 0) + (return 0)) + + (when (== n 1) + (return 1)) + + (+ (fib (- n 1)) (fib (- n 2)))) + + (declare fib-generic (Num :a => :a -> :a)) + (define (fib-generic n) + (when (== n 0) + (return 0)) + + (when (== n 1) + (return 1)) + + (+ (fib-generic (- n 1)) (fib-generic (- n 2)))) + + (declare fib-generic-wrapped (Integer -> Integer)) + (define (fib-generic-wrapped x) + (fib-generic x)) + + (monomorphize) + (declare fib-monomorphized (Integer -> Integer)) + (define (fib-monomorphized x) + (fib-generic x)) + + (declare fib-generic-optional (Integer -> Optional Integer)) + (define (fib-generic-optional x) + (fib-generic (Some x))) + + (monomorphize) + (declare fib-monomorphized-optional (Integer -> Optional Integer)) + (define (fib-monomorphized-optional x) + (fib-generic (Some x)))) + +;;; +;;; Deprecated Trivial-Benchmarks +;;; + +;;(cl:in-package #:coalton-benchmarks) + +#+ig (define-benchmark recursive-fib () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling (coalton-benchmarks/native:fib 20))) (report trivial-benchmark::*current-timer*)) -(define-benchmark recursive-fib-generic () +#+ig (define-benchmark recursive-fib-generic () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling (coalton-benchmarks/native:fib-generic-wrapped 20))) (report trivial-benchmark::*current-timer*)) -(define-benchmark recursive-fib-lisp () +#+ig (define-benchmark recursive-fib-lisp () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling @@ -26,7 +84,7 @@ (report trivial-benchmark::*current-timer*)) -(define-benchmark recursive-fib-monomorphized () +#+ig(define-benchmark recursive-fib-monomorphized () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling @@ -54,7 +112,7 @@ (coalton-benchmarks/native:fib-monomorphized-optional 10))) (report trivial-benchmark::*current-timer*)) -(defun lisp-fib (n) +#+ig(defun lisp-fib (n) (declare (type integer n) (values integer) (optimize (speed 3) (safety 0))) @@ -66,45 +124,4 @@ (+ (lisp-fib (- n 1)) (lisp-fib (- n 2)))) -(cl:in-package #:coalton-benchmarks/native) - -(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) - -(coalton-toplevel - (declare fib (Integer -> Integer)) - (define (fib n) - (when (== n 0) - (return 0)) - - (when (== n 1) - (return 1)) - - (+ (fib (- n 1)) (fib (- n 2)))) - - (declare fib-generic (Num :a => :a -> :a)) - (define (fib-generic n) - (when (== n 0) - (return 0)) - - (when (== n 1) - (return 1)) - - (+ (fib-generic (- n 1)) (fib-generic (- n 2)))) - - (declare fib-generic-wrapped (Integer -> Integer)) - (define (fib-generic-wrapped x) - (fib-generic x)) - - (monomorphize) - (declare fib-monomorphized (Integer -> Integer)) - (define (fib-monomorphized x) - (fib-generic x)) - - (declare fib-generic-optional (Integer -> Optional Integer)) - (define (fib-generic-optional x) - (fib-generic (Some x))) - - (monomorphize) - (declare fib-monomorphized-optional (Integer -> Optional Integer)) - (define (fib-monomorphized-optional x) - (fib-generic (Some x)))) +;; (cl:in-package #:coalton-benchmarks/native) diff --git a/benchmarks/gabriel-benchmarks/package.lisp b/benchmarks/gabriel-benchmarks/package.lisp new file mode 100644 index 000000000..7da79768c --- /dev/null +++ b/benchmarks/gabriel-benchmarks/package.lisp @@ -0,0 +1,6 @@ +(uiop:define-package #:coalton/benchmarks/gabriel + (:mix-reexport + #:coalton/benchmarks/gabriel/tak + #:coalton/benchmarks/gabriel/stak + #:coalton/benchmarks/gabriel/takl + #:coalton/benchmarks/gabriel/takr)) diff --git a/benchmarks/gabriel-benchmarks/stak.lisp b/benchmarks/gabriel-benchmarks/stak.lisp index 87c793580..4fc561d24 100644 --- a/benchmarks/gabriel-benchmarks/stak.lisp +++ b/benchmarks/gabriel-benchmarks/stak.lisp @@ -2,16 +2,51 @@ ;;;; ;;;; -(in-package #:coalton-benchmarks) +(defpackage #:coalton/benchmarks/gabriel/stak + (:use #:coalton + #:coalton-prelude) + (:export + #:stak + #:stak-main)) -(define-benchmark stak () +(cl:in-package #:coalton/benchmarks/gabriel/stak) + +(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) + +(coalton-toplevel + + (declare stak (IFix -> IFix -> IFix -> IFix)) + (define (stak x y z) + (if (not (< y x)) + z + (let ((x1 (let ((x2 (1- x)) + (y2 y) + (z2 z)) + (stak x2 y2 z2))) + (y1 (let ((x2 (1- y)) + (y2 z) + (z2 x)) + (stak x2 y2 z2))) + (z1 (let ((x2 (1- z)) + (y2 x) + (z2 y)) + (stak x2 y2 z2)))) + (stak x1 y1 z1)))) + + (define (stak-main) + (time (fn () + (stak 18 12 6))))) + +;; (in-package #:coalton-benchmarks) + +#+ig(define-benchmark stak () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling (coalton-benchmarks/native:stak 18 12 6))) (report trivial-benchmark::*current-timer*)) -(define-benchmark stak-lisp () +#+ig(define-benchmark stak-lisp () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling @@ -23,12 +58,12 @@ ;;; -(defvar x) -(defvar y) -(defvar z) +;(defvar x) +;(defvar y) +;(defvar z) -(declaim (ftype (function () fixnum) stak-aux)) -(defun stak-aux () +;(declaim (ftype (function () fixnum) stak-aux)) +#+ig(defun stak-aux () (if (not (< y x)) z (let ((x (let ((x (1- x)) @@ -44,35 +79,10 @@ (stak-aux)))) (stak-aux)))) -(declaim (ftype (function (fixnum) fixnum) lisp-stak)) -(defun lisp-stak (x y z) +;(declaim (ftype (function (fixnum) fixnum) lisp-stak)) +#+ig(defun lisp-stak (x y z) (stak-aux)) ;;; ;;; ;;; - - -(cl:in-package #:coalton-benchmarks/native) - -(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) - -(coalton-toplevel - - (declare stak (IFix -> IFix -> IFix -> IFix)) - (define (stak x y z) - (if (not (< y x)) - z - (let ((x1 (let ((x2 (1- x)) - (y2 y) - (z2 z)) - (stak x2 y2 z2))) - (y1 (let ((x2 (1- y)) - (y2 z) - (z2 x)) - (stak x2 y2 z2))) - (z1 (let ((x2 (1- z)) - (y2 x) - (z2 y)) - (stak x2 y2 z2)))) - (stak x1 y1 z1))))) diff --git a/benchmarks/gabriel-benchmarks/tak.lisp b/benchmarks/gabriel-benchmarks/tak.lisp index d5322c11c..1225d1940 100644 --- a/benchmarks/gabriel-benchmarks/tak.lisp +++ b/benchmarks/gabriel-benchmarks/tak.lisp @@ -2,15 +2,40 @@ ;;;; ;;;; -(cl:in-package #:coalton-benchmarks) +(defpackage #:coalton/benchmarks/gabriel/tak + (:use #:coalton + #:coalton-prelude) + (:export + #:tak + #:tak-main)) -(define-benchmark tak () +(cl:in-package #:coalton/benchmarks/gabriel/tak) + +(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) + +(coalton-toplevel + + (declare tak (IFix -> IFix -> IFix -> IFix)) + (define (tak x y z) + (if (not (< y x)) + z + (tak (tak (1- x) y z) + (tak (1- y) z x) + (tak (1- z) x y)))) + + (define (tak-main) + (time (fn () (tak 18 12 6))))) + + +;; (cl:in-package #:coalton-benchmarks) + +#+ig(define-benchmark tak () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling (coalton:coalton (coalton-benchmarks/native:tak 18 12 6)))) (report trivial-benchmark::*current-timer*)) - +#+ig (define-benchmark tak-lisp () (declare (optimize speed)) (loop :repeat 1000 @@ -18,24 +43,10 @@ (lisp-tak 18 12 6))) (report trivial-benchmark::*current-timer*)) -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) lisp-tak)) -(defun lisp-tak (x y z) +;;(declaim (ftype (function (fixnum fixnum fixnum) fixnum) lisp-tak)) +#+ig(defun lisp-tak (x y z) (if (not (< y x)) z (lisp-tak (lisp-tak (1- x) y z) (lisp-tak (1- y) z x) (lisp-tak (1- z) x y)))) - -(cl:in-package #:coalton-benchmarks/native) - -(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) - -(coalton-toplevel - - (declare tak (IFix -> IFix -> IFix -> IFix)) - (define (tak x y z) - (if (not (< y x)) - z - (tak (tak (1- x) y z) - (tak (1- y) z x) - (tak (1- z) x y))))) diff --git a/benchmarks/gabriel-benchmarks/takl.lisp b/benchmarks/gabriel-benchmarks/takl.lisp index 23e3fdd87..04f9891ba 100644 --- a/benchmarks/gabriel-benchmarks/takl.lisp +++ b/benchmarks/gabriel-benchmarks/takl.lisp @@ -2,16 +2,61 @@ ;;;; ;;;; -(cl:in-package #:coalton-benchmarks) +(defpackage #:coalton/benchmarks/gabriel/takl + (:use #:coalton + #:coalton-prelude) + (:local-nicknames (#:list #:coalton-library/list)) + (:export + #:takl + #:takl-main)) -(define-benchmark takl () +(in-package #:coalton/benchmarks/gabriel/takl) + +(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) + +(coalton-toplevel + + (declare listn (UFix -> (List UFix))) + (define (listn n) + (if (not (== n 0)) + (Cons n (listn (1- n))) + Nil)) + + (declare shorterp ((List UFix) -> (List UFix) -> Boolean)) + (define (shorterp x y) + (and (not (list:null? y)) + (or (list:null? x) + (shorterp (list:cdr x) + (list:cdr y))))) + + (declare mas ((List UFix) -> (List UFix) -> (List UFix) -> (List UFix))) + (define (mas x y z) + (if (not (shorterp y x)) + z + (mas (mas (list:cdr x) + y z) + (mas (list:cdr y) + z x) + (mas (list:cdr z) + x y)))) + + (declare takl (UFix -> UFix -> UFix -> (List UFix))) + (define (takl x y z) + (mas (listn x) (listn y) (listn z))) + + (define (takl-main) + (time (fn () (takl 18 12 6))))) + +;; (cl:in-package #:coalton-benchmarks) + +#+ig(define-benchmark takl () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling (coalton-benchmarks/native:takl 18 12 6))) (report trivial-benchmark::*current-timer*)) -(define-benchmark takl-lisp () +#+ig(define-benchmark takl-lisp () (declare (optimize speed)) (loop :repeat 1000 :do (with-benchmark-sampling @@ -22,19 +67,19 @@ ;;; ;;; -(declaim (ftype (function (fixnum) list) listn)) -(defun listn (n) +;;(declaim (ftype (function (fixnum) list) listn)) +#+ig(defun listn (n) (if (not (= 0 n)) (cons n (listn (1- n))))) -(declaim (ftype (function (list list) boolean))) -(defun shorterp (x y) +;;(declaim (ftype (function (list list) boolean))) +#+ig(defun shorterp (x y) (and y (or (null x) (shorterp (cdr x) (cdr y))))) -(declaim (ftype (function (list list list) list))) -(defun mas (x y z) +;; (declaim (ftype (function (list list list) list))) +#+ig(defun mas (x y z) (if (not (shorterp y x)) z (mas (mas (cdr x) @@ -44,45 +89,10 @@ (mas (cdr z) x y)))) -(declaim (ftype (function (fixnum fixnum fixnum) list))) -(defun lisp-takl (x y z) +;;(declaim (ftype (function (fixnum fixnum fixnum) list))) +#+ig(defun lisp-takl (x y z) (mas (listn x) (listn y) (listn z))) ;;; ;;; ;;; - - -(cl:in-package #:coalton-benchmarks/native) - -(cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) - -(coalton-toplevel - - (declare listn (UFix -> (List UFix))) - (define (listn n) - (if (not (== n 0)) - (Cons n (listn (1- n))) - Nil)) - - (declare shorterp ((List UFix) -> (List UFix) -> Boolean)) - (define (shorterp x y) - (and (not (list:null? y)) - (or (list:null? x) - (shorterp (list:cdr x) - (list:cdr y))))) - - (declare mas ((List UFix) -> (List UFix) -> (List UFix) -> (List UFix))) - (define (mas x y z) - (if (not (shorterp y x)) - z - (mas (mas (list:cdr x) - y z) - (mas (list:cdr y) - z x) - (mas (list:cdr z) - x y)))) - - (declare takl (UFix -> UFix -> UFix -> (List UFix))) - (define (takl x y z) - (mas (listn x) (listn y) (listn z)))) diff --git a/benchmarks/gabriel-benchmarks/takr.lisp b/benchmarks/gabriel-benchmarks/takr.lisp index a8ce2bb5a..19d43e7cf 100644 --- a/benchmarks/gabriel-benchmarks/takr.lisp +++ b/benchmarks/gabriel-benchmarks/takr.lisp @@ -2,744 +2,29 @@ ;;;; ;;;; -(cl:in-package #:coalton-benchmarks) - -(define-benchmark takr () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (coalton-benchmarks/native:takr 18 12 6))) - (report trivial-benchmark::*current-timer*)) - -(define-benchmark takr-lisp () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (lisp-takr 18 12 6))) - (report trivial-benchmark::*current-timer*)) +(defpackage #:coalton/benchmarks/gabriel/takr + (:use #:coalton + #:coalton-prelude) + (:export + #:takr + #:takr-main)) -;;; -;;; -;;; - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) lisp-takr)) -(defun lisp-takr (x y z) - (cond ((>= y x) z) - (t (tak1 (tak37 (- x 1) y z) - (tak11 (- y 1) z x) - (tak17 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak1)) -(defun tak1 (x y z) - (cond ((>= y x) z) - (t (tak2 (tak74 (- x 1) y z) - (tak22 (- y 1) z x) - (tak34 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak2)) -(defun tak2 (x y z) - (cond ((>= y x) z) - (t (tak3 (tak11 (- x 1) y z) - (tak33 (- y 1) z x) - (tak51 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak3)) -(defun tak3 (x y z) - (cond ((>= y x) z) - (t (tak4 (tak48 (- x 1) y z) - (tak44 (- y 1) z x) - (tak68 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak4)) -(defun tak4 (x y z) - (cond ((>= y x) z) - (t (tak5 (tak85 (- x 1) y z) - (tak55 (- y 1) z x) - (tak85 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak5)) -(defun tak5 (x y z) - (cond ((>= y x) z) - (t (tak6 (tak22 (- x 1) y z) - (tak66 (- y 1) z x) - (tak2 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak6)) -(defun tak6 (x y z) - (cond ((>= y x) z) - (t (tak7 (tak59 (- x 1) y z) - (tak77 (- y 1) z x) - (tak19 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak7)) -(defun tak7 (x y z) - (cond ((>= y x) z) - (t (tak8 (tak96 (- x 1) y z) - (tak88 (- y 1) z x) - (tak36 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak8)) -(defun tak8 (x y z) - (cond ((>= y x) z) - (t (tak9 (tak33 (- x 1) y z) - (tak99 (- y 1) z x) - (tak53 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak9)) -(defun tak9 (x y z) - (cond ((>= y x) z) - (t (tak10 (tak70 (- x 1) y z) - (tak10 (- y 1) z x) - (tak70 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak10)) -(defun tak10 (x y z) - (cond ((>= y x) z) - (t (tak11 (tak7 (- x 1) y z) - (tak21 (- y 1) z x) - (tak87 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak11)) -(defun tak11 (x y z) - (cond ((>= y x) z) - (t (tak12 (tak44 (- x 1) y z) - (tak32 (- y 1) z x) - (tak4 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak12)) -(defun tak12 (x y z) - (cond ((>= y x) z) - (t (tak13 (tak81 (- x 1) y z) - (tak43 (- y 1) z x) - (tak21 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak13)) -(defun tak13 (x y z) - (cond ((>= y x) z) - (t (tak14 (tak18 (- x 1) y z) - (tak54 (- y 1) z x) - (tak38 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak14)) -(defun tak14 (x y z) - (cond ((>= y x) z) - (t (tak15 (tak55 (- x 1) y z) - (tak65 (- y 1) z x) - (tak55 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak15)) -(defun tak15 (x y z) - (cond ((>= y x) z) - (t (tak16 (tak92 (- x 1) y z) - (tak76 (- y 1) z x) - (tak72 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak16)) -(defun tak16 (x y z) - (cond ((>= y x) z) - (t (tak17 (tak29 (- x 1) y z) - (tak87 (- y 1) z x) - (tak89 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak17)) -(defun tak17 (x y z) - (cond ((>= y x) z) - (t (tak18 (tak66 (- x 1) y z) - (tak98 (- y 1) z x) - (tak6 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak18)) -(defun tak18 (x y z) - (cond ((>= y x) z) - (t (tak19 (tak3 (- x 1) y z) - (tak9 (- y 1) z x) - (tak23 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak19)) -(defun tak19 (x y z) - (cond ((>= y x) z) - (t (tak20 (tak40 (- x 1) y z) - (tak20 (- y 1) z x) - (tak40 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak20)) -(defun tak20 (x y z) - (cond ((>= y x) z) - (t (tak21 (tak77 (- x 1) y z) - (tak31 (- y 1) z x) - (tak57 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak21)) -(defun tak21 (x y z) - (cond ((>= y x) z) - (t (tak22 (tak14 (- x 1) y z) - (tak42 (- y 1) z x) - (tak74 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak22)) -(defun tak22 (x y z) - (cond ((>= y x) z) - (t (tak23 (tak51 (- x 1) y z) - (tak53 (- y 1) z x) - (tak91 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak23)) -(defun tak23 (x y z) - (cond ((>= y x) z) - (t (tak24 (tak88 (- x 1) y z) - (tak64 (- y 1) z x) - (tak8 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak24)) -(defun tak24 (x y z) - (cond ((>= y x) z) - (t (tak25 (tak25 (- x 1) y z) - (tak75 (- y 1) z x) - (tak25 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak25)) -(defun tak25 (x y z) - (cond ((>= y x) z) - (t (tak26 (tak62 (- x 1) y z) - (tak86 (- y 1) z x) - (tak42 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak26)) -(defun tak26 (x y z) - (cond ((>= y x) z) - (t (tak27 (tak99 (- x 1) y z) - (tak97 (- y 1) z x) - (tak59 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak27)) -(defun tak27 (x y z) - (cond ((>= y x) z) - (t (tak28 (tak36 (- x 1) y z) - (tak8 (- y 1) z x) - (tak76 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak28)) -(defun tak28 (x y z) - (cond ((>= y x) z) - (t (tak29 (tak73 (- x 1) y z) - (tak19 (- y 1) z x) - (tak93 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak29)) -(defun tak29 (x y z) - (cond ((>= y x) z) - (t (tak30 (tak10 (- x 1) y z) - (tak30 (- y 1) z x) - (tak10 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak30)) -(defun tak30 (x y z) - (cond ((>= y x) z) - (t (tak31 (tak47 (- x 1) y z) - (tak41 (- y 1) z x) - (tak27 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak31)) -(defun tak31 (x y z) - (cond ((>= y x) z) - (t (tak32 (tak84 (- x 1) y z) - (tak52 (- y 1) z x) - (tak44 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak32)) -(defun tak32 (x y z) - (cond ((>= y x) z) - (t (tak33 (tak21 (- x 1) y z) - (tak63 (- y 1) z x) - (tak61 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak33)) -(defun tak33 (x y z) - (cond ((>= y x) z) - (t (tak34 (tak58 (- x 1) y z) - (tak74 (- y 1) z x) - (tak78 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak34)) -(defun tak34 (x y z) - (cond ((>= y x) z) - (t (tak35 (tak95 (- x 1) y z) - (tak85 (- y 1) z x) - (tak95 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak35)) -(defun tak35 (x y z) - (cond ((>= y x) z) - (t (tak36 (tak32 (- x 1) y z) - (tak96 (- y 1) z x) - (tak12 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak36)) -(defun tak36 (x y z) - (cond ((>= y x) z) - (t (tak37 (tak69 (- x 1) y z) - (tak7 (- y 1) z x) - (tak29 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak37)) -(defun tak37 (x y z) - (cond ((>= y x) z) - (t (tak38 (tak6 (- x 1) y z) - (tak18 (- y 1) z x) - (tak46 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak38)) -(defun tak38 (x y z) - (cond ((>= y x) z) - (t (tak39 (tak43 (- x 1) y z) - (tak29 (- y 1) z x) - (tak63 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak39)) -(defun tak39 (x y z) - (cond ((>= y x) z) - (t (tak40 (tak80 (- x 1) y z) - (tak40 (- y 1) z x) - (tak80 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak40)) -(defun tak40 (x y z) - (cond ((>= y x) z) - (t (tak41 (tak17 (- x 1) y z) - (tak51 (- y 1) z x) - (tak97 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak41)) -(defun tak41 (x y z) - (cond ((>= y x) z) - (t (tak42 (tak54 (- x 1) y z) - (tak62 (- y 1) z x) - (tak14 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak42)) -(defun tak42 (x y z) - (cond ((>= y x) z) - (t (tak43 (tak91 (- x 1) y z) - (tak73 (- y 1) z x) - (tak31 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak43)) -(defun tak43 (x y z) - (cond ((>= y x) z) - (t (tak44 (tak28 (- x 1) y z) - (tak84 (- y 1) z x) - (tak48 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak44)) -(defun tak44 (x y z) - (cond ((>= y x) z) - (t (tak45 (tak65 (- x 1) y z) - (tak95 (- y 1) z x) - (tak65 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak45)) -(defun tak45 (x y z) - (cond ((>= y x) z) - (t (tak46 (tak2 (- x 1) y z) - (tak6 (- y 1) z x) - (tak82 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak46)) -(defun tak46 (x y z) - (cond ((>= y x) z) - (t (tak47 (tak39 (- x 1) y z) - (tak17 (- y 1) z x) - (tak99 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak47)) -(defun tak47 (x y z) - (cond ((>= y x) z) - (t (tak48 (tak76 (- x 1) y z) - (tak28 (- y 1) z x) - (tak16 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak48)) -(defun tak48 (x y z) - (cond ((>= y x) z) - (t (tak49 (tak13 (- x 1) y z) - (tak39 (- y 1) z x) - (tak33 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak49)) -(defun tak49 (x y z) - (cond ((>= y x) z) - (t (tak50 (tak50 (- x 1) y z) - (tak50 (- y 1) z x) - (tak50 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak50)) -(defun tak50 (x y z) - (cond ((>= y x) z) - (t (tak51 (tak87 (- x 1) y z) - (tak61 (- y 1) z x) - (tak67 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak51)) -(defun tak51 (x y z) - (cond ((>= y x) z) - (t (tak52 (tak24 (- x 1) y z) - (tak72 (- y 1) z x) - (tak84 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak52)) -(defun tak52 (x y z) - (cond ((>= y x) z) - (t (tak53 (tak61 (- x 1) y z) - (tak83 (- y 1) z x) - (tak1 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak53)) -(defun tak53 (x y z) - (cond ((>= y x) z) - (t (tak54 (tak98 (- x 1) y z) - (tak94 (- y 1) z x) - (tak18 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak54)) -(defun tak54 (x y z) - (cond ((>= y x) z) - (t (tak55 (tak35 (- x 1) y z) - (tak5 (- y 1) z x) - (tak35 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak55)) -(defun tak55 (x y z) - (cond ((>= y x) z) - (t (tak56 (tak72 (- x 1) y z) - (tak16 (- y 1) z x) - (tak52 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak56)) -(defun tak56 (x y z) - (cond ((>= y x) z) - (t (tak57 (tak9 (- x 1) y z) - (tak27 (- y 1) z x) - (tak69 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak57)) -(defun tak57 (x y z) - (cond ((>= y x) z) - (t (tak58 (tak46 (- x 1) y z) - (tak38 (- y 1) z x) - (tak86 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak58)) -(defun tak58 (x y z) - (cond ((>= y x) z) - (t (tak59 (tak83 (- x 1) y z) - (tak49 (- y 1) z x) - (tak3 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak59)) -(defun tak59 (x y z) - (cond ((>= y x) z) - (t (tak60 (tak20 (- x 1) y z) - (tak60 (- y 1) z x) - (tak20 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak60)) -(defun tak60 (x y z) - (cond ((>= y x) z) - (t (tak61 (tak57 (- x 1) y z) - (tak71 (- y 1) z x) - (tak37 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak61)) -(defun tak61 (x y z) - (cond ((>= y x) z) - (t (tak62 (tak94 (- x 1) y z) - (tak82 (- y 1) z x) - (tak54 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak62)) -(defun tak62 (x y z) - (cond ((>= y x) z) - (t (tak63 (tak31 (- x 1) y z) - (tak93 (- y 1) z x) - (tak71 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak63)) -(defun tak63 (x y z) - (cond ((>= y x) z) - (t (tak64 (tak68 (- x 1) y z) - (tak4 (- y 1) z x) - (tak88 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak64)) -(defun tak64 (x y z) - (cond ((>= y x) z) - (t (tak65 (tak5 (- x 1) y z) - (tak15 (- y 1) z x) - (tak5 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak65)) -(defun tak65 (x y z) - (cond ((>= y x) z) - (t (tak66 (tak42 (- x 1) y z) - (tak26 (- y 1) z x) - (tak22 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak66)) -(defun tak66 (x y z) - (cond ((>= y x) z) - (t (tak67 (tak79 (- x 1) y z) - (tak37 (- y 1) z x) - (tak39 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak67)) -(defun tak67 (x y z) - (cond ((>= y x) z) - (t (tak68 (tak16 (- x 1) y z) - (tak48 (- y 1) z x) - (tak56 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak68)) -(defun tak68 (x y z) - (cond ((>= y x) z) - (t (tak69 (tak53 (- x 1) y z) - (tak59 (- y 1) z x) - (tak73 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak69)) -(defun tak69 (x y z) - (cond ((>= y x) z) - (t (tak70 (tak90 (- x 1) y z) - (tak70 (- y 1) z x) - (tak90 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak70)) -(defun tak70 (x y z) - (cond ((>= y x) z) - (t (tak71 (tak27 (- x 1) y z) - (tak81 (- y 1) z x) - (tak7 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak71)) -(defun tak71 (x y z) - (cond ((>= y x) z) - (t (tak72 (tak64 (- x 1) y z) - (tak92 (- y 1) z x) - (tak24 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak72)) -(defun tak72 (x y z) - (cond ((>= y x) z) - (t (tak73 (tak1 (- x 1) y z) - (tak3 (- y 1) z x) - (tak41 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak73)) -(defun tak73 (x y z) - (cond ((>= y x) z) - (t (tak74 (tak38 (- x 1) y z) - (tak14 (- y 1) z x) - (tak58 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak74)) -(defun tak74 (x y z) - (cond ((>= y x) z) - (t (tak75 (tak75 (- x 1) y z) - (tak25 (- y 1) z x) - (tak75 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak75)) -(defun tak75 (x y z) - (cond ((>= y x) z) - (t (tak76 (tak12 (- x 1) y z) - (tak36 (- y 1) z x) - (tak92 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak76)) -(defun tak76 (x y z) - (cond ((>= y x) z) - (t (tak77 (tak49 (- x 1) y z) - (tak47 (- y 1) z x) - (tak9 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak77)) -(defun tak77 (x y z) - (cond ((>= y x) z) - (t (tak78 (tak86 (- x 1) y z) - (tak58 (- y 1) z x) - (tak26 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak78)) -(defun tak78 (x y z) - (cond ((>= y x) z) - (t (tak79 (tak23 (- x 1) y z) - (tak69 (- y 1) z x) - (tak43 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak79)) -(defun tak79 (x y z) - (cond ((>= y x) z) - (t (tak80 (tak60 (- x 1) y z) - (tak80 (- y 1) z x) - (tak60 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak80)) -(defun tak80 (x y z) - (cond ((>= y x) z) - (t (tak81 (tak97 (- x 1) y z) - (tak91 (- y 1) z x) - (tak77 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak81)) -(defun tak81 (x y z) - (cond ((>= y x) z) - (t (tak82 (tak34 (- x 1) y z) - (tak2 (- y 1) z x) - (tak94 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak82)) -(defun tak82 (x y z) - (cond ((>= y x) z) - (t (tak83 (tak71 (- x 1) y z) - (tak13 (- y 1) z x) - (tak11 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak83)) -(defun tak83 (x y z) - (cond ((>= y x) z) - (t (tak84 (tak8 (- x 1) y z) - (tak24 (- y 1) z x) - (tak28 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak84)) -(defun tak84 (x y z) - (cond ((>= y x) z) - (t (tak85 (tak45 (- x 1) y z) - (tak35 (- y 1) z x) - (tak45 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak85)) -(defun tak85 (x y z) - (cond ((>= y x) z) - (t (tak86 (tak82 (- x 1) y z) - (tak46 (- y 1) z x) - (tak62 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak86)) -(defun tak86 (x y z) - (cond ((>= y x) z) - (t (tak87 (tak19 (- x 1) y z) - (tak57 (- y 1) z x) - (tak79 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak87)) -(defun tak87 (x y z) - (cond ((>= y x) z) - (t (tak88 (tak56 (- x 1) y z) - (tak68 (- y 1) z x) - (tak96 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak88)) -(defun tak88 (x y z) - (cond ((>= y x) z) - (t (tak89 (tak93 (- x 1) y z) - (tak79 (- y 1) z x) - (tak13 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak89)) -(defun tak89 (x y z) - (cond ((>= y x) z) - (t (tak90 (tak30 (- x 1) y z) - (tak90 (- y 1) z x) - (tak30 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak91)) -(defun tak90 (x y z) - (cond ((>= y x) z) - (t (tak91 (tak67 (- x 1) y z) - (tak1 (- y 1) z x) - (tak47 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak92)) -(defun tak91 (x y z) - (cond ((>= y x) z) - (t (tak92 (tak4 (- x 1) y z) - (tak12 (- y 1) z x) - (tak64 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak93)) -(defun tak92 (x y z) - (cond ((>= y x) z) - (t (tak93 (tak41 (- x 1) y z) - (tak23 (- y 1) z x) - (tak81 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak94)) -(defun tak93 (x y z) - (cond ((>= y x) z) - (t (tak94 (tak78 (- x 1) y z) - (tak34 (- y 1) z x) - (tak98 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak95)) -(defun tak94 (x y z) - (cond ((>= y x) z) - (t (tak95 (tak15 (- x 1) y z) - (tak45 (- y 1) z x) - (tak15 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak96)) -(defun tak95 (x y z) - (cond ((>= y x) z) - (t (tak96 (tak52 (- x 1) y z) - (tak56 (- y 1) z x) - (tak32 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak96)) -(defun tak96 (x y z) - (cond ((>= y x) z) - (t (tak97 (tak89 (- x 1) y z) - (tak67 (- y 1) z x) - (tak49 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak97)) -(defun tak97 (x y z) - (cond ((>= y x) z) - (t (tak98 (tak26 (- x 1) y z) - (tak78 (- y 1) z x) - (tak66 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak98)) -(defun tak98 (x y z) - (cond ((>= y x) z) - (t (tak99 (tak63 (- x 1) y z) - (tak89 (- y 1) z x) - (tak83 (- z 1) x y))))) - -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak99)) -(defun tak99 (x y z) - (cond ((>= y x) z) - (t (lisp-takr (lisp-takr (- x 1) y z) - (lisp-takr (- y 1) z x) - (lisp-takr (- z 1) x y))))) - -;;; -;;; -;;; - - -(cl:in-package #:coalton-benchmarks/native) +(cl:in-package #:coalton/benchmarks/gabriel/takr) (cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) (coalton-toplevel + (define (takr-main) + (time (fn () (takr 18 12 6)))) + (declare takr (UFix -> UFix -> UFix -> UFix)) (define (takr x y z) (cond ((>= y x) z) (True (tak1 (tak37 (- x 1) y z) (tak11 (- y 1) z x) (tak17 (- z 1) x y))))) - + (declare tak1 (UFix -> UFix -> UFix -> UFix)) (define (tak1 x y z) (cond ((>= y x) z) @@ -816,7 +101,7 @@ (True (tak12 (tak44 (- x 1) y z) (tak32 (- y 1) z x) (tak4 (- z 1) x y))))) - + (declare tak12 (UFix -> UFix -> UFix -> UFix)) (define (tak12 x y z) (cond ((>= y x) z) @@ -830,605 +115,1329 @@ (True (tak14 (tak18 (- x 1) y z) (tak54 (- y 1) z x) (tak38 (- z 1) x y))))) - + (declare tak14 (UFix -> UFix -> UFix -> UFix)) (define (tak14 x y z) (cond ((>= y x) z) (True (tak15 (tak55 (- x 1) y z) (tak65 (- y 1) z x) (tak55 (- z 1) x y))))) - + (declare tak15 (UFix -> UFix -> UFix -> UFix)) (define (tak15 x y z) (cond ((>= y x) z) (True (tak16 (tak92 (- x 1) y z) (tak76 (- y 1) z x) (tak72 (- z 1) x y))))) - + (declare tak16 (UFix -> UFix -> UFix -> UFix)) (define (tak16 x y z) (cond ((>= y x) z) (True (tak17 (tak29 (- x 1) y z) (tak87 (- y 1) z x) (tak89 (- z 1) x y))))) - + (declare tak17 (UFix -> UFix -> UFix -> UFix)) (define (tak17 x y z) (cond ((>= y x) z) (True (tak18 (tak66 (- x 1) y z) (tak98 (- y 1) z x) (tak6 (- z 1) x y))))) - + (declare tak18 (UFix -> UFix -> UFix -> UFix)) (define (tak18 x y z) (cond ((>= y x) z) (True (tak19 (tak3 (- x 1) y z) (tak9 (- y 1) z x) (tak23 (- z 1) x y))))) - + (declare tak19 (UFix -> UFix -> UFix -> UFix)) (define (tak19 x y z) (cond ((>= y x) z) (True (tak20 (tak40 (- x 1) y z) (tak20 (- y 1) z x) (tak40 (- z 1) x y))))) - + (declare tak20 (UFix -> UFix -> UFix -> UFix)) (define (tak20 x y z) (cond ((>= y x) z) (True (tak21 (tak77 (- x 1) y z) (tak31 (- y 1) z x) (tak57 (- z 1) x y))))) - + (declare tak21 (UFix -> UFix -> UFix -> UFix)) (define (tak21 x y z) (cond ((>= y x) z) (True (tak22 (tak14 (- x 1) y z) (tak42 (- y 1) z x) (tak74 (- z 1) x y))))) - + (declare tak22 (UFix -> UFix -> UFix -> UFix)) (define (tak22 x y z) (cond ((>= y x) z) (True (tak23 (tak51 (- x 1) y z) (tak53 (- y 1) z x) (tak91 (- z 1) x y))))) - + (declare tak23 (UFix -> UFix -> UFix -> UFix)) (define (tak23 x y z) (cond ((>= y x) z) (True (tak24 (tak88 (- x 1) y z) (tak64 (- y 1) z x) (tak8 (- z 1) x y))))) - + (declare tak24 (UFix -> UFix -> UFix -> UFix)) (define (tak24 x y z) (cond ((>= y x) z) (True (tak25 (tak25 (- x 1) y z) (tak75 (- y 1) z x) (tak25 (- z 1) x y))))) - + (declare tak25 (UFix -> UFix -> UFix -> UFix)) (define (tak25 x y z) (cond ((>= y x) z) (True (tak26 (tak62 (- x 1) y z) (tak86 (- y 1) z x) (tak42 (- z 1) x y))))) - + (declare tak26 (UFix -> UFix -> UFix -> UFix)) (define (tak26 x y z) (cond ((>= y x) z) (True (tak27 (tak99 (- x 1) y z) (tak97 (- y 1) z x) (tak59 (- z 1) x y))))) - + (declare tak27 (UFix -> UFix -> UFix -> UFix)) (define (tak27 x y z) (cond ((>= y x) z) (True (tak28 (tak36 (- x 1) y z) (tak8 (- y 1) z x) (tak76 (- z 1) x y))))) - + (declare tak28 (UFix -> UFix -> UFix -> UFix)) (define (tak28 x y z) (cond ((>= y x) z) (True (tak29 (tak73 (- x 1) y z) (tak19 (- y 1) z x) (tak93 (- z 1) x y))))) - + (declare tak29 (UFix -> UFix -> UFix -> UFix)) (define (tak29 x y z) (cond ((>= y x) z) (True (tak30 (tak10 (- x 1) y z) (tak30 (- y 1) z x) (tak10 (- z 1) x y))))) - + (declare tak30 (UFix -> UFix -> UFix -> UFix)) (define (tak30 x y z) (cond ((>= y x) z) (True (tak31 (tak47 (- x 1) y z) (tak41 (- y 1) z x) (tak27 (- z 1) x y))))) - + (declare tak31 (UFix -> UFix -> UFix -> UFix)) (define (tak31 x y z) (cond ((>= y x) z) (True (tak32 (tak84 (- x 1) y z) (tak52 (- y 1) z x) (tak44 (- z 1) x y))))) - + (declare tak32 (UFix -> UFix -> UFix -> UFix)) (define (tak32 x y z) (cond ((>= y x) z) (True (tak33 (tak21 (- x 1) y z) (tak63 (- y 1) z x) (tak61 (- z 1) x y))))) - + (declare tak33 (UFix -> UFix -> UFix -> UFix)) (define (tak33 x y z) (cond ((>= y x) z) (True (tak34 (tak58 (- x 1) y z) (tak74 (- y 1) z x) (tak78 (- z 1) x y))))) - + (declare tak34 (UFix -> UFix -> UFix -> UFix)) (define (tak34 x y z) (cond ((>= y x) z) (True (tak35 (tak95 (- x 1) y z) (tak85 (- y 1) z x) (tak95 (- z 1) x y))))) - + (declare tak35 (UFix -> UFix -> UFix -> UFix)) (define (tak35 x y z) (cond ((>= y x) z) (True (tak36 (tak32 (- x 1) y z) (tak96 (- y 1) z x) (tak12 (- z 1) x y))))) - + (declare tak36 (UFix -> UFix -> UFix -> UFix)) (define (tak36 x y z) (cond ((>= y x) z) (True (tak37 (tak69 (- x 1) y z) (tak7 (- y 1) z x) (tak29 (- z 1) x y))))) - + (declare tak37 (UFix -> UFix -> UFix -> UFix)) (define (tak37 x y z) (cond ((>= y x) z) (True (tak38 (tak6 (- x 1) y z) (tak18 (- y 1) z x) (tak46 (- z 1) x y))))) - + (declare tak38 (UFix -> UFix -> UFix -> UFix)) (define (tak38 x y z) (cond ((>= y x) z) (True (tak39 (tak43 (- x 1) y z) (tak29 (- y 1) z x) (tak63 (- z 1) x y))))) - + (declare tak39 (UFix -> UFix -> UFix -> UFix)) (define (tak39 x y z) (cond ((>= y x) z) (True (tak40 (tak80 (- x 1) y z) (tak40 (- y 1) z x) (tak80 (- z 1) x y))))) - + (declare tak40 (UFix -> UFix -> UFix -> UFix)) (define (tak40 x y z) (cond ((>= y x) z) (True (tak41 (tak17 (- x 1) y z) (tak51 (- y 1) z x) (tak97 (- z 1) x y))))) - + (declare tak41 (UFix -> UFix -> UFix -> UFix)) (define (tak41 x y z) (cond ((>= y x) z) (True (tak42 (tak54 (- x 1) y z) (tak62 (- y 1) z x) (tak14 (- z 1) x y))))) - + (declare tak42 (UFix -> UFix -> UFix -> UFix)) (define (tak42 x y z) (cond ((>= y x) z) (True (tak43 (tak91 (- x 1) y z) (tak73 (- y 1) z x) (tak31 (- z 1) x y))))) - + (declare tak43 (UFix -> UFix -> UFix -> UFix)) (define (tak43 x y z) (cond ((>= y x) z) (True (tak44 (tak28 (- x 1) y z) (tak84 (- y 1) z x) (tak48 (- z 1) x y))))) - + (declare tak44 (UFix -> UFix -> UFix -> UFix)) (define (tak44 x y z) (cond ((>= y x) z) (True (tak45 (tak65 (- x 1) y z) (tak95 (- y 1) z x) (tak65 (- z 1) x y))))) - + (declare tak45 (UFix -> UFix -> UFix -> UFix)) (define (tak45 x y z) (cond ((>= y x) z) (True (tak46 (tak2 (- x 1) y z) (tak6 (- y 1) z x) (tak82 (- z 1) x y))))) - + (declare tak46 (UFix -> UFix -> UFix -> UFix)) (define (tak46 x y z) (cond ((>= y x) z) (True (tak47 (tak39 (- x 1) y z) (tak17 (- y 1) z x) (tak99 (- z 1) x y))))) - + (declare tak47 (UFix -> UFix -> UFix -> UFix)) (define (tak47 x y z) (cond ((>= y x) z) (True (tak48 (tak76 (- x 1) y z) (tak28 (- y 1) z x) (tak16 (- z 1) x y))))) - + (declare tak48 (UFix -> UFix -> UFix -> UFix)) (define (tak48 x y z) (cond ((>= y x) z) (True (tak49 (tak13 (- x 1) y z) (tak39 (- y 1) z x) (tak33 (- z 1) x y))))) - + (declare tak49 (UFix -> UFix -> UFix -> UFix)) (define (tak49 x y z) (cond ((>= y x) z) (True (tak50 (tak50 (- x 1) y z) (tak50 (- y 1) z x) (tak50 (- z 1) x y))))) - + (declare tak50 (UFix -> UFix -> UFix -> UFix)) (define (tak50 x y z) (cond ((>= y x) z) (True (tak51 (tak87 (- x 1) y z) (tak61 (- y 1) z x) (tak67 (- z 1) x y))))) - + (declare tak51 (UFix -> UFix -> UFix -> UFix)) (define (tak51 x y z) (cond ((>= y x) z) (True (tak52 (tak24 (- x 1) y z) (tak72 (- y 1) z x) (tak84 (- z 1) x y))))) - + (declare tak52 (UFix -> UFix -> UFix -> UFix)) (define (tak52 x y z) (cond ((>= y x) z) (True (tak53 (tak61 (- x 1) y z) (tak83 (- y 1) z x) (tak1 (- z 1) x y))))) - + (declare tak53 (UFix -> UFix -> UFix -> UFix)) (define (tak53 x y z) (cond ((>= y x) z) (True (tak54 (tak98 (- x 1) y z) (tak94 (- y 1) z x) (tak18 (- z 1) x y))))) - + (declare tak54 (UFix -> UFix -> UFix -> UFix)) (define (tak54 x y z) (cond ((>= y x) z) (True (tak55 (tak35 (- x 1) y z) (tak5 (- y 1) z x) (tak35 (- z 1) x y))))) - + (declare tak55 (UFix -> UFix -> UFix -> UFix)) (define (tak55 x y z) (cond ((>= y x) z) (True (tak56 (tak72 (- x 1) y z) (tak16 (- y 1) z x) (tak52 (- z 1) x y))))) - + (declare tak56 (UFix -> UFix -> UFix -> UFix)) (define (tak56 x y z) (cond ((>= y x) z) (True (tak57 (tak9 (- x 1) y z) (tak27 (- y 1) z x) (tak69 (- z 1) x y))))) - + (declare tak57 (UFix -> UFix -> UFix -> UFix)) (define (tak57 x y z) (cond ((>= y x) z) (True (tak58 (tak46 (- x 1) y z) (tak38 (- y 1) z x) (tak86 (- z 1) x y))))) - + (declare tak58 (UFix -> UFix -> UFix -> UFix)) (define (tak58 x y z) (cond ((>= y x) z) (True (tak59 (tak83 (- x 1) y z) (tak49 (- y 1) z x) (tak3 (- z 1) x y))))) - + (declare tak59 (UFix -> UFix -> UFix -> UFix)) (define (tak59 x y z) (cond ((>= y x) z) (True (tak60 (tak20 (- x 1) y z) (tak60 (- y 1) z x) (tak20 (- z 1) x y))))) - + (declare tak60 (UFix -> UFix -> UFix -> UFix)) (define (tak60 x y z) (cond ((>= y x) z) (True (tak61 (tak57 (- x 1) y z) (tak71 (- y 1) z x) (tak37 (- z 1) x y))))) - + (declare tak61 (UFix -> UFix -> UFix -> UFix)) (define (tak61 x y z) (cond ((>= y x) z) (True (tak62 (tak94 (- x 1) y z) (tak82 (- y 1) z x) (tak54 (- z 1) x y))))) - + (declare tak62 (UFix -> UFix -> UFix -> UFix)) (define (tak62 x y z) (cond ((>= y x) z) (True (tak63 (tak31 (- x 1) y z) (tak93 (- y 1) z x) (tak71 (- z 1) x y))))) - + (declare tak63 (UFix -> UFix -> UFix -> UFix)) (define (tak63 x y z) (cond ((>= y x) z) (True (tak64 (tak68 (- x 1) y z) (tak4 (- y 1) z x) (tak88 (- z 1) x y))))) - + (declare tak64 (UFix -> UFix -> UFix -> UFix)) (define (tak64 x y z) (cond ((>= y x) z) (True (tak65 (tak5 (- x 1) y z) (tak15 (- y 1) z x) (tak5 (- z 1) x y))))) - + (declare tak65 (UFix -> UFix -> UFix -> UFix)) (define (tak65 x y z) (cond ((>= y x) z) (True (tak66 (tak42 (- x 1) y z) (tak26 (- y 1) z x) (tak22 (- z 1) x y))))) - + (declare tak66 (UFix -> UFix -> UFix -> UFix)) (define (tak66 x y z) (cond ((>= y x) z) (True (tak67 (tak79 (- x 1) y z) (tak37 (- y 1) z x) (tak39 (- z 1) x y))))) - + (declare tak67 (UFix -> UFix -> UFix -> UFix)) (define (tak67 x y z) (cond ((>= y x) z) (True (tak68 (tak16 (- x 1) y z) (tak48 (- y 1) z x) (tak56 (- z 1) x y))))) - + (declare tak68 (UFix -> UFix -> UFix -> UFix)) (define (tak68 x y z) (cond ((>= y x) z) (True (tak69 (tak53 (- x 1) y z) (tak59 (- y 1) z x) (tak73 (- z 1) x y))))) - + (declare tak69 (UFix -> UFix -> UFix -> UFix)) (define (tak69 x y z) (cond ((>= y x) z) (True (tak70 (tak90 (- x 1) y z) (tak70 (- y 1) z x) (tak90 (- z 1) x y))))) - + (declare tak70 (UFix -> UFix -> UFix -> UFix)) (define (tak70 x y z) (cond ((>= y x) z) (True (tak71 (tak27 (- x 1) y z) (tak81 (- y 1) z x) (tak7 (- z 1) x y))))) - + (declare tak71 (UFix -> UFix -> UFix -> UFix)) (define (tak71 x y z) (cond ((>= y x) z) (True (tak72 (tak64 (- x 1) y z) (tak92 (- y 1) z x) (tak24 (- z 1) x y))))) - + (declare tak72 (UFix -> UFix -> UFix -> UFix)) (define (tak72 x y z) (cond ((>= y x) z) (True (tak73 (tak1 (- x 1) y z) (tak3 (- y 1) z x) (tak41 (- z 1) x y))))) - + (declare tak73 (UFix -> UFix -> UFix -> UFix)) (define (tak73 x y z) (cond ((>= y x) z) (True (tak74 (tak38 (- x 1) y z) (tak14 (- y 1) z x) (tak58 (- z 1) x y))))) - + (declare tak74 (UFix -> UFix -> UFix -> UFix)) (define (tak74 x y z) (cond ((>= y x) z) (True (tak75 (tak75 (- x 1) y z) (tak25 (- y 1) z x) (tak75 (- z 1) x y))))) - + (declare tak75 (UFix -> UFix -> UFix -> UFix)) (define (tak75 x y z) (cond ((>= y x) z) (True (tak76 (tak12 (- x 1) y z) (tak36 (- y 1) z x) (tak92 (- z 1) x y))))) - + (declare tak76 (UFix -> UFix -> UFix -> UFix)) (define (tak76 x y z) (cond ((>= y x) z) (True (tak77 (tak49 (- x 1) y z) (tak47 (- y 1) z x) (tak9 (- z 1) x y))))) - + (declare tak77 (UFix -> UFix -> UFix -> UFix)) (define (tak77 x y z) (cond ((>= y x) z) (True (tak78 (tak86 (- x 1) y z) (tak58 (- y 1) z x) (tak26 (- z 1) x y))))) - + (declare tak78 (UFix -> UFix -> UFix -> UFix)) (define (tak78 x y z) (cond ((>= y x) z) (True (tak79 (tak23 (- x 1) y z) (tak69 (- y 1) z x) (tak43 (- z 1) x y))))) - + (declare tak79 (UFix -> UFix -> UFix -> UFix)) (define (tak79 x y z) (cond ((>= y x) z) (True (tak80 (tak60 (- x 1) y z) (tak80 (- y 1) z x) (tak60 (- z 1) x y))))) - + (declare tak80 (UFix -> UFix -> UFix -> UFix)) (define (tak80 x y z) (cond ((>= y x) z) (True (tak81 (tak97 (- x 1) y z) (tak91 (- y 1) z x) (tak77 (- z 1) x y))))) - + (declare tak81 (UFix -> UFix -> UFix -> UFix)) (define (tak81 x y z) (cond ((>= y x) z) (True (tak82 (tak34 (- x 1) y z) (tak2 (- y 1) z x) (tak94 (- z 1) x y))))) - + (declare tak82 (UFix -> UFix -> UFix -> UFix)) (define (tak82 x y z) (cond ((>= y x) z) (True (tak83 (tak71 (- x 1) y z) (tak13 (- y 1) z x) (tak11 (- z 1) x y))))) - + (declare tak83 (UFix -> UFix -> UFix -> UFix)) (define (tak83 x y z) (cond ((>= y x) z) (True (tak84 (tak8 (- x 1) y z) (tak24 (- y 1) z x) (tak28 (- z 1) x y))))) - + (declare tak84 (UFix -> UFix -> UFix -> UFix)) (define (tak84 x y z) (cond ((>= y x) z) (True (tak85 (tak45 (- x 1) y z) (tak35 (- y 1) z x) (tak45 (- z 1) x y))))) - + (declare tak85 (UFix -> UFix -> UFix -> UFix)) (define (tak85 x y z) (cond ((>= y x) z) (True (tak86 (tak82 (- x 1) y z) (tak46 (- y 1) z x) (tak62 (- z 1) x y))))) - + (declare tak86 (UFix -> UFix -> UFix -> UFix)) (define (tak86 x y z) (cond ((>= y x) z) (True (tak87 (tak19 (- x 1) y z) (tak57 (- y 1) z x) (tak79 (- z 1) x y))))) - + (declare tak87 (UFix -> UFix -> UFix -> UFix)) (define (tak87 x y z) (cond ((>= y x) z) (True (tak88 (tak56 (- x 1) y z) (tak68 (- y 1) z x) (tak96 (- z 1) x y))))) - + (declare tak88 (UFix -> UFix -> UFix -> UFix)) (define (tak88 x y z) (cond ((>= y x) z) (True (tak89 (tak93 (- x 1) y z) (tak79 (- y 1) z x) (tak13 (- z 1) x y))))) - + (declare tak89 (UFix -> UFix -> UFix -> UFix)) (define (tak89 x y z) (cond ((>= y x) z) (True (tak90 (tak30 (- x 1) y z) (tak90 (- y 1) z x) (tak30 (- z 1) x y))))) - + (declare tak90 (UFix -> UFix -> UFix -> UFix)) (define (tak90 x y z) (cond ((>= y x) z) (True (tak91 (tak67 (- x 1) y z) (tak1 (- y 1) z x) (tak47 (- z 1) x y))))) - + (declare tak91 (UFix -> UFix -> UFix -> UFix)) (define (tak91 x y z) (cond ((>= y x) z) (True (tak92 (tak4 (- x 1) y z) (tak12 (- y 1) z x) (tak64 (- z 1) x y))))) - + (declare tak92 (UFix -> UFix -> UFix -> UFix)) (define (tak92 x y z) (cond ((>= y x) z) (True (tak93 (tak41 (- x 1) y z) (tak23 (- y 1) z x) (tak81 (- z 1) x y))))) - + (declare tak93 (UFix -> UFix -> UFix -> UFix)) (define (tak93 x y z) (cond ((>= y x) z) (True (tak94 (tak78 (- x 1) y z) (tak34 (- y 1) z x) (tak98 (- z 1) x y))))) - + (declare tak94 (UFix -> UFix -> UFix -> UFix)) (define (tak94 x y z) (cond ((>= y x) z) (True (tak95 (tak15 (- x 1) y z) (tak45 (- y 1) z x) (tak15 (- z 1) x y))))) - + (declare tak95 (UFix -> UFix -> UFix -> UFix)) (define (tak95 x y z) (cond ((>= y x) z) (True (tak96 (tak52 (- x 1) y z) (tak56 (- y 1) z x) (tak32 (- z 1) x y))))) - + (declare tak96 (UFix -> UFix -> UFix -> UFix)) (define (tak96 x y z) (cond ((>= y x) z) (True (tak97 (tak89 (- x 1) y z) (tak67 (- y 1) z x) (tak49 (- z 1) x y))))) - + (declare tak97 (UFix -> UFix -> UFix -> UFix)) (define (tak97 x y z) (cond ((>= y x) z) (True (tak98 (tak26 (- x 1) y z) (tak78 (- y 1) z x) (tak66 (- z 1) x y))))) - + (declare tak98 (UFix -> UFix -> UFix -> UFix)) (define (tak98 x y z) (cond ((>= y x) z) (True (tak99 (tak63 (- x 1) y z) (tak89 (- y 1) z x) (tak83 (- z 1) x y))))) - + (declare tak99 (UFix -> UFix -> UFix -> UFix)) (define (tak99 x y z) (cond ((>= y x) z) (True (takr (takr (- x 1) y z) (takr (- y 1) z x) (takr (- z 1) x y)))))) + +;; (cl:in-package #:coalton-benchmarks) + +;; (define-benchmark takr () +;; (declare (optimize speed)) +;; (loop :repeat 1000 +;; :do (with-benchmark-sampling +;; (coalton-benchmarks/native:takr 18 12 6))) +;; (report trivial-benchmark::*current-timer*)) + +;; (define-benchmark takr-lisp () +;; (declare (optimize speed)) +;; (loop :repeat 1000 +;; :do (with-benchmark-sampling +;; (lisp-takr 18 12 6))) +;; (report trivial-benchmark::*current-timer*)) + +;; ;;; +;; ;;; +;; ;;; + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) lisp-takr)) +;; (defun lisp-takr (x y z) +;; (cond ((>= y x) z) +;; (t (tak1 (tak37 (- x 1) y z) +;; (tak11 (- y 1) z x) +;; (tak17 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak1)) +;; (defun tak1 (x y z) +;; (cond ((>= y x) z) +;; (t (tak2 (tak74 (- x 1) y z) +;; (tak22 (- y 1) z x) +;; (tak34 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak2)) +;; (defun tak2 (x y z) +;; (cond ((>= y x) z) +;; (t (tak3 (tak11 (- x 1) y z) +;; (tak33 (- y 1) z x) +;; (tak51 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak3)) +;; (defun tak3 (x y z) +;; (cond ((>= y x) z) +;; (t (tak4 (tak48 (- x 1) y z) +;; (tak44 (- y 1) z x) +;; (tak68 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak4)) +;; (defun tak4 (x y z) +;; (cond ((>= y x) z) +;; (t (tak5 (tak85 (- x 1) y z) +;; (tak55 (- y 1) z x) +;; (tak85 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak5)) +;; (defun tak5 (x y z) +;; (cond ((>= y x) z) +;; (t (tak6 (tak22 (- x 1) y z) +;; (tak66 (- y 1) z x) +;; (tak2 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak6)) +;; (defun tak6 (x y z) +;; (cond ((>= y x) z) +;; (t (tak7 (tak59 (- x 1) y z) +;; (tak77 (- y 1) z x) +;; (tak19 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak7)) +;; (defun tak7 (x y z) +;; (cond ((>= y x) z) +;; (t (tak8 (tak96 (- x 1) y z) +;; (tak88 (- y 1) z x) +;; (tak36 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak8)) +;; (defun tak8 (x y z) +;; (cond ((>= y x) z) +;; (t (tak9 (tak33 (- x 1) y z) +;; (tak99 (- y 1) z x) +;; (tak53 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak9)) +;; (defun tak9 (x y z) +;; (cond ((>= y x) z) +;; (t (tak10 (tak70 (- x 1) y z) +;; (tak10 (- y 1) z x) +;; (tak70 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak10)) +;; (defun tak10 (x y z) +;; (cond ((>= y x) z) +;; (t (tak11 (tak7 (- x 1) y z) +;; (tak21 (- y 1) z x) +;; (tak87 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak11)) +;; (defun tak11 (x y z) +;; (cond ((>= y x) z) +;; (t (tak12 (tak44 (- x 1) y z) +;; (tak32 (- y 1) z x) +;; (tak4 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak12)) +;; (defun tak12 (x y z) +;; (cond ((>= y x) z) +;; (t (tak13 (tak81 (- x 1) y z) +;; (tak43 (- y 1) z x) +;; (tak21 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak13)) +;; (defun tak13 (x y z) +;; (cond ((>= y x) z) +;; (t (tak14 (tak18 (- x 1) y z) +;; (tak54 (- y 1) z x) +;; (tak38 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak14)) +;; (defun tak14 (x y z) +;; (cond ((>= y x) z) +;; (t (tak15 (tak55 (- x 1) y z) +;; (tak65 (- y 1) z x) +;; (tak55 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak15)) +;; (defun tak15 (x y z) +;; (cond ((>= y x) z) +;; (t (tak16 (tak92 (- x 1) y z) +;; (tak76 (- y 1) z x) +;; (tak72 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak16)) +;; (defun tak16 (x y z) +;; (cond ((>= y x) z) +;; (t (tak17 (tak29 (- x 1) y z) +;; (tak87 (- y 1) z x) +;; (tak89 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak17)) +;; (defun tak17 (x y z) +;; (cond ((>= y x) z) +;; (t (tak18 (tak66 (- x 1) y z) +;; (tak98 (- y 1) z x) +;; (tak6 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak18)) +;; (defun tak18 (x y z) +;; (cond ((>= y x) z) +;; (t (tak19 (tak3 (- x 1) y z) +;; (tak9 (- y 1) z x) +;; (tak23 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak19)) +;; (defun tak19 (x y z) +;; (cond ((>= y x) z) +;; (t (tak20 (tak40 (- x 1) y z) +;; (tak20 (- y 1) z x) +;; (tak40 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak20)) +;; (defun tak20 (x y z) +;; (cond ((>= y x) z) +;; (t (tak21 (tak77 (- x 1) y z) +;; (tak31 (- y 1) z x) +;; (tak57 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak21)) +;; (defun tak21 (x y z) +;; (cond ((>= y x) z) +;; (t (tak22 (tak14 (- x 1) y z) +;; (tak42 (- y 1) z x) +;; (tak74 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak22)) +;; (defun tak22 (x y z) +;; (cond ((>= y x) z) +;; (t (tak23 (tak51 (- x 1) y z) +;; (tak53 (- y 1) z x) +;; (tak91 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak23)) +;; (defun tak23 (x y z) +;; (cond ((>= y x) z) +;; (t (tak24 (tak88 (- x 1) y z) +;; (tak64 (- y 1) z x) +;; (tak8 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak24)) +;; (defun tak24 (x y z) +;; (cond ((>= y x) z) +;; (t (tak25 (tak25 (- x 1) y z) +;; (tak75 (- y 1) z x) +;; (tak25 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak25)) +;; (defun tak25 (x y z) +;; (cond ((>= y x) z) +;; (t (tak26 (tak62 (- x 1) y z) +;; (tak86 (- y 1) z x) +;; (tak42 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak26)) +;; (defun tak26 (x y z) +;; (cond ((>= y x) z) +;; (t (tak27 (tak99 (- x 1) y z) +;; (tak97 (- y 1) z x) +;; (tak59 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak27)) +;; (defun tak27 (x y z) +;; (cond ((>= y x) z) +;; (t (tak28 (tak36 (- x 1) y z) +;; (tak8 (- y 1) z x) +;; (tak76 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak28)) +;; (defun tak28 (x y z) +;; (cond ((>= y x) z) +;; (t (tak29 (tak73 (- x 1) y z) +;; (tak19 (- y 1) z x) +;; (tak93 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak29)) +;; (defun tak29 (x y z) +;; (cond ((>= y x) z) +;; (t (tak30 (tak10 (- x 1) y z) +;; (tak30 (- y 1) z x) +;; (tak10 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak30)) +;; (defun tak30 (x y z) +;; (cond ((>= y x) z) +;; (t (tak31 (tak47 (- x 1) y z) +;; (tak41 (- y 1) z x) +;; (tak27 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak31)) +;; (defun tak31 (x y z) +;; (cond ((>= y x) z) +;; (t (tak32 (tak84 (- x 1) y z) +;; (tak52 (- y 1) z x) +;; (tak44 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak32)) +;; (defun tak32 (x y z) +;; (cond ((>= y x) z) +;; (t (tak33 (tak21 (- x 1) y z) +;; (tak63 (- y 1) z x) +;; (tak61 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak33)) +;; (defun tak33 (x y z) +;; (cond ((>= y x) z) +;; (t (tak34 (tak58 (- x 1) y z) +;; (tak74 (- y 1) z x) +;; (tak78 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak34)) +;; (defun tak34 (x y z) +;; (cond ((>= y x) z) +;; (t (tak35 (tak95 (- x 1) y z) +;; (tak85 (- y 1) z x) +;; (tak95 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak35)) +;; (defun tak35 (x y z) +;; (cond ((>= y x) z) +;; (t (tak36 (tak32 (- x 1) y z) +;; (tak96 (- y 1) z x) +;; (tak12 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak36)) +;; (defun tak36 (x y z) +;; (cond ((>= y x) z) +;; (t (tak37 (tak69 (- x 1) y z) +;; (tak7 (- y 1) z x) +;; (tak29 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak37)) +;; (defun tak37 (x y z) +;; (cond ((>= y x) z) +;; (t (tak38 (tak6 (- x 1) y z) +;; (tak18 (- y 1) z x) +;; (tak46 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak38)) +;; (defun tak38 (x y z) +;; (cond ((>= y x) z) +;; (t (tak39 (tak43 (- x 1) y z) +;; (tak29 (- y 1) z x) +;; (tak63 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak39)) +;; (defun tak39 (x y z) +;; (cond ((>= y x) z) +;; (t (tak40 (tak80 (- x 1) y z) +;; (tak40 (- y 1) z x) +;; (tak80 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak40)) +;; (defun tak40 (x y z) +;; (cond ((>= y x) z) +;; (t (tak41 (tak17 (- x 1) y z) +;; (tak51 (- y 1) z x) +;; (tak97 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak41)) +;; (defun tak41 (x y z) +;; (cond ((>= y x) z) +;; (t (tak42 (tak54 (- x 1) y z) +;; (tak62 (- y 1) z x) +;; (tak14 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak42)) +;; (defun tak42 (x y z) +;; (cond ((>= y x) z) +;; (t (tak43 (tak91 (- x 1) y z) +;; (tak73 (- y 1) z x) +;; (tak31 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak43)) +;; (defun tak43 (x y z) +;; (cond ((>= y x) z) +;; (t (tak44 (tak28 (- x 1) y z) +;; (tak84 (- y 1) z x) +;; (tak48 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak44)) +;; (defun tak44 (x y z) +;; (cond ((>= y x) z) +;; (t (tak45 (tak65 (- x 1) y z) +;; (tak95 (- y 1) z x) +;; (tak65 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak45)) +;; (defun tak45 (x y z) +;; (cond ((>= y x) z) +;; (t (tak46 (tak2 (- x 1) y z) +;; (tak6 (- y 1) z x) +;; (tak82 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak46)) +;; (defun tak46 (x y z) +;; (cond ((>= y x) z) +;; (t (tak47 (tak39 (- x 1) y z) +;; (tak17 (- y 1) z x) +;; (tak99 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak47)) +;; (defun tak47 (x y z) +;; (cond ((>= y x) z) +;; (t (tak48 (tak76 (- x 1) y z) +;; (tak28 (- y 1) z x) +;; (tak16 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak48)) +;; (defun tak48 (x y z) +;; (cond ((>= y x) z) +;; (t (tak49 (tak13 (- x 1) y z) +;; (tak39 (- y 1) z x) +;; (tak33 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak49)) +;; (defun tak49 (x y z) +;; (cond ((>= y x) z) +;; (t (tak50 (tak50 (- x 1) y z) +;; (tak50 (- y 1) z x) +;; (tak50 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak50)) +;; (defun tak50 (x y z) +;; (cond ((>= y x) z) +;; (t (tak51 (tak87 (- x 1) y z) +;; (tak61 (- y 1) z x) +;; (tak67 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak51)) +;; (defun tak51 (x y z) +;; (cond ((>= y x) z) +;; (t (tak52 (tak24 (- x 1) y z) +;; (tak72 (- y 1) z x) +;; (tak84 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak52)) +;; (defun tak52 (x y z) +;; (cond ((>= y x) z) +;; (t (tak53 (tak61 (- x 1) y z) +;; (tak83 (- y 1) z x) +;; (tak1 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak53)) +;; (defun tak53 (x y z) +;; (cond ((>= y x) z) +;; (t (tak54 (tak98 (- x 1) y z) +;; (tak94 (- y 1) z x) +;; (tak18 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak54)) +;; (defun tak54 (x y z) +;; (cond ((>= y x) z) +;; (t (tak55 (tak35 (- x 1) y z) +;; (tak5 (- y 1) z x) +;; (tak35 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak55)) +;; (defun tak55 (x y z) +;; (cond ((>= y x) z) +;; (t (tak56 (tak72 (- x 1) y z) +;; (tak16 (- y 1) z x) +;; (tak52 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak56)) +;; (defun tak56 (x y z) +;; (cond ((>= y x) z) +;; (t (tak57 (tak9 (- x 1) y z) +;; (tak27 (- y 1) z x) +;; (tak69 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak57)) +;; (defun tak57 (x y z) +;; (cond ((>= y x) z) +;; (t (tak58 (tak46 (- x 1) y z) +;; (tak38 (- y 1) z x) +;; (tak86 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak58)) +;; (defun tak58 (x y z) +;; (cond ((>= y x) z) +;; (t (tak59 (tak83 (- x 1) y z) +;; (tak49 (- y 1) z x) +;; (tak3 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak59)) +;; (defun tak59 (x y z) +;; (cond ((>= y x) z) +;; (t (tak60 (tak20 (- x 1) y z) +;; (tak60 (- y 1) z x) +;; (tak20 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak60)) +;; (defun tak60 (x y z) +;; (cond ((>= y x) z) +;; (t (tak61 (tak57 (- x 1) y z) +;; (tak71 (- y 1) z x) +;; (tak37 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak61)) +;; (defun tak61 (x y z) +;; (cond ((>= y x) z) +;; (t (tak62 (tak94 (- x 1) y z) +;; (tak82 (- y 1) z x) +;; (tak54 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak62)) +;; (defun tak62 (x y z) +;; (cond ((>= y x) z) +;; (t (tak63 (tak31 (- x 1) y z) +;; (tak93 (- y 1) z x) +;; (tak71 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak63)) +;; (defun tak63 (x y z) +;; (cond ((>= y x) z) +;; (t (tak64 (tak68 (- x 1) y z) +;; (tak4 (- y 1) z x) +;; (tak88 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak64)) +;; (defun tak64 (x y z) +;; (cond ((>= y x) z) +;; (t (tak65 (tak5 (- x 1) y z) +;; (tak15 (- y 1) z x) +;; (tak5 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak65)) +;; (defun tak65 (x y z) +;; (cond ((>= y x) z) +;; (t (tak66 (tak42 (- x 1) y z) +;; (tak26 (- y 1) z x) +;; (tak22 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak66)) +;; (defun tak66 (x y z) +;; (cond ((>= y x) z) +;; (t (tak67 (tak79 (- x 1) y z) +;; (tak37 (- y 1) z x) +;; (tak39 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak67)) +;; (defun tak67 (x y z) +;; (cond ((>= y x) z) +;; (t (tak68 (tak16 (- x 1) y z) +;; (tak48 (- y 1) z x) +;; (tak56 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak68)) +;; (defun tak68 (x y z) +;; (cond ((>= y x) z) +;; (t (tak69 (tak53 (- x 1) y z) +;; (tak59 (- y 1) z x) +;; (tak73 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak69)) +;; (defun tak69 (x y z) +;; (cond ((>= y x) z) +;; (t (tak70 (tak90 (- x 1) y z) +;; (tak70 (- y 1) z x) +;; (tak90 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak70)) +;; (defun tak70 (x y z) +;; (cond ((>= y x) z) +;; (t (tak71 (tak27 (- x 1) y z) +;; (tak81 (- y 1) z x) +;; (tak7 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak71)) +;; (defun tak71 (x y z) +;; (cond ((>= y x) z) +;; (t (tak72 (tak64 (- x 1) y z) +;; (tak92 (- y 1) z x) +;; (tak24 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak72)) +;; (defun tak72 (x y z) +;; (cond ((>= y x) z) +;; (t (tak73 (tak1 (- x 1) y z) +;; (tak3 (- y 1) z x) +;; (tak41 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak73)) +;; (defun tak73 (x y z) +;; (cond ((>= y x) z) +;; (t (tak74 (tak38 (- x 1) y z) +;; (tak14 (- y 1) z x) +;; (tak58 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak74)) +;; (defun tak74 (x y z) +;; (cond ((>= y x) z) +;; (t (tak75 (tak75 (- x 1) y z) +;; (tak25 (- y 1) z x) +;; (tak75 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak75)) +;; (defun tak75 (x y z) +;; (cond ((>= y x) z) +;; (t (tak76 (tak12 (- x 1) y z) +;; (tak36 (- y 1) z x) +;; (tak92 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak76)) +;; (defun tak76 (x y z) +;; (cond ((>= y x) z) +;; (t (tak77 (tak49 (- x 1) y z) +;; (tak47 (- y 1) z x) +;; (tak9 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak77)) +;; (defun tak77 (x y z) +;; (cond ((>= y x) z) +;; (t (tak78 (tak86 (- x 1) y z) +;; (tak58 (- y 1) z x) +;; (tak26 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak78)) +;; (defun tak78 (x y z) +;; (cond ((>= y x) z) +;; (t (tak79 (tak23 (- x 1) y z) +;; (tak69 (- y 1) z x) +;; (tak43 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak79)) +;; (defun tak79 (x y z) +;; (cond ((>= y x) z) +;; (t (tak80 (tak60 (- x 1) y z) +;; (tak80 (- y 1) z x) +;; (tak60 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak80)) +;; (defun tak80 (x y z) +;; (cond ((>= y x) z) +;; (t (tak81 (tak97 (- x 1) y z) +;; (tak91 (- y 1) z x) +;; (tak77 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak81)) +;; (defun tak81 (x y z) +;; (cond ((>= y x) z) +;; (t (tak82 (tak34 (- x 1) y z) +;; (tak2 (- y 1) z x) +;; (tak94 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak82)) +;; (defun tak82 (x y z) +;; (cond ((>= y x) z) +;; (t (tak83 (tak71 (- x 1) y z) +;; (tak13 (- y 1) z x) +;; (tak11 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak83)) +;; (defun tak83 (x y z) +;; (cond ((>= y x) z) +;; (t (tak84 (tak8 (- x 1) y z) +;; (tak24 (- y 1) z x) +;; (tak28 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak84)) +;; (defun tak84 (x y z) +;; (cond ((>= y x) z) +;; (t (tak85 (tak45 (- x 1) y z) +;; (tak35 (- y 1) z x) +;; (tak45 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak85)) +;; (defun tak85 (x y z) +;; (cond ((>= y x) z) +;; (t (tak86 (tak82 (- x 1) y z) +;; (tak46 (- y 1) z x) +;; (tak62 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak86)) +;; (defun tak86 (x y z) +;; (cond ((>= y x) z) +;; (t (tak87 (tak19 (- x 1) y z) +;; (tak57 (- y 1) z x) +;; (tak79 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak87)) +;; (defun tak87 (x y z) +;; (cond ((>= y x) z) +;; (t (tak88 (tak56 (- x 1) y z) +;; (tak68 (- y 1) z x) +;; (tak96 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak88)) +;; (defun tak88 (x y z) +;; (cond ((>= y x) z) +;; (t (tak89 (tak93 (- x 1) y z) +;; (tak79 (- y 1) z x) +;; (tak13 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak89)) +;; (defun tak89 (x y z) +;; (cond ((>= y x) z) +;; (t (tak90 (tak30 (- x 1) y z) +;; (tak90 (- y 1) z x) +;; (tak30 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak91)) +;; (defun tak90 (x y z) +;; (cond ((>= y x) z) +;; (t (tak91 (tak67 (- x 1) y z) +;; (tak1 (- y 1) z x) +;; (tak47 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak92)) +;; (defun tak91 (x y z) +;; (cond ((>= y x) z) +;; (t (tak92 (tak4 (- x 1) y z) +;; (tak12 (- y 1) z x) +;; (tak64 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak93)) +;; (defun tak92 (x y z) +;; (cond ((>= y x) z) +;; (t (tak93 (tak41 (- x 1) y z) +;; (tak23 (- y 1) z x) +;; (tak81 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak94)) +;; (defun tak93 (x y z) +;; (cond ((>= y x) z) +;; (t (tak94 (tak78 (- x 1) y z) +;; (tak34 (- y 1) z x) +;; (tak98 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak95)) +;; (defun tak94 (x y z) +;; (cond ((>= y x) z) +;; (t (tak95 (tak15 (- x 1) y z) +;; (tak45 (- y 1) z x) +;; (tak15 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak96)) +;; (defun tak95 (x y z) +;; (cond ((>= y x) z) +;; (t (tak96 (tak52 (- x 1) y z) +;; (tak56 (- y 1) z x) +;; (tak32 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak96)) +;; (defun tak96 (x y z) +;; (cond ((>= y x) z) +;; (t (tak97 (tak89 (- x 1) y z) +;; (tak67 (- y 1) z x) +;; (tak49 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak97)) +;; (defun tak97 (x y z) +;; (cond ((>= y x) z) +;; (t (tak98 (tak26 (- x 1) y z) +;; (tak78 (- y 1) z x) +;; (tak66 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak98)) +;; (defun tak98 (x y z) +;; (cond ((>= y x) z) +;; (t (tak99 (tak63 (- x 1) y z) +;; (tak89 (- y 1) z x) +;; (tak83 (- z 1) x y))))) + +;; (declaim (ftype (function (fixnum fixnum fixnum) fixnum) tak99)) +;; (defun tak99 (x y z) +;; (cond ((>= y x) z) +;; (t (lisp-takr (lisp-takr (- x 1) y z) +;; (lisp-takr (- y 1) z x) +;; (lisp-takr (- z 1) x y))))) + +;;; +;;; +;;; diff --git a/benchmarks/package.lisp b/benchmarks/package.lisp index 6e3ee4b8c..8df5255ba 100644 --- a/benchmarks/package.lisp +++ b/benchmarks/package.lisp @@ -2,46 +2,53 @@ ;;;; ;;;; Benchmarks packages and common functions -(benchmark:define-benchmark-package #:coalton-benchmarks - (:export #:run-benchmarks - #:run-benchmarks-ci)) +(uiop:define-package #:coalton/benchmarks + (:mix-reexport + #:coalton/benchmarks/fibonacci + #:coalton/benchmarks/big-float + #:coalton/benchmarks/gabriel + #:coalton/benchmarks/benchmarks-game)) -(cl:defpackage #:coalton-benchmarks/native - (:use - #:coalton - #:coalton-prelude - #:coalton-library/big-float - #:coalton-library/math) - (:local-nicknames (#:list #:coalton-library/list)) - (:export - #:fib - #:fib-fixnum - #:fib-generic-wrapped - #:fib-monomorphized - #:fib-generic-optional - #:fib-monomorphized-optional) +;; (benchmark:define-benchmark-package #:coalton-benchmarks +;; (:export #:run-benchmarks +;; #:run-benchmarks-ci)) - ;; gabriel-benchmarks/ - (:export - #:tak - #:stak - #:takl - #:takr)) +;; (cl:defpackage #:coalton-benchmarks/native +;; (:use +;; #:coalton +;; #:coalton-prelude +;; #:coalton-library/big-float +;; #:coalton-library/math) +;; (:local-nicknames (#:list #:coalton-library/list)) +;; (:export +;; #:fib +;; #:fib-fixnum +;; #:fib-generic-wrapped +;; #:fib-monomorphized +;; #:fib-generic-optional +;; #:fib-monomorphized-optional) -(cl:in-package #:coalton-benchmarks) +;; ;; gabriel-benchmarks/ +;; (:export +;; #:tak +;; #:stak +;; #:takl +;; #:takr)) -(defun run-benchmarks () - (run-package-benchmarks :package '#:coalton-benchmarks :verbose t)) +;; (cl:in-package #:coalton-benchmarks) -(defun run-benchmarks-ci () - (let ((result (run-package-benchmarks :package '#:coalton-benchmarks :verbose t))) - (with-open-file (out "bench.json" :direction :output :if-exists :supersede) - (yason:encode - (loop :for name :being :the :hash-keys :of result - :for data :being :the :hash-values :of result - :for real-time := (cdar data) - :for value := (coerce (cdr (find :total (alexandria:plist-alist real-time) :key #'car)) 'double-float) - :collect (alexandria:plist-hash-table (list "name" (symbol-name name) "value" value "unit" "seconds"))) - out) - (format out "~%")) - (values))) +;; (defun run-benchmarks () +;; (run-package-benchmarks :package '#:coalton-benchmarks :verbose t)) + +;; (defun run-benchmarks-ci () +;; (let ((result (run-package-benchmarks :package '#:coalton-benchmarks :verbose t))) +;; (with-open-file (out "bench.json" :direction :output :if-exists :supersede) +;; (yason:encode +;; (loop :for name :being :the :hash-keys :of result +;; :for data :being :the :hash-values :of result +;; :for real-time := (cdar data) +;; :for value := (coerce (cdr (find :total (alexandria:plist-alist real-time) :key #'car)) 'double-float) +;; :collect (alexandria:plist-hash-table (list "name" (symbol-name name) "value" value "unit" "seconds"))) +;; out) +;; (format out "~%")) +;; (values))) diff --git a/coalton.asd b/coalton.asd index 4c9bb7816..833efca46 100644 --- a/coalton.asd +++ b/coalton.asd @@ -143,20 +143,24 @@ (funcall compile))) :depends-on (#:coalton - #:coalton/library/big-float - #:trivial-benchmark - #:yason) + #:coalton/library/big-float) :pathname "benchmarks" :serial t - :components ((:file "package") - (:file "fibonacci") + :components ((:file "fibonacci") (:file "big-float") + (:module "benchmarks-game" + :serial t + :components ((:file "mandelbrot") + (:file "too-simple") + (:file "package"))) (:module "gabriel-benchmarks" :serial t :components ((:file "tak") (:file "stak") (:file "takl") - (:file "takr"))))) + (:file "takr") + (:file "package"))) + (:file "package"))) ;;; we need to inspect the sbcl version in order to decide which version of the hashtable shim to load, ;;; because 2.1.12 includes (or will include) a bugfix that allows a cleaner, more maintainable From f90c0af1b0c1c9fdbb864ee5767b41c8e3dfccfa Mon Sep 17 00:00:00 2001 From: Izaak Walton Date: Wed, 21 Aug 2024 22:15:00 -0700 Subject: [PATCH 2/2] Adding faster brainfold implementations --- .../src/fast-brainfold.lisp | 285 ++++++++++++++++++ .../src/faster-brainfold.lisp | 161 ++++++++++ 2 files changed, 446 insertions(+) create mode 100644 examples/small-coalton-programs/src/fast-brainfold.lisp create mode 100644 examples/small-coalton-programs/src/faster-brainfold.lisp diff --git a/examples/small-coalton-programs/src/fast-brainfold.lisp b/examples/small-coalton-programs/src/fast-brainfold.lisp new file mode 100644 index 000000000..f9f83a41e --- /dev/null +++ b/examples/small-coalton-programs/src/fast-brainfold.lisp @@ -0,0 +1,285 @@ +;;;; +;;;; A Brainfold/Brainf*** interpreter implemented in Coalton +;;;; +;;;; This interpreter handles all standard bf commands: +;;;; ( > < + - . , [ ] ). +;;;; +;;;; +;;;; Run Brainfold programs with (run-program "+++++[-]+++") +;;;; +;;;; or +;;;; +;;;; (run-file "/path/to/your/file.bf") +;;;; +;;;; try (coalton (hello-world)) in the REPL! +;;;; + +(cl:defpackage #:brainfold + (:use + #:coalton + #:coalton-prelude) + (:local-nicknames + (#:vec #:coalton-library/vector) + (#:iter #:coalton-library/iterator) + (#:cell #:coalton-library/cell) + (#:char #:coalton-library/char) + (#:str #:coalton-library/string) + (#:list #:coalton-library/list) + (#:arith #:coalton-library/math) + (#:state #:coalton-library/monad/state) + (#:file #:coalton-library/file)) + (:export + #:eval + #:run-program + #:run-file + + ;; Examples + #:hello-world + #:gnarly-hello-world + #:squares)) + +(in-package #:brainfold) + +(named-readtables:in-readtable coalton:coalton) + +(cl:declaim (cl:optimize (cl:speed 3))) +;;; +;;; State/Env +;;; + +(coalton-toplevel + + (define-struct BF-State + (memory "The brainfold memory array." (Vector Integer)) + (pointer "A pointer to the current register." (Cell UFix))) + + ;; + ;; Generating a Brainfold memory vector + ;; + + (declare bf-vector-size UFix) + (define bf-vector-size 1000) + + ;; + ;; Generating a default BF-State: + ;; + + (define-instance (Default BF-State) + (define (default) + (BF-State (vec:with-initial-element bf-vector-size 0) + (cell:new 0)))) + + ;; + ;; Accessing the current value + ;; + + (declare value-at-pointer (BF-State -> Integer)) + (define (value-at-pointer bfs) + "Returns the value at the current pointer." + (vec:index-unsafe (cell:read (.pointer bfs)) + (.memory bfs)))) + +;;; +;;; Commands (Functions called by Brainfold Cmds) +;;; + +(coalton-toplevel + + ;; + ;; Navigating through bf-cells (> <) + ;; + + (declare move-right (BF-State -> Unit)) + (define (move-right state) + "Moves the pointer one bf-cell to the right." + (cell:increment! (.pointer state)) + Unit) + + (declare move-left (BF-State -> Unit)) + (define (move-left state) + "Moves the pointer one bf-cell to the left." + (cell:decrement! (.pointer state)) + Unit) + + ;; + ;; Changing bf-cell values (+ -) + ;; + + (declare incr (BF-State -> Unit)) + (define (incr state) + "Increments the value for the current bf-cell." + (vec:set! (cell:read (.pointer state)) + (1+ (value-at-pointer state)) + (.memory state)) + Unit) + + (declare decr (BF-State -> Unit)) + (define (decr state) + "Decrements the value for the current bf-cell." + (vec:set! (cell:read (.pointer state)) + (1- (value-at-pointer state)) + (.memory state)) + Unit) + + ;; + ;; Printing Cells (.) + ;; + + (declare display (BF-State -> Unit)) + (define (display state) + "Prints the value at the pointer to the print buffer." + (let val = (value-at-pointer state)) + (lisp Unit (val) + (cl:format cl:*standard-output* "~a" (cl:code-char val)) + Unit)) + + ;; + ;; Taking Input (,) + ;; + ;; Currently takes individual characters one at a time as prompted + + (define (prompt-char) + "A prompt for obtaining one character as input." + (Lisp Char () + (cl:format cl:*query-io* "Input a character: ") + (cl:finish-output cl:*query-io*) + (cl:read-char cl:*query-io*))) + + (declare take-input (BF-State -> Unit)) + (define (take-input state) + "Takes and stores a character as an ascii code at the pointer." + (vec:set! (cell:read (.pointer state)) + (into (char:char-code (prompt-char))) + (.memory state)))) + +;;; +;;; Parsing/Lexing +;;; + +(coalton-toplevel + + (define-type Cmd + BFRight + BFLeft + BFPlus + BFMinus + BFPrint + BFInput + (BFLoop (Vector Cmd))) + + (declare parse (String -> (Vector Cmd))) + (define (parse input-string) + "Parses a Brainfold instruction string, returns a Vector of Brainfold Commands." + (let cmds = (vec:new)) + (let vecs = (vec:new)) + ;(let counter = (cell:new 0)) + (let ((parser (fn (input-string v) + ;; (traceobject "cmd#" (cell:read counter)) + ;; (cell:increment! counter!) + (let ((head-tail (str:split 1 input-string))) + (match (fst head-tail) + ("" cmds) + (">" + (vec:push! BFRight v) + (parser (snd head-tail) v)) + ("<" + (vec:push! BFLeft v) + (parser (snd head-tail) v)) + ("+" + (vec:push! BFPlus v) + (parser (snd head-tail) v)) + ("-" + (vec:push! BFMinus v) + (parser (snd head-tail) v)) + ("." + (vec:push! BFPrint v) + (parser (snd head-tail) v)) + ("," + (vec:push! BFInput v) + (parser (snd head-tail) v)) + ("[" + (vec:push! v vecs) + (parser (snd head-tail) (vec:new))) + ("]" + (vec:push! (BFLoop v) (unwrap (vec:last vecs))) + (parser (snd head-tail) (unwrap (vec:pop! vecs)))) + (_ (parser (snd head-tail) v))))))) + (parser input-string cmds)))) + +;;; +;;; Evaluation +;;; + +(coalton-toplevel + + (declare exec (BF-State -> Cmd -> Unit)) + (define (exec state cmd) + "Executes a given bf command." + ;;(traceobject "pos, current-val" (Tuple (cell:read (.pointer state)) (value-at-pointer state))) + (match cmd + ((BFRight) (move-right state)) + ((BFLeft) (move-left state)) + ((BFPlus) (incr state)) + ((BFMinus) (decr state)) + ((BFPRint) (display state)) + ((BFInput) (take-input state)) + ((BFLoop v) (exec-loop state v)))) + + + (declare exec-cmds (BF-State -> (Vector Cmd) -> Unit)) + (define (exec-cmds state cmds) + "Executes a list of bf-commands." + (for cmd in cmds + (exec state cmd))) + + (declare exec-loop (BF-State -> (Vector Cmd) -> Unit)) + (define (exec-loop state cmds) + "Executes a list of commands until the value at the pointer is 0." + (match (value-at-pointer state) + (0 Unit) + (_ (exec-cmds state cmds) + (exec-loop state cmds)))) + + (declare eval (String -> Unit)) + (define (eval input-string) + "Parses and evaluates a string of brainfold input." + (exec-cmds (default) (into (parse input-string))))) + + +;;; +;;; Top Level +;;; + +(coalton-toplevel + + (declare run-program (String -> Unit)) + (define (run-program bf-string) + "Evaluates and executes a bf-command string on a fresh state." + (eval bf-string)) + + (define (run-file filepath) + "Loads and executes the brainfold file at the given filepath." + ;;(run-program (unwrap (file:read-file-to-string filepath))) + (eval (unwrap (file:read-file-to-string filepath))))) + + +;;; +;;; Sample test programs +;;; + +(coalton-toplevel + + ;; from https://esolangs.org/wiki/Brainfuck + + (define (hello-world) + (run-program + "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.")) + + (define (gnarly-hello-world) + (run-program + ">++++++++[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]>-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------.>>.+++.------.--------.>+.")) + + ;; from https://github.com/saulpw/brainfuck/tree/master/tests + + (define (squares) + (run-program "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]"))) diff --git a/examples/small-coalton-programs/src/faster-brainfold.lisp b/examples/small-coalton-programs/src/faster-brainfold.lisp new file mode 100644 index 000000000..8fe1c2454 --- /dev/null +++ b/examples/small-coalton-programs/src/faster-brainfold.lisp @@ -0,0 +1,161 @@ +;;;; +;;;; A Brainfold/Brainf*** interpreter implemented in Coalton +;;;; +;;;; This interpreter handles all standard bf commands: +;;;; ( > < + - . , [ ] ). +;;;; +;;;; +;;;; Run Brainfold programs with (run-program "+++++[-]+++") +;;;; +;;;; or +;;;; +;;;; (run-file "/path/to/your/file.bf") +;;;; +;;;; try (coalton (hello-world)) in the REPL! +;;;; + +(cl:require :sb-sprof) + +(cl:setf coalton-impl/settings:*coalton-heuristic-inlining* cl:t) + +(cl:defpackage #:brainfold + (:use + #:coalton + #:coalton-prelude) + (:local-nicknames + (#:vec #:coalton-library/vector) + (#:iter #:coalton-library/iterator) + (#:cell #:coalton-library/cell) + (#:char #:coalton-library/char) + (#:str #:coalton-library/string) + (#:list #:coalton-library/list) + (#:arith #:coalton-library/math) + (#:state #:coalton-library/monad/state) + (#:file #:coalton-library/file)) + (:export + #:eval + #:run-program + #:run-file + + ;; Examples + #:hello-world + #:gnarly-hello-world + #:squares)) + +(in-package #:brainfold) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare current-cell ((Vector Integer) -> UFix -> Integer)) + (define (current-cell tape pos) + "Returns the value at the current cell." + (vec:index-unsafe pos tape)) + + (declare incr ((Vector Integer) -> UFix -> UFix)) + (define (incr tape pos) + (vec:set! pos (1+ (current-cell tape pos)) tape) + pos) + + (declare decr ((Vector Integer) -> UFix -> UFix)) + (define (decr tape pos) + (vec:set! pos (1- (current-cell tape pos)) tape) + pos) + + (declare display ((Vector Integer) -> UFix -> UFix)) + (define (display tape pos) + "Prints the value at the pointer to the print buffer." + (let val = (current-cell tape pos)) + (lisp Unit (val) + (cl:format cl:*standard-output* "~a" (cl:code-char val)) + Unit) + pos) + + (declare run (String -> UFix)) + (define (run input-string) + "Parses and runs a Brainfold instruction string, returns the length of the input string." + (let tape = (vec:with-initial-element 30000 0)) + (let stack = (vec:new)) + (let ((next-end (fn (i) + (if (== (unwrap (str:ref input-string i)) + #\]) + i + (next-end (1+ i))))) + (parse-and-run (fn (i pos) + (unwrap-or-else + (fn (x) + (traceobject "cmd - val" (Tuple x (current-cell tape pos))) + (match x + (#\> + (parse-and-run (1+ i) (1+ pos))) + (#\< + (parse-and-run (1+ i) (1- pos))) + (#\+ + (parse-and-run (1+ i) (incr tape pos))) + (#\- + (parse-and-run (1+ i) (decr tape pos))) + (#\. + (parse-and-run (1+ i) (display tape pos))) + (#\[ + + (cond ((zero? (current-cell tape pos)) + (trace "skipped") + (parse-and-run (1+ (next-end i)) pos)) + (True + (vec:push! i stack) + (traceobject "stacked " stack) + (parse-and-run (1+ i) pos)))) + (#\] + (let popped = (vec:pop-unsafe! stack)) + (traceobject "popped" stack;;(Tuple (current-cell tape pos) stack) + ) + (cond ((zero? (current-cell tape pos)) + (trace "continued") + (parse-and-run (1+ i) pos)) + (True + (parse-and-run popped pos ;;(vec:pop-unsafe! stack) pos + )))) + (_ (parse-and-run (1+ i) pos)))) + (fn () + i) + (str:ref input-string i))))) + (parse-and-run 0 0))) + + ;; make another run that has cells for pos and idx + (declare run-file (String -> UFix)) + (define (run-file filename) + (run (unwrap (file:read-file-to-string filename))))) + +;;; +;;; Sample test programs +;;; + +(coalton-toplevel + + ;; from https://esolangs.org/wiki/Brainfuck + (define (hello-world) + (run + "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.")) + + (define (gnarly-hello-world) + (run + ">++++++++[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]>-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------.>>.+++.------.--------.>+.")) + + ;; from https://github.com/saulpw/brainfuck/tree/master/tests + + (define (squares) + (run "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]"))) + +(cl:defun profile-bench () + (sb-sprof:with-profiling (:max-samples 100000 + :sample-interval 0.001 + :report :flat + :loop cl:nil) + (coalton (run-file "bench.b")))) +#+ig +(cl:defun profile-hello-world () + (sb-sprof:with-profiling (:max-samples 1000 + :report :flat + :loop cl:nil) + (coalton (brainfold:hello-world))))