diff --git a/benchmarking/benchmarking.lisp b/benchmarking/benchmarking.lisp index cc16283ef..49e119ed1 100644 --- a/benchmarking/benchmarking.lisp +++ b/benchmarking/benchmarking.lisp @@ -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) @@ -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." @@ -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*))) @@ -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) @@ -146,14 +156,21 @@ (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 ;;; @@ -161,8 +178,8 @@ (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* @@ -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" @@ -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)))) diff --git a/benchmarking/printing.lisp b/benchmarking/printing.lisp index f86561bc6..7f1980cdb 100644 --- a/benchmarking/printing.lisp +++ b/benchmarking/printing.lisp @@ -13,11 +13,25 @@ (:export #:render + #:BoxChar + #:Horizontal + #:Vertical + #:TopLeft + #:TopRight + #:TopDown + #:BottomLeft + #:BottomRight + #:BottomUp + #:LeftCross + #:RightCross + #:Cross + #:Newline + + #:TableComponent #:TopEdge #:TopInternalEdge #:InternalEdge #:BottomEdge - #:TCell #:TableHeader #:TableRow @@ -25,6 +39,7 @@ #:Table #:Header + #:SecondaryHeader #:Row #:TopRow #:Bottom @@ -67,129 +82,101 @@ (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 a leftovers for the last column." - (let ((size (math:floor/ (into width) (into columns))) - (remainder (- (into width) (* size (into columns))))) - (Tuple (math:1- (fromint size)) (fromint remainder)))) - - (declare %whitespace (UFix -> String)) - (define (%whitespace width) - "Generates whitespace with a given width." - (let space = (vec:new)) - (for i in (iter:up-to width) - (vec:push! " " space)) - (into space)) - - (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)) - (let ((blank (- width (str:length text))) - (offsets (Tuple (%whitespace (fromint (math:floor/ (into blank) 2))) - (%whitespace (fromint (math:ceiling/ (into blank) 2))))) - (out (vec:new))) - (vec:push! (fst offsets) out) - (vec:push! text out) - (vec:push! (snd offsets) out) - (into (the (vec:Vector String) out)))) - - - (declare %horizontal (UFix -> String)) - (define (%horizontal width) - "Generates a horizontal line with a given width." - (let line = (vec:new)) - (for i in (iter:up-to width) - (vec:push! Horizontal line)) - (render line)) - - (declare %top-edge (UFix -> String)) - (define (%top-edge width) - "Generates the top-edge of a box of width `width`." - (let out = (vec:new)) - (vec:push! TopLeft out) - (for i in (iter:up-to width) - (vec:push! Horizontal out)) - (vec:push! TopRight out) - (vec:push! NewLine out) - (render out)) - - (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" + (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 (vec:new))) - (vec:push! LeftCross out) + (out (the (vec:Vector BoxChar) (vec:new)))) + (vec:push! start-char out) (for j in (iter:up-to (math:1- columns)) (for i in (iter:up-to (fst spacing)) (vec:push! Horizontal out)) - (vec:push! TopDown out)) + (vec:push! break-char out)) (for i in (iter:up-to (+ (fst spacing) (snd spacing))) (vec:push! Horizontal out)) - (vec:push! RightCross out) + (vec:push! end-char out) (vec:push! NewLine out) - (render (the (vec:Vector BoxChar) 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" - (let ((spacing (%column-spacing width columns)) - (out (vec:new))) - (vec:push! LeftCross out) - (for j in (iter:up-to (math:1- columns)) - (for i in (iter:up-to (fst spacing)) - (vec:push! Horizontal out)) - (vec:push! Cross out)) - (for i in (iter:up-to (+ (fst spacing) (snd spacing))) - (vec:push! Horizontal out)) - (vec:push! RightCross out) - (vec:push! NewLine out) - (render (the (vec:Vector BoxChar) out)))) + (%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" - (let ((spacing (%column-spacing width columns)) - (out (vec:new))) - (vec:push! BottomLeft out) - (for j in (iter:up-to (math:1- columns)) - (for i in (iter:up-to (fst spacing)) - (vec:push! Horizontal out)) - (vec:push! BottomUp out)) - (for i in (iter:up-to (+ (fst spacing) (snd spacing))) - (vec:push! Horizontal out)) - (vec:push! BottomRight out) - (vec:push! NewLine out) - (render (the (vec:Vector BoxChar) out)))) + (%write-component width columns BottomRight BottomUp BottomRight)) - (declare %write-row (UFix -> (vec:Vector String) -> String)) - (define (%write-row width column-texts) + ;; + ;; 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 (InternalEdge width columns)) out) + (vec:push! (render top-edge) out) (vec:push! (render Vertical) out) (for txt in column-texts (vec:push! (%write-cell txt (fst spacing)) out) (vec:push! (render Vertical) out)) (vec:push! (render NewLine) out) - (into 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." - (let ((columns (vec:length column-texts)) - (spacing (%column-spacing width columns)) - (out (the (vec:Vector String) (vec:new)))) - (vec:push! (render (TopInternalEdge width columns)) out) - (vec:push! (render Vertical) out) - (for txt in column-texts - (vec:push! (%write-cell txt (fst spacing)) out) - (vec:push! (render Vertical) out)) - (vec:push! (render NewLine) out) - (into out))) + (%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) @@ -224,11 +211,11 @@ (define-instance (Render (List BoxChar)) (define (render bcs) - (into (map render bcs)))) + (mconcat (map render bcs)))) (define-instance (Render (vec:Vector BoxChar)) (define (render bcs) - (into (map render bcs))))) + (mconcat (map render bcs))))) (coalton-toplevel @@ -265,7 +252,7 @@ (vec:push! (render (TCell text (math:1- width))) out) (vec:push! (render Vertical) out) (vec:push! (render NewLine) out) - (into out))))) + (mconcat (as (List String) out)))))) ;;; ;;; Monadic table building @@ -273,8 +260,9 @@ (coalton-toplevel - (declare add-component ((Render :a) => :a -> (state:ST Table Unit))) - (define (add-component component) + (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) @@ -298,27 +286,37 @@ (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 (TableHeader (.width table) text)))) + (%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)))) + (%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)))) + (%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))))) + (%add-component (BottomEdge (.width table) columns))))) (cl:defmacro coalton-table (width cl:&rest forms) "Can be used for building tables or portions of tables. diff --git a/library/string.lisp b/library/string.lisp index 7c22aa3a7..e2e7fb6ca 100644 --- a/library/string.lisp +++ b/library/string.lisp @@ -195,16 +195,6 @@ does not have that suffix." (lisp String (lst) (cl:coerce lst 'cl:string)))) - (define-instance (Into (List String) String) - (define (into strs) - (lisp String (strs) - (cl:format cl:nil "~{~a~}" strs)))) - - (define-instance (Into (Vector String) String) - (define (into strs) - (lisp String (strs) - (cl:format cl:nil "~{~a~}" (cl:coerce strs 'cl:list))))) - (define-instance (Iso (List Char) String))) (define-instance-into-integral-string Integer)