Added table-printing functionality

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:

benchmarks/README.md → benchmarking/README.md

@@ -4,4 +4,4 @@
 
 `(in-package #:coalton-benchmarks)`
 
-`(run-benchmarks)`
+`(run-coalton-benchmarks)`

benchmarks/benchmarking.lisp → benchmarking/benchmarking.lisp

@@ -1,7 +1,8 @@
-(defpackage #:coalton-benchmarking
+(defpackage #:coalton-benchmarking/benchmarking
   (:use
    #:coalton
-   #:coalton-prelude)
+   #:coalton-prelude
+   #:coalton-benchmarking/printing)
   (:local-nicknames
    (#:vec #:coalton-library/vector)
    (#:hash #:coalton-library/hashtable)
@@ -22,7 +23,14 @@
    #:import-benchmarks
    #:reexport-benchmarks))
 
-(in-package #:coalton-benchmarking)
+(in-package #:coalton-benchmarking/benchmarking)
+
+(cl:defvar *coalton-verbose-benchmarking* cl:t)
+
+(cl:defvar *coalton-benchmark-width* 90)
+
+(cl:defvar *coalton-benchmark-sci-notation* cl:t
+  "Coalton benchmarks should use scientific notation for times (or not).")
 
 (coalton-toplevel
 
@@ -33,10 +41,14 @@
     (code       (Unit -> Unit))
     (packages   (Vector String)))
 
-  (declare *verbose-benchmarking* Boolean)
-  (define *verbose-benchmarking*
+  (declare verbose-benchmarking (Unit -> Boolean))
+  (define (verbose-benchmarking)
     "This variable indicates whether benchmarks should print to the repl or just return a BenchmarkResult object."
-    True)
+    (lisp Boolean () *coalton-verbose-benchmarking*))
+
+  (define (benchmark-width)
+    "The width of the benchmark table output. Ideally should be divisible by 5."
+    (lisp UFix () *coalton-benchmark-width*))
 
   (declare *benchmark-environment* (hash:Hashtable String Benchmark))
   (define *benchmark-environment*
@@ -47,58 +59,59 @@
 
   (define-struct BenchmarkResults
     "Results from a Benchmark run."
-    (name       String)
-    (iterations UFix)
-    (real-time  Integer))
-  ;; TODO: this should have cpu-time, space/bytes consed, etc.
+    (name         String)
+    (iterations   UFix)
+    (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 String)
-    (define (into (BenchmarkResults name iterations real-time))
-      (lisp String (name iterations real-time)
-        (cl:format cl:nil "~%Benchmark Results:~%Name: ~a~%Iterations: ~a~%Real-Time: ~a ms~%"
-                   name
-                   iterations
-                   real-time))))
+  (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)))))
 
   (define-struct BenchmarkSystem
     (architecture String)
     (OS           String)
     (lisp-impl    String)
-    (lisp-version String))
-
-  (define-instance (Into BenchmarkSystem String)
-    (define (into (BenchmarkSystem architecture os lisp-impl lisp-version))
-      (lisp String (architecture os lisp-impl lisp-version)
-        (cl:format cl:nil "~a, ~a, ~a ~a"
-                   architecture
-                   os
-                   lisp-impl
-                   lisp-version))))
+    (lisp-version String)
+    (release?     Boolean)
+    (inlining?    Boolean))
 
   (declare benchmark-system-info (Unit -> BenchmarkSystem))
   (define (benchmark-system-info)
-    "This gathers information about your the system the benchmark is run on."
+    "This gathers information about the system the benchmark is run on."
     (BenchmarkSystem
      (sys:architecture)
      (sys:os)
      (sys:implementation)
-     (sys:lisp-version)))
+     (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)))
-
-  (define-instance (Into PackageBenchmarkResults String)
-    (define (into (PackageBenchmarkResults package-name system results))
-      (let system-info = (as String system))
-      (let result-strings = (map (fn (r) (the String (into r))) results))
-      (lisp String (package-name system-info result-strings)
-        (cl:format cl:nil "Package Benchmark Results:~%Package: ~a~%System: ~a~%~%~%~a"
-                   package-name
-                   system-info
-                   result-strings)))))
+    (Results      (vector BenchmarkResults))))
 
 (coalton-toplevel
 
@@ -136,13 +149,17 @@
 
   (declare %run-benchmark (Benchmark -> BenchmarkResults))
   (define (%run-benchmark (Benchmark name iterations func _package))
+    (let profile = (sys:make-profile (fn ()
+                                       (for i in (iter:up-to iterations)
+                                         (func)
+                                         Unit))))
     (BenchmarkResults
      name
      iterations
-     (snd (time (fn ()
-                  (for i in (iter:up-to iterations)
-                    (func)
-                    Unit))))))
+     (.run-time profile)
+     (.real-time profile)
+     #+sbcl
+     (.bytes-consed profile)))
 
   (declare run-benchmark (String -> BenchmarkResults))
   (define (run-benchmark name)
@@ -151,31 +168,70 @@
                                    (fn () (error (lisp String (name)
                                                    (cl:format cl:nil "No benchmark defined by this name: ~a" name))))
                                    (find-benchmark name))))
