Skip to content

Commit

Permalink
Added monadic table building
Browse files Browse the repository at this point in the history
  • Loading branch information
@Izaakwltn
Izaakwltn committed Oct 9, 2024
1 parent 19fadb1 commit 775c382
Show file tree
Hide file tree
Showing 3 changed files with 231 additions and 173 deletions.
227 changes: 134 additions & 93 deletions benchmarking/benchmarking.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,12 @@
#: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))
(#:list #:coalton-library/list)
(#:state #:coalton-library/monad/state))
(:export
#:Benchmark
#:BenchmarkResults
Expand Down Expand Up @@ -64,34 +66,16 @@
(run-time UFix)
(real-time UFix)
#+sbcl
(bytes-consed UFix))


(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*
"~,4e s"
"~,7f s")))
(cl:format cl:nil control-string (cl:/ rtime 1e6)))))

(define-instance (Into BenchmarkResults TableRow)
(define (into (BenchmarkResults name iterations run-time real-time #+sbcl bytes-consed))
(TableRow (benchmark-width) (vec:make name
(format-time run-time)
(format-time real-time)
#+sbcl
(into bytes-consed)
(into iterations)))))
(bytes-consed "Bytes-consed is only currently enabled for SBCL" UFix))

(define-struct BenchmarkSystem
"Information about the system the benchmark is run on."
(architecture String)
(OS String)
(lisp-impl String)
(lisp-version String)
(release? Boolean)
(inlining? Boolean))
(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)
Expand Down Expand Up @@ -148,8 +132,83 @@
(vec:find-elem pkg (.packages b))))
(hash:values *benchmark-environment*)))

;;
;; Allow importing of benchmarks into other packages,
;; for the sake of building package-per-file benchmark hierarchies.
;;

(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 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*
"~,4e s"
"~,7f s")))
(cl:format cl:nil control-string (cl:/ rtime 1e6)))))

(declare *benchmark-column-names* (Vector String))
(define *benchmark-column-names* (vec:make "Benchmark"
"Run time"
"Real time"
#+sbcl
"Bytes consed"
"# Iterations"))

(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)
#+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))
"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 a given number of iterations."
(let profile = (sys:make-profile (fn ()
(for i in (iter:up-to iterations)
(func)
Expand All @@ -164,103 +223,85 @@

(declare run-benchmark (String -> BenchmarkResults))
(define (run-benchmark name)
"Looks up and runs a benchmark if it exists."
"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 name))))
(find-benchmark 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)))
(Header (fst sys))
(Header (snd sys))
(TopRow *benchmark-column-names*)
(Row (column-values results))
(Bottom (vec:length *benchmark-column-names*)))))
results))

(define (system-header-text (BenchmarkSystem architecture os lisp-impl lisp-version release inlining))
(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")))))

(define (column-names)
(render (TopTableRow (benchmark-width) (vec:make "Benchmark"
"Run time"
"Real time"
#+sbcl
"Bytes consed"
"# Iterations"))))

(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 out = (vec:new))
(vec:push! (render (TableHeader (benchmark-width) (lisp String (name)
(cl:format cl:nil "Package '~a'"
name))))
out)
(vec:push! (render (TableHeader (benchmark-width) (fst sys))) out)
(vec:push! (render (TableHeader (benchmark-width) (snd sys))) out)
(vec:push! (column-names) out)
(as String out))
(coalton-table
(benchmark-width)
(Header (lisp String (name)
(cl:format cl:nil "Package '~a'" name)))
(Header (fst sys))
(Header (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 (package-header name system)))
(let results = (vec:new))

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

(when (verbose-benchmarking)
(print (render (BottomEdge (benchmark-width) #+sbcl 5 #-sbcl 4))))
(print (coalton-table
(benchmark-width)
(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 package-name system results))
(let out = (vec:new))
(vec:push! (package-header package-name system) out)
(for res in results
(vec:push! (render (as TableRow res)) out))
(vec:push! (render (BottomEdge (benchmark-width) #+sbcl 5 #-sbcl 4)) out)
(as String out))))
(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)))
(Header (fst sys))
(Header (snd sys))
(TopRow *benchmark-column-names*)
(print-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))))

;;;
;;; 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)))
Loading

0 comments on commit 775c382

Please sign in to comment.