From a40508c9333ed0fd347f1882889bcbdd7c0173a8 Mon Sep 17 00:00:00 2001 From: Izaak Walton Date: Wed, 2 Oct 2024 23:56:24 -0700 Subject: [PATCH] Adding coalton-based benchmark system --- Makefile | 4 +- benchmarking/README.md | 122 +++++++ benchmarking/benchmarking.lisp | 339 ++++++++++++++++++ benchmarking/benchmarks/big-float.lisp | 102 ++++++ .../benchmarks}/fibonacci.lisp | 152 ++++---- .../gabriel-benchmarks/package.lisp | 18 + .../benchmarks}/gabriel-benchmarks/stak.lisp | 61 ++-- .../benchmarks/gabriel-benchmarks/tak.lisp | 47 +++ .../benchmarks/gabriel-benchmarks/takl.lisp | 87 +++++ .../benchmarks}/gabriel-benchmarks/takr.lisp | 44 ++- .../benchmarks}/package.lisp | 43 +-- benchmarking/package.lisp | 6 + benchmarking/printing.lisp | 325 +++++++++++++++++ benchmarks/README.md | 7 - benchmarks/big-float.lisp | 101 ------ benchmarks/gabriel-benchmarks/tak.lisp | 41 --- benchmarks/gabriel-benchmarks/takl.lisp | 88 ----- coalton.asd | 25 +- .../small-coalton-programs.asd | 2 +- .../small-coalton-programs/src/brainfold.lisp | 44 ++- 20 files changed, 1270 insertions(+), 388 deletions(-) create mode 100644 benchmarking/README.md create mode 100644 benchmarking/benchmarking.lisp create mode 100644 benchmarking/benchmarks/big-float.lisp rename {benchmarks => benchmarking/benchmarks}/fibonacci.lisp (56%) create mode 100644 benchmarking/benchmarks/gabriel-benchmarks/package.lisp rename {benchmarks => benchmarking/benchmarks}/gabriel-benchmarks/stak.lisp (54%) create mode 100644 benchmarking/benchmarks/gabriel-benchmarks/tak.lisp create mode 100644 benchmarking/benchmarks/gabriel-benchmarks/takl.lisp rename {benchmarks => benchmarking/benchmarks}/gabriel-benchmarks/takr.lisp (98%) rename {benchmarks => benchmarking/benchmarks}/package.lisp (53%) create mode 100644 benchmarking/package.lisp create mode 100644 benchmarking/printing.lisp delete mode 100644 benchmarks/README.md delete mode 100644 benchmarks/big-float.lisp delete mode 100644 benchmarks/gabriel-benchmarks/tak.lisp delete mode 100644 benchmarks/gabriel-benchmarks/takl.lisp diff --git a/Makefile b/Makefile index d0587d790..6cb5816f0 100644 --- a/Makefile +++ b/Makefile @@ -45,8 +45,8 @@ web-docs: bench: COALTON_ENV=release sbcl --noinform \ --non-interactive \ - --eval "(ql:quickload :coalton/benchmarks :silent t)" \ - --eval "(sb-ext::without-gcing (coalton-benchmarks:run-benchmarks))" + --eval "(ql:quickload :coalton/benchmarks :silent t)" \ + --eval "(coalton-benchmarks:run-coalton-benchmarks)" .PHONY: parser-coverage parser-coverage: diff --git a/benchmarking/README.md b/benchmarking/README.md new file mode 100644 index 000000000..730b26a44 --- /dev/null +++ b/benchmarking/README.md @@ -0,0 +1,122 @@ +# Run the Coalton benchmark suite: + +`(ql:quickload :coalton/benchmarks)` or `(asdf:load-system :coalton/benchmarks)` + +`(in-package #:coalton-benchmarks)` + +`(run-coalton-benchmarks)` + +# Coalton benchmark development + +Benchmarks can be written in any Coalton project, as long as the package imports or nicknames `#:coalton-benchmarking`. + +Benchmarks are attached to the package they are defined in, though they can be reexported to other packages. + +This allows them to be embedded amongst the relevant code, in a standalone suite, or both! + +## Benchmark Settings + +### Verbose +Coalton benchmarking prints to the repl by default. + +This setting can be turned off with: + +``` +(cl:setf *coalton-verbose-benchmarking* cl:nil) +``` + +### Printing width +Coalton benchmarks print to the repl at 90 characters wide by default. + +This can be changed using: + +``` +(cl:setf *coalton-benchmark-width* 90) +``` + +### Print time in cientific notation +By default, times are printed using scientific notation. This can be turned off using: + +``` +(cl:setf *coalton-benchmark-sci-notation* cl:nil) +``` + +## Defining benchmarks: + +Benchmarks can be defined in any Coalton package (that imports or nicknames `#:coalton-benchmarking`): + +``` +;; Defining a Coalton benchmark +(define-benchmark stak 1000 ; iterations + (fn () + (stak 18 12 6) + Unit)) + +;; Defining a Lisp Benchmark +(define-benchmark lisp-stak 1000 ; iterations + (fn () + (lisp Unit () + (lisp-stak 18 12 6) + Unit))) +``` + +## Running individual benchmarks + +Individual benchmarks can be run with `#'run-benchmark`, as long as the benchmark is defined. + +`#'run-benchmark` returns a `BenchmarkResults` object. + +``` +COALTON-BENCHMARKS> (coalton (run-benchmark "tak")) +┌─────────────────────────────────────────────────────────────────────────────────────────┐ +│ Benchmark tak │ +├─────────────────────────────────────────────────────────────────────────────────────────┤ +│ System: ARM64 OS-MACOSX SBCL2.2.4-WIP │ +├─────────────────────────────────────────────────────────────────────────────────────────┤ +│ Coalton development mode without heuristic inlining │ +├───────────────────────┬─────────────────────┬─────────────────────┬─────────────────────┤ +│ Benchmark │ Time Elapsed │ Bytes consed │ # Iterations │ +├───────────────────────┼─────────────────────┼─────────────────────┼─────────────────────┤ +│ TAK │ 9.4079e-1 s │ 0 │ 1000 │ +└───────────────────────┴─────────────────────┴─────────────────────┴─────────────────────┘ + +#.(BENCHMARKRESULTS "TAK" 1000 940788 #.(SOME 0)) +``` + +## Running package benchmarks + +Package benchmarks can be run with #'run-package-benchmarks, from any package that imports coalton-benchmarking. + +`#'run-package-benchmarks` returns a `PackageBenchmarkResults` object. + +``` +COALTON-BENCHMARKS> (coalton (run-package-benchmarks "coalton-benchmarks/gabriel/tak")) +┌─────────────────────────────────────────────────────────────────────────────────────────┐ +│ Package 'coalton-benchmarks/gabriel/tak' │ +├─────────────────────────────────────────────────────────────────────────────────────────┤ +│ System: ARM64 OS-MACOSX SBCL2.2.4-WIP │ +├─────────────────────────────────────────────────────────────────────────────────────────┤ +│ Coalton development mode without heuristic inlining │ +├─────────────────┬─────────────────┬─────────────────┬─────────────────┬─────────────────┤ +│ Benchmark │ Run time │ Real time │ Bytes consed │ # Iterations │ +├─────────────────┼─────────────────┼─────────────────┼─────────────────┼─────────────────┤ +│ TAK │ 1.043406 s │ 1.044723 s │ 65520 │ 1000 │ +├─────────────────┼─────────────────┼─────────────────┼─────────────────┼─────────────────┤ +│ LISP-TAK │ 0.082777 s │ 0.082867 s │ 65520 │ 1000 │ +└─────────────────┴─────────────────┴─────────────────┴─────────────────┴─────────────────┘ + +#.(PACKAGEBENCHMARKRESULTS "coalton-benchmarks/gabriel/tak" #.(COALTON-BENCHMARKING/BENCHMARKING::BENCHMARKSYSTEM "ARM64" "OS-MACOSX" "SBCL" "2.2.4-WIP" COMMON-LISP:NIL COMMON-LISP:NIL) #(#.(BENCHMARKRESULTS "TAK" 1000 1040557 1041583 95888) + #.(BENCHMARKRESULTS "LISP-TAK" 1000 83104 83040 65520))) +``` + +## Reexporting package benchmarks +Package benchmarks can be reexported to other packages: + +``` +(reexport-benchmarks + "coalton-benchmarks/fibonacci" + "coalton-benchmarks/big-float" + "coalton-benchmarks/gabriel") +``` + +This is useful for package-per-file projects. diff --git a/benchmarking/benchmarking.lisp b/benchmarking/benchmarking.lisp new file mode 100644 index 000000000..6c050a2ab --- /dev/null +++ b/benchmarking/benchmarking.lisp @@ -0,0 +1,339 @@ +(defpackage #:coalton-benchmarking/benchmarking + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking/printing) + (:local-nicknames + (#:vec #:coalton-library/vector) + (#:cell #:coalton-library/cell) + (#:hash #:coalton-library/hashtable) + (#:iter #:coalton-library/iterator) + (#:sys #:coalton-library/system) + (#:list #:coalton-library/list) + (#:state #:coalton-library/monad/state)) + (:export + #:Benchmark + #:BenchmarkResults + #:PackageBenchmarkResults + + #:define-benchmark + #:find-benchmark + #:find-package-benchmarks + #:run-benchmark + #:run-package-benchmarks + + #:import-benchmarks + #:reexport-benchmarks)) + +(in-package #:coalton-benchmarking/benchmarking) + +;;; +;;; Settings/options +;;; + +(cl:defvar *coalton-verbose-benchmarking* cl:t + "Toggles whether benchmarking will print to the repl.") + +(cl:defvar *coalton-benchmark-width* 90 + "The width that benchmarks will be printed to.") + +(cl:defvar *coalton-benchmark-sci-notation* cl:t + "Coalton benchmarks should use scientific notation for times (or not).") + +(coalton-toplevel + + (declare verbose-benchmarking (Unit -> Boolean)) + (define (verbose-benchmarking) + "This returns whether benchmarks will print to the repl or just return a BenchmarkResults object." + (lisp Boolean () *coalton-verbose-benchmarking*)) + + (declare benchmark-width (Unit -> UFix)) + (define (benchmark-width) + "This returns the width of the benchmark table output. Ideally should be divisible by 5." + (lisp UFix () *coalton-benchmark-width*)) + + (declare benchmark-sci-notation (Unit -> Boolean)) + (define (benchmark-sci-notation) + "This returns whether benchmarks will print time with scientific notation." + (lisp Boolean () *coalton-benchmark-sci-notation*))) + +;;; +;;; Benchmark environment +;;; + +(coalton-toplevel + + (define-struct Benchmark + "A benchmark object" + (name String) + (iterations UFix) + (code (Unit -> Unit)) + (packages (Vector String))) + + (declare benchmark-environment (hash:Hashtable String Benchmark)) + (define benchmark-environment + "A global environment holding Coalton benchmarks. Key is benchmark name." + (hash:new))) + +;;; +;;; Benchmark Results +;;; + +(coalton-toplevel + + + (define-struct BenchmarkResults + "Results from a Benchmark run." + (name String) + (iterations UFix) + (time-elapsed Integer) + (bytes-consed (Optional Integer))) + + (define-struct BenchmarkSystem + "Information about the system the benchmark is run on." + (architecture String) + (OS String) + (lisp-impl String) + (lisp-version String) + (release? "Is this in release mode or development mode?" Boolean) + (inlining? "Is inlining enabled?" Boolean)) + + (declare benchmark-system-info (Unit -> BenchmarkSystem)) + (define (benchmark-system-info) + "This gathers information about the system the benchmark is run on." + (BenchmarkSystem + (sys:architecture) + (sys:os) + (sys:implementation) + (sys:lisp-version) + (lisp Boolean () + (cl:if (cl:member 'coalton-release cl:*features*) + cl:t + cl:nil)) + (lisp Boolean () + coalton-impl/settings:*coalton-heuristic-inlining*))) + + (define-struct PackageBenchmarkResults + "This is information about a run of package benchmarks." + (package-name String) + (system BenchmarkSystem) + (Results (vector BenchmarkResults)))) + +;;; +;;; Benchmark definition +;;; + +(coalton-toplevel + + (declare current-package (Unit -> String)) + (define (current-package) + "Returns the current local package." + (lisp String () + (cl:package-name cl:*package*))) + + (declare %define-benchmark (String -> UFix -> (Unit -> Unit) -> Unit)) + (define (%define-benchmark name iterations fn) + "Defines a Coalton benchmark, stored in `benchmark-environment`." + (hash:set! + benchmark-environment + name + (Benchmark + name + iterations + fn + (vec:make (current-package))))) + + (declare find-benchmark (String -> (Optional Benchmark))) + (define (find-benchmark name) + "Finds a benchmark given its name." + (hash:get benchmark-environment name)) + + (declare find-package-benchmarks (String -> (Iterator Benchmark))) + (define (find-package-benchmarks package) + "Finds all benchmarks defined in a `package`" + (let pkg = (lisp String (package) (cl:string-upcase package))) + (iter:filter! (fn (b) (unwrap-or-else (fn (_x) True) + (fn () False) + (vec:find-elem pkg (.packages b)))) + (hash:values benchmark-environment)))) + +(cl:defmacro define-benchmark (name iterations func) + "Defines a Coalton benchmark" + (cl:let ((name (cl:string name))) + `(coalton (%define-benchmark ,name ,iterations ,func)))) + +;;; +;;; Allow importing of benchmarks into other packages, +;;; for the sake of building package-per-file benchmark hierarchies. +;;; + +(coalton-toplevel + + (declare %add-package (String -> Benchmark -> Unit)) + (define (%add-package package-name benchmark) + "Adds a package to the benchmark's packages." + (vec:push! package-name (.packages benchmark)) + Unit) + + (declare %reexport-package-benchmarks (String -> Unit)) + (define (%reexport-package-benchmarks package) + (for bmark in (find-package-benchmarks package) + (%add-package (current-package) bmark) + Unit))) + +(cl:defun reexport-benchmarks (cl:&rest packages) + "This imports and reexports benchmarks from another package, for package-per-file hierarchy." + (cl:loop :for pkg :in packages + :do (%reexport-package-benchmarks pkg))) + +;;; +;;; Running and Printing +;;; + +(coalton-toplevel + + (declare print-item ((Into :a String) => :a -> Unit)) + (define (print-item item) + "Equivalent to coalton's `print` function except without a trailing newline." + (let str = (as String item)) + (lisp Unit (str) + (cl:format cl:*standard-output* "~A" str) + Unit)) + + (declare format-time (Integer -> String)) + (define (format-time rtime) + "Converts time from microseconds to seconds then prunes down to a 10 characters." + (let t = (sys:time-units->seconds rtime)) + (lisp String (t) + (cl:let ((control-string (cl:if *coalton-benchmark-sci-notation* + "~,4e s" + "~,7f s"))) + (cl:format cl:nil control-string t)))) + + (declare benchmark-column-names (Vector String)) + (define benchmark-column-names (vec:make "Benchmark" + "Time Elapsed" + "Bytes consed" + "# Iterations")) + + (declare column-values (BenchmarkResults -> (Vector String))) + (define (column-values (BenchmarkResults name iterations time-elapsed bytes-consed)) + "Returns the column values for a row." + (vec:make name + (format-time time-elapsed) + (unwrap-or-else into + (fn () "n/a") + bytes-consed) + (into iterations))) + + (declare system-header-text (BenchmarkSystem -> (Tuple String String))) + (define (system-header-text (BenchmarkSystem architecture os lisp-impl lisp-version release inlining)) + "Returns formatted system information for printing purposes." + (Tuple (lisp String (architecture os lisp-impl lisp-version) + (cl:format cl:nil "System: ~a ~a ~a~a" + architecture + os + lisp-impl + lisp-version)) + (lisp String (release inlining) + (cl:format cl:nil "Coalton ~a mode ~a heuristic inlining" + (cl:if release + "release" + "development") + (cl:if inlining + "with" + "without"))))) + + (declare %run-benchmark (Benchmark -> BenchmarkResults)) + (define (%run-benchmark (Benchmark name iterations func _package)) + "Runs a benchmark." + (let profile = (sys:spacetime (fn () + (for i in (iter:up-to iterations) + (func) + Unit)))) + (BenchmarkResults + name + iterations + (.time-elapsed profile) + (.bytes-consed profile))) + + (declare run-benchmark (String -> BenchmarkResults)) + (define (run-benchmark name) + "Looks up a benchmark by name and runs it if it exists." + (let ((results (unwrap-or-else %run-benchmark + (fn () (error (lisp String (name) + (cl:format cl:nil "No benchmark defined by this name: ~a" name)))) + (find-benchmark (lisp string (name) + (cl:string-upcase name))))) + (sys (system-header-text (benchmark-system-info)))) + (when (verbose-benchmarking) + (print + (coalton-table + (benchmark-width) + (Header (lisp String (name) (cl:format cl:nil "Benchmark ~a" name))) + (SecondaryHeader (fst sys)) + (SecondaryHeader (snd sys)) + (TopRow benchmark-column-names) + (Row (column-values results)) + (Bottom (vec:length benchmark-column-names))))) + results)) + + (declare package-header (String -> BenchmarkSystem -> String)) + (define (package-header name system) + "Returns a formatted package header, including package and system information." + (let sys = (system-header-text system)) + (coalton-table + (benchmark-width) + (Header (lisp String (name) + (cl:format cl:nil "Package '~a'" name))) + (SecondaryHeader (fst sys)) + (SecondaryHeader (snd sys)) + (TopRow benchmark-column-names))) + + (declare run-package-benchmarks (String -> PackageBenchmarkResults)) + (define (run-package-benchmarks name) + "Runs all benchmarks for a package" + (let system = (benchmark-system-info)) + (let results = (vec:new)) + (when (verbose-benchmarking) + (print-item (package-header name system))) + + (for b in (find-package-benchmarks name) + (let res = (%run-benchmark b)) + (when (verbose-benchmarking) + (print-item (coalton-table + (benchmark-width) + (Row (column-values res))))) + (vec:push! res results)) + + (when (verbose-benchmarking) + (print-item (coalton-table + (benchmark-width) + (Bottom 4)))) + + (PackageBenchmarkResults + name + system + results)) + + (declare print-results ((List BenchmarkResults) -> (state:ST Table Unit))) + (define (print-results results) + "Adds results to the table object." + (match results + ((Cons x xs) + (do + (Row (column-values x)) + (print-results xs))) + ((Nil) (pure Unit)))) + + (define-instance (Into PackageBenchmarkResults String) + (define (into (PackageBenchmarkResults name system results)) + (let sys = (system-header-text system)) + (coalton-table (benchmark-width) + (Header (lisp String (name) + (cl:format cl:nil "Package '~a'" name))) + (SecondaryHeader (fst sys)) + (SecondaryHeader (snd sys)) + (TopRow benchmark-column-names) + (print-results (into results)) + (Bottom 5))))) diff --git a/benchmarking/benchmarks/big-float.lisp b/benchmarking/benchmarks/big-float.lisp new file mode 100644 index 000000000..b02373f59 --- /dev/null +++ b/benchmarking/benchmarks/big-float.lisp @@ -0,0 +1,102 @@ +;;;; big-float.lisp +;;;; +;;;; Benchmarks for arbitrary precision floats + +(defpackage #:coalton-benchmarks/big-float + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking + #:coalton-library/big-float) + (:local-nicknames + (#:math #:coalton-library/math)) + (:export + #:*big-float-bench-precision* + #:*big-float-bench-iterations* + #:big-trig + #:big-inv-trig + #:big-ln-exp + #:big-sqrt + #:big-mult-constants)) + +(cl:in-package #:coalton-benchmarks/big-float) + +(cl:defvar *big-float-bench-precision* + #-coalton-portable-bigfloat 10000 + #+coalton-portable-bigfloat 100) +(cl:defvar *big-float-bench-iterations* + #-coalton-portable-bigfloat 1000 + #+coalton-portable-bigfloat 10) + +(coalton-toplevel + + (define (big-float-bench-precision) + (lisp UFix () + *big-float-bench-precision*)) + + (define (big-float-bench-iterations) + (lisp UFix () + *big-float-bench-iterations*))) + +(coalton-toplevel + (define (random-double-float) + (lisp Double-Float () + (cl:* (cl:- (cl:random 2)) (cl:random 100.0d0))))) + +(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-const n x) + (with-precision n + (fn () + (let x = (into x)) + (* x (* math:pi math:ee)))))) + +(cl:defmacro define-big-float-benchmark (name) + (cl:let ((func name) + (name (cl:string name)) + (rand (cl:* (cl:- (cl:random 2)) (cl:random 100.0d0)))) + `(coalton (coalton-benchmarking/benchmarking::%define-benchmark ,name (big-float-bench-iterations) + (fn () + (,func (big-float-bench-precision) + ,rand) + Unit))))) + + +(define-big-float-benchmark big-trig) + +(define-big-float-benchmark big-inv-trig) + +(define-big-float-benchmark big-ln-exp) + +(define-big-float-benchmark big-sqrt) + +(define-big-float-benchmark big-mult-const) diff --git a/benchmarks/fibonacci.lisp b/benchmarking/benchmarks/fibonacci.lisp similarity index 56% rename from benchmarks/fibonacci.lisp rename to benchmarking/benchmarks/fibonacci.lisp index 222c1c68f..af7edd378 100644 --- a/benchmarks/fibonacci.lisp +++ b/benchmarking/benchmarks/fibonacci.lisp @@ -2,77 +2,48 @@ ;;;; ;;;; Benchmarks for different methods of generating fibonacci numbers -(cl:in-package #:coalton-benchmarks) - -(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 () - (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 () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (lisp-fib 20))) - (report trivial-benchmark::*current-timer*)) - - -(define-benchmark recursive-fib-monomorphized () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (coalton-benchmarks/native:fib-monomorphized 20))) - (report trivial-benchmark::*current-timer*)) - -;; -;; Benchmarks on optional are disabled by default because they compute the 10th -;; instead of the 20th fibonacci number. Computing the 20th was exhausting the heap. -;; - -#+ignore -(define-benchmark recursive-fib-generic-optional () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (coalton-benchmarks/native:fib-generic-optional 10))) - (report trivial-benchmark::*current-timer*)) - -#+ignore -(define-benchmark recursive-fib-monomorphized-optional () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (coalton-benchmarks/native:fib-monomorphized-optional 10))) - (report trivial-benchmark::*current-timer*)) - -(defun lisp-fib (n) - (declare (type integer n) - (values integer) - (optimize (speed 3) (safety 0))) - (when (= n 0) - (return-from lisp-fib 0)) - - (when (= n 1) - (return-from lisp-fib 1)) - - (+ (lisp-fib (- n 1)) (lisp-fib (- n 2)))) - -(cl:in-package #:coalton-benchmarks/native) +(defpackage #:coalton-benchmarks/fibonacci + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking) + (:export + #:lisp-fib + #:fib + #:fib-generic + #:fib-generic-wrapped + #:fib-monomorphized + #:fib-optional + #:fib-monomorphized-optional)) + +(in-package #:coalton-benchmarks/fibonacci) + +;;; +;;; Lisp fibonacci +;;; + +(cl:defun lisp-fib (n) + (cl:declare (cl:type cl:integer n) + (cl:values cl:integer) + (cl:optimize (cl:speed 3) (cl:safety 0))) + (cl:when (cl:= n 0) + (cl:return-from lisp-fib 0)) + + (cl:when (cl:= n 1) + (cl:return-from lisp-fib 1)) + + (cl:+ (lisp-fib (cl:- n 1)) (lisp-fib (cl:- n 2)))) + +;;; +;;; Coalton fibonacci +;;; (cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) (coalton-toplevel - (declare fib (Integer -> Integer)) - (define (fib n) + + (declare fib (Integer -> Integer)) + (define (fib n) (when (== n 0) (return 0)) @@ -108,3 +79,50 @@ (declare fib-monomorphized-optional (Integer -> Optional Integer)) (define (fib-monomorphized-optional x) (fib-generic (Some x)))) + +;;; +;;; Benchmarks +;;; + +(define-benchmark rec-fib 1000 + (fn () + (fib 20) + Unit)) + +(define-benchmark rec-fib-generic 1000 + (fn () + (fib-generic-wrapped 20) + Unit)) + +(define-benchmark rec-fib-lisp 1000 + (fn () + (lisp Unit () + (lisp-fib 20) + Unit))) + +(define-benchmark rec-fib-mono 1000 + (fn () + (lisp Unit () + (fib-monomorphized 20) + Unit))) + +;; +;; Benchmarks on optional are disabled by default because they compute the 10th +;; instead of the 20th fibonacci number. Computing the 20th was exhausting the heap. +;; + +#+ignore +(define-benchmark recursive-fib-generic-optional () + (declare (optimize speed)) + (loop :repeat 1000 + :do (with-benchmark-sampling + (coalton-benchmarks/native:fib-generic-optional 10))) + (report trivial-benchmark::*current-timer*)) + +#+ignore +(define-benchmark recursive-fib-monomorphized-optional () + (declare (optimize speed)) + (loop :repeat 1000 + :do (with-benchmark-sampling + (coalton-benchmarks/native:fib-monomorphized-optional 10))) + (report trivial-benchmark::*current-timer*)) diff --git a/benchmarking/benchmarks/gabriel-benchmarks/package.lisp b/benchmarking/benchmarks/gabriel-benchmarks/package.lisp new file mode 100644 index 000000000..ba7b99f02 --- /dev/null +++ b/benchmarking/benchmarks/gabriel-benchmarks/package.lisp @@ -0,0 +1,18 @@ +(uiop:define-package #:coalton-benchmarks/gabriel + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking) + (:mix-reexport + #:coalton-benchmarks/gabriel/tak + #:coalton-benchmarks/gabriel/takr + #:coalton-benchmarks/gabriel/stak + #:coalton-benchmarks/gabriel/takl)) + +(in-package #:coalton-benchmarks/gabriel) + +(reexport-benchmarks + "coalton-benchmarks/gabriel/tak" + "coalton-benchmarks/gabriel/takr" + "coalton-benchmarks/gabriel/stak" + "coalton-benchmarks/gabriel/takl") diff --git a/benchmarks/gabriel-benchmarks/stak.lisp b/benchmarking/benchmarks/gabriel-benchmarks/stak.lisp similarity index 54% rename from benchmarks/gabriel-benchmarks/stak.lisp rename to benchmarking/benchmarks/gabriel-benchmarks/stak.lisp index 89377e558..9e158eb7e 100644 --- a/benchmarks/gabriel-benchmarks/stak.lisp +++ b/benchmarking/benchmarks/gabriel-benchmarks/stak.lisp @@ -2,59 +2,51 @@ ;;;; ;;;; -(in-package #:coalton-benchmarks) +(defpackage #:coalton-benchmarks/gabriel/stak + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking) + (:export + #:lisp-stak + #:stak)) -(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 () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (lisp-stak 18 12 6))) - (report trivial-benchmark::*current-timer*)) +(in-package #:coalton-benchmarks/gabriel/stak) ;;; ;;; ;;; -(defvar x) -(defvar y) -(defvar z) +(cl:defvar x) +(cl:defvar y) +(cl:defvar z) -(declaim (ftype (function () fixnum) stak-aux)) -(defun stak-aux () - (if (not (< y x)) +(cl:declaim (cl:ftype (cl:function () cl:fixnum) stak-aux)) +(cl:defun stak-aux () + (cl:if (cl:not (cl:< y x)) z - (let ((x (let ((x (1- x)) + (cl:let ((x (cl:let ((x (cl:1- x)) (y y) (z z)) (stak-aux))) - (y (let ((x (1- y)) + (y (cl:let ((x (cl:1- y)) (y z) (z x)) (stak-aux))) - (z (let ((x (1- z)) + (z (cl:let ((x (cl:1- z)) (y x)(z y)) (stak-aux)))) (stak-aux)))) -(declaim (ftype (function (fixnum fixnum fixnum) fixnum) lisp-stak)) -(defun lisp-stak (x y z) +(cl:declaim (cl:ftype (cl:function (cl:fixnum cl:fixnum cl:fixnum) cl:fixnum) lisp-stak)) +(cl: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 @@ -76,3 +68,16 @@ (z2 y)) (stak x2 y2 z2)))) (stak x1 y1 z1))))) + +;; Defining the Coalton benchmark +(define-benchmark stak 1000 + (fn () + (stak 18 12 6) + Unit)) + +;; Defining the Lisp Benchmark +(define-benchmark lisp-stak 1000 + (fn () + (lisp Unit () + (lisp-stak 18 12 6) + Unit))) diff --git a/benchmarking/benchmarks/gabriel-benchmarks/tak.lisp b/benchmarking/benchmarks/gabriel-benchmarks/tak.lisp new file mode 100644 index 000000000..339b3b360 --- /dev/null +++ b/benchmarking/benchmarks/gabriel-benchmarks/tak.lisp @@ -0,0 +1,47 @@ +;;;; gabriel-benchmarks/tak.lisp +;;;; +(defpackage #:coalton-benchmarks/gabriel/tak + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking) + (:export + #:lisp-tak + #:tak)) + +(in-package #:coalton-benchmarks/gabriel/tak) + + +;; Defining the lisp version +(cl:declaim (cl:ftype (cl:function (cl:fixnum cl:fixnum cl:fixnum) cl:fixnum) lisp-tak)) +(cl:defun lisp-tak (x y z) + (cl:declare (cl:optimize (cl:speed 3) (cl:safety 0))) + (cl:if (cl:not (cl:< y x)) + z + (lisp-tak (lisp-tak (cl:1- x) y z) + (lisp-tak (cl:1- y) z x) + (lisp-tak (cl:1- z) x y)))) + +;; Defining the Coalton version +(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))))) + +;; Defining the Coalton benchmark +(define-benchmark tak 1000 + (fn () + (tak 18 12 6) + Unit)) + +;; Defining the Lisp Benchmark +(define-benchmark lisp-tak 1000 + (fn () + (lisp Unit () + (lisp-tak 18 12 6) + Unit)))() diff --git a/benchmarking/benchmarks/gabriel-benchmarks/takl.lisp b/benchmarking/benchmarks/gabriel-benchmarks/takl.lisp new file mode 100644 index 000000000..2a5508e7a --- /dev/null +++ b/benchmarking/benchmarks/gabriel-benchmarks/takl.lisp @@ -0,0 +1,87 @@ +;;;; gabriel-benchmarks/takl.lisp +;;;; +;;;; + +(defpackage #:coalton-benchmarks/gabriel/takl + (:use #:coalton + #:coalton-prelude + #:coalton-benchmarking) + (:local-nicknames + (#:list #:Coalton-library/list))) + +(in-package #:coalton-benchmarks/gabriel/takl) +;;; +;;; +;;; + +(cl:declaim (cl:ftype (cl:function (cl:fixnum) cl:list) lisp-listn)) +(cl:defun lisp-listn (n) + (cl:if (cl:not (cl:= 0 n)) + (cl:cons n (lisp-listn (cl:1- n))))) + +(cl:declaim (cl:ftype (cl:function (cl:list cl:list) cl:boolean) lisp-shorterp)) +(cl:defun lisp-shorterp (x y) + (cl:and y (cl:or (cl:null x) + (lisp-shorterp (cl:cdr x) + (cl:cdr y))))) + +(cl:declaim (cl:ftype (cl:function (cl:list cl:list cl:list) cl:list) lisp-mas)) +(cl:defun lisp-mas (x y z) + (cl:if (cl:not (lisp-shorterp y x)) + z + (lisp-mas (lisp-mas (cl:cdr x) + y z) + (lisp-mas (cl:cdr y) + z x) + (lisp-mas (cl:cdr z) + x y)))) + +(cl:declaim (cl:ftype (cl:function (cl:fixnum cl:fixnum cl:fixnum) cl:list) lisp-takl)) +(cl:defun lisp-takl (x y z) + (lisp-mas (lisp-listn x) (lisp-listn y) (lisp-listn z))) + +;;; +;;; +;;; + +#+ig(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-benchmark takl 2000 + (fn () + (takl 18 12 6) + Unit)) + +(define-benchmark lisp-takl 2000 + (fn () + (takl 18 12 6) + Unit)) diff --git a/benchmarks/gabriel-benchmarks/takr.lisp b/benchmarking/benchmarks/gabriel-benchmarks/takr.lisp similarity index 98% rename from benchmarks/gabriel-benchmarks/takr.lisp rename to benchmarking/benchmarks/gabriel-benchmarks/takr.lisp index a8ce2bb5a..a3d5e4395 100644 --- a/benchmarks/gabriel-benchmarks/takr.lisp +++ b/benchmarking/benchmarks/gabriel-benchmarks/takr.lisp @@ -2,21 +2,12 @@ ;;;; ;;;; -(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*)) +(cl:defpackage #:coalton-benchmarks/gabriel/takr-lisp + (:use #:cl) + (:export + #:lisp-takr)) + +(in-package #:coalton-benchmarks/gabriel/takr-lisp) ;;; ;;; @@ -726,8 +717,16 @@ ;;; ;;; +(defpackage #:coalton-benchmarks/gabriel/takr + (:use + #:coalton + #:coalton-prelude + #:coalton-benchmarking + #:coalton-benchmarks/gabriel/takr-lisp) + (:export + #:takr)) -(cl:in-package #:coalton-benchmarks/native) +(in-package #:coalton-benchmarks/gabriel/takr) (cl:declaim (cl:optimize (cl:speed 3) (cl:safety 0))) @@ -1432,3 +1431,16 @@ (True (takr (takr (- x 1) y z) (takr (- y 1) z x) (takr (- z 1) x y)))))) + +;; Defining the Coalton benchmark +(define-benchmark takr 1000 + (fn () + (takr 18 12 6) + Unit)) + +;; Defining the Lisp Benchmark +(define-benchmark lisp-takr 1000 + (fn () + (lisp Unit () + (lisp-takr 18 12 6) + Unit))) diff --git a/benchmarks/package.lisp b/benchmarking/benchmarks/package.lisp similarity index 53% rename from benchmarks/package.lisp rename to benchmarking/benchmarks/package.lisp index 6e3ee4b8c..101b987a2 100644 --- a/benchmarks/package.lisp +++ b/benchmarking/benchmarks/package.lisp @@ -2,37 +2,28 @@ ;;;; ;;;; Benchmarks packages and common functions -(benchmark:define-benchmark-package #:coalton-benchmarks - (:export #:run-benchmarks - #:run-benchmarks-ci)) - -(cl:defpackage #:coalton-benchmarks/native - (:use - #:coalton - #:coalton-prelude - #:coalton-library/big-float - #:coalton-library/math) - (:local-nicknames (#:list #:coalton-library/list)) +(uiop:define-package #:coalton-benchmarks + (:use #:coalton + #:coalton-prelude + #:coalton-benchmarking) + (:mix-reexport + #:coalton-benchmarks/fibonacci + #:coalton-benchmarks/big-float + #:coalton-benchmarks/gabriel) (:export - #:fib - #:fib-fixnum - #:fib-generic-wrapped - #:fib-monomorphized - #:fib-generic-optional - #:fib-monomorphized-optional) + #:run-coalton-benchmarks)) - ;; gabriel-benchmarks/ - (:export - #:tak - #:stak - #:takl - #:takr)) +(in-package #:coalton-benchmarks) -(cl:in-package #:coalton-benchmarks) +(reexport-benchmarks + "coalton-benchmarks/fibonacci" + "coalton-benchmarks/big-float" + "coalton-benchmarks/gabriel") -(defun run-benchmarks () - (run-package-benchmarks :package '#:coalton-benchmarks :verbose t)) +(cl:defun run-coalton-benchmarks () + (coalton (run-package-benchmarks "coalton-benchmarks"))) +#+ig (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) diff --git a/benchmarking/package.lisp b/benchmarking/package.lisp new file mode 100644 index 000000000..6cb037fc1 --- /dev/null +++ b/benchmarking/package.lisp @@ -0,0 +1,6 @@ +(uiop:define-package #:coalton-benchmarking + (:use #:coalton + #:coalton-prelude) + (:mix-reexport + #:coalton-benchmarking/printing + #:coalton-benchmarking/benchmarking)) diff --git a/benchmarking/printing.lisp b/benchmarking/printing.lisp new file mode 100644 index 000000000..4dfb74f05 --- /dev/null +++ b/benchmarking/printing.lisp @@ -0,0 +1,325 @@ +(defpackage #:coalton-benchmarking/printing + (:use + #:coalton + #:coalton-prelude) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:vec #:coalton-library/vector) + (#:math #:coalton-library/math) + (#:str #:coalton-library/string) + (#:list #:coalton-library/list) + (#:cell #:coalton-library/cell) + (#:state #:coalton-library/monad/state)) + (:export + #:render + + #:BoxChar + #:Horizontal + #:Vertical + #:TopLeft + #:TopRight + #:TopDown + #:BottomLeft + #:BottomRight + #:BottomUp + #:LeftCross + #:RightCross + #:Cross + #:Newline + + #:TableComponent + #:TopEdge + #:TopInternalEdge + #:InternalEdge + #:BottomEdge + + #:TableHeader + #:TableRow + #:TopTableRow + + #:Table + #:Header + #:SecondaryHeader + #:Row + #:TopRow + #:Bottom + #:coalton-table)) + +(in-package #:coalton-benchmarking/printing) + +(coalton-toplevel + + (define-class (Render :a) + "Class for rendering portions of tables." + (render "Renders a portion of a table in string form." + (:a -> String)))) + +(coalton-toplevel + + (define-type BoxChar + "Coalton table printing atoms." + Horizontal + Vertical + TopLeft + TopRight + TopDown + BottomLeft + BottomRight + BottomUp + LeftCross + RightCross + Cross + Newline) + + (define-type TableComponent + "Coalton table printing combinations." + (TopEdge UFix) + (TopInternalEdge UFix UFix) + (InternalEdge UFix UFix) + (BottomEdge UFix UFix) + (TCell String UFix)) + + (declare %column-spacing (UFix -> UFix -> (Tuple UFix UFix))) + (define (%column-spacing width columns) + "Evenly divides the width by the number of columns. Returns the size for each column plus the remainder." + (if (== columns 1) + (Tuple width 0) + (let ((size (math:floor/ (into width) (into columns))) + (remainder (- (into width) (* size (into columns))))) + (Tuple (math:1- (fromint size)) (fromint remainder))))) + + (declare %write-component (UFix -> UFix -> BoxChar -> BoxChar -> BoxChar -> String)) + (define (%write-component width columns start-char break-char end-char) + "Writes a component (edge) as a string." + (let ((spacing (%column-spacing width columns)) + (out (the (vec:Vector BoxChar) (vec:new)))) + (vec:push! start-char out) + (for i in (iter:up-to (+ (fst spacing) (snd spacing))) + (vec:push! Horizontal out)) + (for j in (iter:up-to (math:1- columns)) + (vec:push! break-char out) + (for i in (iter:up-to (fst spacing)) + (vec:push! Horizontal out))) + (vec:push! end-char out) + (vec:push! NewLine out) + (render out))) + + (declare %top-edge (UFix -> String)) + (define (%top-edge width) + "Generates the top edge of a table." + (%write-component width 1 TopLeft Horizontal TopRight)) + + (declare %top-internal-edge (UFix -> UFix -> String)) + (define (%top-internal-edge width columns) + "Generates the top-edge of a row of width `width` divided evenly into `columns` columns" + (%write-component width columns LeftCross TopDown RightCross)) + + (declare %internal-edge (UFix -> UFix -> String)) + (define (%internal-edge width columns) + "Generates the top-edge of a row of width `width` divided evenly into `columns` columns" + (%write-component width columns LeftCross Cross RightCross)) + + (declare %bottom-edge (UFix -> UFix -> String)) + (define (%bottom-edge width columns) + "Generates the top-edge of a row of width `width` divided evenly into `columns` columns" + (%write-component width columns BottomLeft BottomUp BottomRight)) + + ;; + ;; Writing text, cells, headers + ;; + + (declare %whitespace (UFix -> String)) + (define (%whitespace width) + "Generates whitespace with a given width." + (mconcat (vec:with-initial-element width " "))) + + (declare %write-cell (String -> UFix -> String)) + (define (%write-cell cell-text width) + "Writes text as if to a cell, with appropriate whitespace" + ;; this handles text too long for a table cell + (let ((text (if (>= (str:length cell-text) width) + (str:substring cell-text 0 (1- width)) + cell-text)) + (blank (- width (str:length text))) + (offsets (Tuple (%whitespace (fromint (math:floor/ (into blank) 2))) + (%whitespace (fromint (math:ceiling/ (into blank) 2))))) + (out (the (vec:Vector String) (vec:new)))) + (vec:push! (fst offsets) out) + (vec:push! text out) + (vec:push! (snd offsets) out) + (mconcat out))) + + ;; + ;; + ;; + + (declare %write-row-component (UFix -> (vec:Vector String) -> TableComponent -> String)) + (define (%write-row-component width column-texts top-edge) + "Writes a full table row of width `width` containing `column-texts`." + (let ((columns (vec:length column-texts)) + (spacing (%column-spacing width columns)) + (out (the (vec:Vector String) (vec:new)))) + (vec:push! (render top-edge) out) + (vec:push! (render Vertical) out) + (vec:push! (%whitespace (snd spacing)) out) + (for txt in column-texts + (vec:push! (%write-cell txt (fst spacing)) out) + (vec:push! (render Vertical) out)) + (vec:push! (render NewLine) out) + (mconcat out))) + + (declare %write-top-row (UFix -> (vec:Vector String) -> String)) + (define (%write-top-row width column-texts) + "Writes the top-row of a table- has no lines crossing above the top." + (%write-row-component width column-texts (TopInternalEdge width (vec:length column-texts)))) + + (declare %write-row (UFix -> (vec:Vector String) -> String)) + (define (%write-row width column-texts) + "Writes a row of a table." + (%write-row-component width column-texts (InternalEdge width (vec:length column-texts)))) + + (define-instance (Render TableComponent) + (define (render tc) + (match tc + ((TopEdge width) + (%top-edge width)) + ((TopInternalEdge width columns) + (%top-internal-edge width columns)) + ((InternalEdge width columns) + (%internal-edge width columns)) + ((BottomEdge width columns) + (%bottom-edge width columns)) + ((TCell text width) + (%write-cell text width))))) + + (define-instance (Render BoxChar) + (define (render bc) + (match bc + ((Horizontal) "─") + ((Vertical) "│") + ((TopLeft) "┌") + ((TopRight) "┐") + ((TopDown) "┬") + ((BottomLeft) "└") + ((BottomRight) "┘") + ((BottomUp) "┴") + ((Cross) "┼") + ((LeftCross) "├") + ((RightCross) "┤") + ((Newline) " +")))) + + (define-instance (Render (List BoxChar)) + (define (render bcs) + (mconcat (map render bcs)))) + + (define-instance (Render (vec:Vector BoxChar)) + (define (render bcs) + (mconcat (map render bcs))))) + +(coalton-toplevel + + (define-struct TableHeader + (width "The width of the table" UFix) + (text "The text of the table" String)) + + (define-struct TableRow + "A struct that can be used to generate a printed table row." + (width "The width of the table row." UFix) + (column-contents "A vector of column contents." (vec:Vector String))) + + (define-struct TopTableRow + "A struct that can be used to generate a printed table row with no row above." + (width UFix) + (column-contents (vec:Vector String))) + + (define-instance (Render TableRow) + (define (render (TableRow width contents)) + (%write-row width contents))) + + (define-instance (Render TopTableRow) + (define (render (TopTableRow width contents)) + (%write-top-row width contents))) + + (define-instance (Render TableHeader) + (define (render (TableHeader width text)) + (let ((blank (the Integer (into (- width (str:length text))))) + (offsets (Tuple (%whitespace (fromint (math:floor/ blank 2))) + (%whitespace (fromint (math:ceiling/ blank 2))))) + (out (the (vec:Vector String) (vec:new)))) + (vec:push! (%top-edge (math:1- width)) out) + (vec:push! (render Vertical) out) + (vec:push! (render (TCell text (math:1- width))) out) + (vec:push! (render Vertical) out) + (vec:push! (render NewLine) out) + (mconcat (as (List String) out)))))) + +;;; +;;; Monadic table building +;;; + +(coalton-toplevel + + (declare %add-component ((Render :a) => :a -> (state:ST Table Unit))) + (define (%add-component component) + "Adds a rendered component to the table printout." + (do + (table <- state:get) + (pure (cell:update! (fn (s) + (str:concat s (render component))) + (.printout table))) + (state:put table))) + + (define-struct Table + (printout "The table being rendered." (Cell String)) + (width "The width of the table" UFix)) + + (define-instance (Into Table String) + (define (into (Table printout width)) + (cell:read printout))) + + (define-instance (Default Table) + (define (default) + (Table + (cell:new "") + 90))) + + (declare Header (String -> (state:ST Table Unit))) + (define (Header text) + "Add a header to the table printout." + (do + (table <- state:get) + (%add-component (TableHeader (.width table) text)))) + + (define (SecondaryHeader text) + "Adds a header below the first header." + (do + (table <- state:get) + (%add-component (TableRow (1- (.width table)) (vec:make text))))) + + (declare Row ((Vector String) -> (state:ST Table Unit))) + (define (Row texts) + "Add a row to the table printout." + (do + (table <- state:get) + (%add-component (TableRow (.width table) texts)))) + + (declare TopRow ((Vector String) -> (state:ST Table Unit))) + (define (TopRow texts) + "Add a top row to the table printout (no upward cross characters)." + (do + (table <- state:get) + (%add-component (TopTableRow (.width table) texts)))) + + (declare Bottom (UFix -> (state:ST Table Unit))) + (define (Bottom columns) + "Add the bottom edge to the table printout." + (do + (table <- state:get) + (%add-component (BottomEdge (.width table) columns))))) + +(cl:defmacro coalton-table (width cl:&rest forms) + "Can be used for building tables or portions of tables. +Forms should be provided with the understanding that they are embedded in a `do` form." + (cl:let ((forms (cl:append '(do) forms))) + `(cell:read (.printout (fst (state:run ,forms (Table (cell:new "") ,width))))))) diff --git a/benchmarks/README.md b/benchmarks/README.md deleted file mode 100644 index 2feb099e6..000000000 --- a/benchmarks/README.md +++ /dev/null @@ -1,7 +0,0 @@ -# To run Coalton Benchmarks: - -`(ql:quickload :coalton/benchmarks)` or `(asdf:load-system :coalton/benchmarks)` - -`(in-package #:coalton-benchmarks)` - -`(run-benchmarks)` \ No newline at end of file diff --git a/benchmarks/big-float.lisp b/benchmarks/big-float.lisp deleted file mode 100644 index f044ee3aa..000000000 --- a/benchmarks/big-float.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;;;; big-float.lisp -;;;; -;;;; Benchmarks for arbitrary precision floats - -(cl:in-package #:coalton-benchmarks) - -(cl:defvar *big-float-bench-precision* - #-coalton-portable-bigfloat 10000 - #+coalton-portable-bigfloat 100) -(cl:defvar *big-float-bench-iterations* - #-coalton-portable-bigfloat 1000 - #+coalton-portable-bigfloat 10) - -(define-benchmark big-trig () - "Benchmark at N precision big-float trigonometric functions." - (declare (optimize speed)) - (loop :repeat *big-float-bench-iterations* - :do (with-benchmark-sampling - (coalton-benchmarks/native::big-trig - *big-float-bench-precision* - (* (- (random 2)) (random 100.0d0))))) - (report trivial-benchmark::*current-timer*)) - -(define-benchmark big-inv-trig () - "Benchmark at N precision big-float inverse trigonometric functions." - (declare (optimize speed)) - (loop :repeat *big-float-bench-iterations* - :do (with-benchmark-sampling - (coalton-benchmarks/native::big-inv-trig - *big-float-bench-precision* - (* (- (random 2)) (random 1.0d0))))) - (report trivial-benchmark::*current-timer*)) - -(define-benchmark big-ln-exp () - "Benchmark at N precision big-float ln and exp." - (declare (optimize speed)) - (loop :repeat *big-float-bench-iterations* - :do (with-benchmark-sampling - (coalton-benchmarks/native::big-ln-exp - *big-float-bench-precision* - (* (- (random 2)) (random 100.0d0))))) - (report trivial-benchmark::*current-timer*)) - -(define-benchmark big-sqrt () - "Benchmark at N precision big-float square roots." - (declare (optimize speed)) - (loop :repeat *big-float-bench-iterations* - :do (with-benchmark-sampling - (coalton-benchmarks/native::big-sqrt - *big-float-bench-precision* - (random 100.0d0)))) - (report trivial-benchmark::*current-timer*)) - -(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* - :do (with-benchmark-sampling - (coalton-benchmarks/native::big-sqrt - *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/gabriel-benchmarks/tak.lisp b/benchmarks/gabriel-benchmarks/tak.lisp deleted file mode 100644 index 0617c5caf..000000000 --- a/benchmarks/gabriel-benchmarks/tak.lisp +++ /dev/null @@ -1,41 +0,0 @@ -;;;; gabriel-benchmarks/tak.lisp -;;;; -;;;; - -(cl:in-package #:coalton-benchmarks) - -(define-benchmark tak () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (coalton-benchmarks/native:tak 18 12 6))) - (report trivial-benchmark::*current-timer*)) - -(define-benchmark tak-lisp () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (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) - (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 deleted file mode 100644 index 23e3fdd87..000000000 --- a/benchmarks/gabriel-benchmarks/takl.lisp +++ /dev/null @@ -1,88 +0,0 @@ -;;;; gabriel-benchmarks/takl.lisp -;;;; -;;;; - -(cl:in-package #:coalton-benchmarks) - -(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 () - (declare (optimize speed)) - (loop :repeat 1000 - :do (with-benchmark-sampling - (lisp-takl 18 12 6))) - (report trivial-benchmark::*current-timer*)) - -;;; -;;; -;;; - -(declaim (ftype (function (fixnum) list) listn)) -(defun listn (n) - (if (not (= 0 n)) - (cons n (listn (1- n))))) - -(declaim (ftype (function (list list) boolean))) -(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) - (if (not (shorterp y x)) - z - (mas (mas (cdr x) - y z) - (mas (cdr y) - z x) - (mas (cdr z) - x y)))) - -(declaim (ftype (function (fixnum fixnum fixnum) list))) -(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/coalton.asd b/coalton.asd index 30a8da1bc..6a1bd385a 100644 --- a/coalton.asd +++ b/coalton.asd @@ -134,6 +134,17 @@ :components ((:file "package") (:file "coalton-native-test-utils"))) +(asdf:defsystem #:coalton/benchmarking + :author "Coalton contributors (https://github.com/coalton-lang/coalton)" + :license "MIT" + :version (:read-file-form "VERSION.txt") + :depends-on (#:coalton) + :pathname "benchmarking" + :serial t + :components ((:file "printing") + (:file "benchmarking") + (:file "package"))) + (asdf:defsystem #:coalton/benchmarks :author "Coalton contributors (https://github.com/coalton-lang/coalton)" :license "MIT" @@ -142,22 +153,21 @@ (let (#+sbcl (sb-ext:*derive-function-types* t) #+sbcl (sb-ext:*block-compile-default* :specified)) (funcall compile))) - :depends-on (#:coalton #:coalton/library/big-float - #:trivial-benchmark - #:yason) - :pathname "benchmarks" + #:coalton/benchmarking) + :pathname "benchmarking/benchmarks" :serial t - :components ((:file "package") - (:file "fibonacci") + :components ((:file "fibonacci") (:file "big-float") (: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 @@ -213,6 +223,7 @@ :author "Coalton contributors (https://github.com/coalton-lang/coalton)" :license "MIT" :depends-on (#:coalton + #:coalton/library/computable-reals #:coalton/library/big-float #:coalton/testing #:fiasco diff --git a/examples/small-coalton-programs/small-coalton-programs.asd b/examples/small-coalton-programs/small-coalton-programs.asd index 79359f68c..d9d9a0aa6 100644 --- a/examples/small-coalton-programs/small-coalton-programs.asd +++ b/examples/small-coalton-programs/small-coalton-programs.asd @@ -1,5 +1,5 @@ (asdf:defsystem #:small-coalton-programs - :depends-on (#:coalton) + :depends-on (#:coalton #:coalton/benchmarking) :pathname "src/" :serial t :components ((:file "package") diff --git a/examples/small-coalton-programs/src/brainfold.lisp b/examples/small-coalton-programs/src/brainfold.lisp index 11d0c18b3..46bc5db5f 100644 --- a/examples/small-coalton-programs/src/brainfold.lisp +++ b/examples/small-coalton-programs/src/brainfold.lisp @@ -17,7 +17,8 @@ (cl:defpackage #:brainfold (:use #:coalton - #:coalton-prelude) + #:coalton-prelude + #:coalton-benchmarking) (:local-nicknames (#:vec #:coalton-library/vector) (#:iter #:coalton-library/iterator) @@ -31,12 +32,14 @@ (:export #:eval #:run-program - #:run-file - + #:run-file) + (:export ;; Examples #:hello-world #:gnarly-hello-world - #:squares)) + #:squares) + (:export + #:run-brainfold-benchmarks)) (in-package #:brainfold) @@ -305,3 +308,36 @@ (define (squares) (run-program "++++[>+++++<-]>[<+++++>-]+<+[>[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+>>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]<<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>[-[<->-]+[<<<]]<[>+<-]>]<<-]<<-]"))) + +(define-benchmark bf-hello 1 + (fn () + (hello-world) + Unit)) + +(define-benchmark bf-hello10 10 + (fn () + (hello-world) + Unit)) + +(define-benchmark bf-gnarly 1 + (fn () + (gnarly-hello-world) + Unit)) + +(define-benchmark bf-gnarly10 10 + (fn () + (gnarly-hello-world) + Unit)) + +(define-benchmark squares 1 + (fn () + (squares) + Unit)) + +(define-benchmark squares10 10 + (fn () + (squares) + Unit)) + +(cl:defun run-brainfold-benchmarks () + (run-package-benchmarks "brainfold"))