-      (if *verbose-benchmarking*
-          (progn (print results)
-                 results)
-          results)))
+      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"))))
+
+  (define (package-header name system)
+    (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))
 
   (define (run-package-benchmarks name)
     "Runs all benchmarks for a package"
     (let system = (benchmark-system-info))
-    (let sys-str = (as String system))
-    (when *verbose-benchmarking*
-      (print
-       (lisp String (name sys-str)
-         (cl:format cl:nil "Package '~a' Benchmark Results~%System:~a"
-                    name
-                    sys-str))))
+    (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 res))
+      (when (verbose-benchmarking)
+        (print (render (as TableRow res))))
       (vec:push! (%run-benchmark b) results))
+    (when (verbose-benchmarking)
+      (print (render (BottomEdge (benchmark-width) #+sbcl 5 #-sbcl 4))))
     (PackageBenchmarkResults
      name
      system
-     results)))
+     results))
+
+  (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))))
 
 (cl:defmacro define-benchmark (name iterations func)
   "Defines a Coalton benchmark"

benchmarks/big-float.lisp → benchmarking/benchmarks/big-float.lisp

@@ -73,7 +73,7 @@
         (let x = (into x))
         (sqrt x))))
 
-  (define (big-mult-constants n x)
+  (define (big-mult-const n x)
     (with-precision n
       (fn ()
         (let x = (into x))
@@ -85,7 +85,7 @@
            ;(iterations '*big-float-bench-iterations*)
            ;(precision (coalton (big-float-bench-precision)))
            (rand (cl:* (cl:- (cl:random 2)) (cl:random 100.0d0))))
-    `(coalton (coalton-benchmarking::%define-benchmark ,name 1000
+    `(coalton (coalton-benchmarking/benchmarking::%define-benchmark ,name 1000
                                  (fn ()
                                    (,func 10000
                                          ,rand)
@@ -100,4 +100,4 @@
 
 (define-big-float-benchmark big-sqrt)
 
-(define-big-float-benchmark big-mult-constants)
+(define-big-float-benchmark big-mult-const)

benchmarks/fibonacci.lisp → benchmarking/benchmarks/fibonacci.lisp

@@ -42,8 +42,8 @@
 
 (coalton-toplevel
 
-  (declare fib (Integer -> Integer))
-  (define (fib n)
+ (declare fib (Integer -> Integer))
+ (define (fib n)
     (when (== n 0)
       (return 0))
 
@@ -84,23 +84,23 @@
 ;;; Benchmarks
 ;;;
 
-(define-benchmark recursive-fib 1000
+(define-benchmark rec-fib 1000
   (fn ()
     (fib 20)
     Unit))
 
-(define-benchmark recursive-fib-generic 1000
+(define-benchmark rec-fib-generic 1000
   (fn ()
     (fib-generic-wrapped 20)
     Unit))
 
-(define-benchmark recursive-fib-lisp 1000
+(define-benchmark rec-fib-lisp 1000
   (fn ()
     (lisp Unit ()
       (lisp-fib 20)
       Unit)))
 
-(define-benchmark recursive-fib-monomorphized 1000
+(define-benchmark rec-fib-mono 1000
   (fn ()
     (lisp Unit ()
       (fib-monomorphized 20)

benchmarking/package.lisp

@@ -0,0 +1,6 @@
+(uiop:define-package #:coalton-benchmarking
+    (:use #:coalton
+          #:coalton-prelude)
+    (:mix-reexport
+     #:coalton-benchmarking/printing
+     #:coalton-benchmarking/benchmarking))