Skip to content

Commit

Permalink
Added benchmarking package totals
Browse files Browse the repository at this point in the history
  • Loading branch information
@Izaakwltn
Izaakwltn committed Oct 10, 2024
1 parent 0ea89d1 commit 21d0d02
Show file tree
Hide file tree
Showing 3 changed files with 181 additions and 168 deletions.
133 changes: 79 additions & 54 deletions benchmarking/benchmarking.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,18 +12,26 @@
(#:list #:coalton-library/list)
(#:state #:coalton-library/monad/state))
(:export
#:*coalton-verbose-benchmarking*
#:*coalton-benchmark-width*
#:*coalton-benchmark-sci-notation*
#:verbose-benchmarking
#:benchmark-width

#:Benchmark

#:BenchmarkResults
#:BenchmarkSystem
#:benchmark-system-info
#:PackageBenchmarkResults

#:define-benchmark
#:find-benchmark
#:find-package-benchmarks
#:run-benchmark
#:run-package-benchmarks
#:define-benchmark
#:reexport-benchmarks

#:import-benchmarks
#:reexport-benchmarks))
#:run-benchmark
#:run-package-benchmarks))

(in-package #:coalton-benchmarking/benchmarking)

Expand All @@ -36,22 +44,24 @@

(coalton-toplevel

(define-struct Benchmark
"A benchmark object"
(name String)
(iterations UFix)
(code (Unit -> Unit))
(packages (Vector String)))

(declare verbose-benchmarking (Unit -> Boolean))
(define (verbose-benchmarking)
"This variable indicates whether benchmarks should print to the repl or just return a BenchmarkResult object."
(lisp Boolean () *coalton-verbose-benchmarking*))

(declare benchmark-width (Unit -> UFix))
(define (benchmark-width)
"The width of the benchmark table output. Ideally should be divisible by 5."
(lisp UFix () *coalton-benchmark-width*))

(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."
Expand Down Expand Up @@ -100,8 +110,8 @@

(coalton-toplevel

(declare current-package (Unit -> String))
(define (current-package)
(declare %current-package (Unit -> String))
(define (%current-package)
"Returns the current local package."
(lisp String ()
(cl:package-name cl:*package*)))
Expand All @@ -116,7 +126,7 @@
name
iterations
fn
(vec:make (current-package)))))
(vec:make (%current-package)))))

(declare find-benchmark (String -> (Optional Benchmark)))
(define (find-benchmark name)
Expand Down Expand Up @@ -146,23 +156,30 @@
(declare %reexport-package-benchmarks (String -> Unit))
(define (%reexport-package-benchmarks package)
(for bmark in (find-package-benchmarks package)
(%add-package (current-package) bmark)
(%add-package (%current-package) bmark)
Unit)))

(cl:defmacro define-benchmark (name iterations func)
"Defines a Coalton benchmark"
(cl:let ((name (cl:string name)))
`(coalton (%define-benchmark ,name ,iterations ,func))))

(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 format-time (UFix -> String))
(define (format-time rtime)
(declare %format-time (UFix -> String))
(define (%format-time rtime)
"Converts time from microseconds to seconds then prunes down to a 10 characters."
(lisp String (rtime)
(cl:let ((control-string (cl:if *coalton-benchmark-sci-notation*
Expand All @@ -178,18 +195,18 @@
"Bytes consed"
"# Iterations"))

(declare column-values (BenchmarkResults -> (Vector String)))
(define (column-values (BenchmarkResults name iterations run-time real-time #+sbcl bytes-consed))
(declare %column-values (BenchmarkResults -> (Vector String)))
(define (%column-values (BenchmarkResults name iterations run-time real-time #+sbcl bytes-consed))
"Returns the column values for a row."
(vec:make name
(format-time run-time)
(format-time real-time)
(%format-time run-time)
(%format-time real-time)
#+sbcl
(into 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))
(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"
Expand Down Expand Up @@ -228,80 +245,88 @@
(fn () (error (lisp String (name)
(cl:format cl:nil "No benchmark defined by this name: ~a" name))))
(find-benchmark name)))
(sys (system-header-text (benchmark-system-info))))
(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)))
(Header (fst sys))
(Header (snd sys))
(SecondaryHeader (fst sys))
(SecondaryHeader (snd sys))
(TopRow *benchmark-column-names*)
(Row (column-values results))
(Row (%column-values results))
(Bottom (vec:length *benchmark-column-names*)))))
results))

(declare package-header (String -> BenchmarkSystem -> String))
(define (package-header name system)
(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))
(let sys = (%system-header-text system))
(coalton-table
(benchmark-width)
(Header (lisp String (name)
(cl:format cl:nil "Package '~a'" name)))
(Header (fst sys))
(Header (snd sys))
(SecondaryHeader (fst sys))
(SecondaryHeader (snd sys))
(TopRow *benchmark-column-names*)))

(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))))

(declare %total-results ((List BenchmarkResults) -> BenchmarkResults))
(define (%total-results results)
"Returns the total metrics for all package benchmarks."
(BenchmarkResults
"Total"
(sum (map (fn (x) (.iterations x)) results))
(sum (map (fn (x) (.run-time x)) results))
(sum (map (fn (x) (.real-time x)) results))
#+sbcl
(sum (map (fn (x) (.bytes-consed x)) results))))

(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 (package-header name system)))
(print (%package-header name system)))

(for b in (find-package-benchmarks name)
(let res = (%run-benchmark b))
(when (verbose-benchmarking)
(print (coalton-table
(benchmark-width)
(Row (column-values res)))))
(Row (%column-values res)))))
(vec:push! res results))

(when (verbose-benchmarking)
(print (coalton-table
(benchmark-width)
(Row (%column-values (%total-results (into results))))
(Bottom #+sbcl 5 #-sbcl 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))
(let sys = (%system-header-text system))
(coalton-table (benchmark-width)
(Header (lisp String (name)
(cl:format cl:nil "Package '~a'" name)))
(Header (fst sys))
(Header (snd sys))
(SecondaryHeader (fst sys))
(SecondaryHeader (snd sys))
(TopRow *benchmark-column-names*)
(print-results (into results))
(%print-results (into results))
(Row (%column-values (%total-results (into results))))
(Bottom #+sbcl 5 #-sbcl 4)))))

(cl:defmacro define-benchmark (name iterations func)
"Defines a Coalton benchmark"
(cl:let ((name (cl:string name)))
`(coalton (%define-benchmark ,name ,iterations ,func))))
Loading

0 comments on commit 21d0d02

Please sign in to comment.