Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Remove benchmark code and report timing/allocation info for all tests.

  • Loading branch information...
commit 0e42b67fdc0cb9e86486c7e53cf6d817462c292c 1 parent c013f78
@cgay cgay authored
View
108 benchmarks.dylan
@@ -1,108 +0,0 @@
-Module: testworks
-Synopsis: Testworks benchmarks
-Author: Carl Gay
-Copyright: Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
- All rights reserved.
-License: See License.txt in this distribution for details.
-Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-
-/// Benchmarks
-
-/// Note that <benchmark-result> is defined in tests.dylan
-
-// TODO(cgay): rather than having a special benchmark mechanism, just
-// record/report timing info for all tests (optionally).
-
-define macro benchmark
- { benchmark (?benchmark-name:expression, ?expr:expression)
- } => {
- %benchmark(method () ?benchmark-name end,
- method () ?expr end)
- }
-end macro benchmark;
-
-define function %benchmark
- (get-name :: <function>, run-benchmark :: <function>)
- => ()
- let phase = "evaluating benchmark name";
- let name = #f;
- block (return)
- let handler <serious-condition>
- = method (condition, next-handler)
- if (*debug?*)
- next-handler() // decline to handle it
- else
- record-benchmark(name | format-to-string("*** Invalid benchmark name ***"),
- $crashed,
- format-to-string("Error %s: %s", phase, condition),
- #f, #f, #f);
- return();
- end;
- end method;
- name := get-name();
- phase := "running benchmark";
- profiling (cpu-time-seconds, cpu-time-microseconds, allocation)
- run-benchmark();
- results
- // Benchmarks pass if they don't crash.
- record-benchmark(name, $passed, #f,
- cpu-time-seconds, cpu-time-microseconds, allocation);
- end profiling;
- end block;
-end function %benchmark;
-
-/// Benchmark recording
-
-define method record-benchmark
- (name :: <string>,
- status :: <result-status>,
- reason :: false-or(<string>),
- seconds :: false-or(<integer>),
- microseconds :: false-or(<integer>),
- bytes-allocated :: false-or(<integer>))
- => (status :: <result-status>)
- let result = make(<benchmark-result>,
- name: name, status: status, reason: reason,
- seconds: seconds, microseconds: microseconds,
- bytes: bytes-allocated);
- *check-recording-function*(result);
- status
-end method record-benchmark;
-
-
-/// A few utilities related to benchmarks
-
-define function time-to-string
- (seconds :: false-or(<integer>), microseconds :: false-or(<integer>),
- #key pad-seconds-to :: false-or(<integer>))
- => (seconds :: <string>)
- if (seconds & microseconds)
- format-to-string("%s.%s",
- integer-to-string(seconds,
- size: pad-seconds-to | 6,
- fill: ' '),
- integer-to-string(microseconds, size: 6))
- else
- "N/A"
- end
-end;
-
-
-// Add two times that are encoded as seconds + microseconds.
-// Assumes the first time is valid. The second time may be #f.
-//
-define method addtimes
- (sec1, usec1, sec2, usec2)
- => (sec, usec)
- if (sec2 & usec2)
- let sec = sec1 + sec2;
- let usec = usec1 + usec2;
- if (usec >= 1000000)
- usec := usec - 1000000;
- sec1 := sec1 + 1;
- end if;
- values(sec, usec)
- else
- values(sec1, sec2)
- end if
-end method addtimes;
View
50 components.dylan
@@ -21,6 +21,7 @@ define class <component> (<object>)
init-keyword: tags:;
end class <component>;
+
define generic component-type-name
(component :: <component>) => (type-name :: <string>);
@@ -29,12 +30,49 @@ define method component-type-name
"component"
end;
+
+// Get the result type for a component. This isn't needed for checks;
+// only for components with subresults.
+define generic component-result-type
+ (component :: <component>) => (result-type :: subclass(<result>));
+
+define method component-result-type
+ (component :: <component>) => (result-type :: subclass(<result>))
+ <component-result>
+end;
+
+define method component-result-type
+ (component :: <test>) => (result-type :: subclass(<result>))
+ <test-result>
+end;
+
+define method component-result-type
+ (component :: <suite>) => (result-type :: subclass(<result>))
+ <suite-result>
+end;
+
+define method component-result-type
+ (component :: <test-unit>) => (result-type :: subclass(<result>))
+ <unit-result>
+end;
+
+
/// Result handling
define class <component-result> (<result>)
constant slot result-subresults :: <sequence> = make(<stretchy-vector>),
init-keyword: subresults:;
+
+ // Profiling data...
+
+ constant slot result-seconds :: false-or(<integer>),
+ required-init-keyword: seconds:;
+ constant slot result-microseconds :: false-or(<integer>),
+ required-init-keyword: microseconds:;
+ // Hopefully no benchmarks will allocate more than 536MB haha...
+ constant slot result-bytes :: false-or(<integer>),
+ required-init-keyword: bytes:;
end class <component-result>;
define class <test-result> (<component-result>)
@@ -99,11 +137,17 @@ define method maybe-execute-component
if (announce-function)
announce-function(component)
end;
- let (subresults, perform-status)
+ let (subresults, status, seconds, microseconds, bytes)
= if (execute-component?(component, options))
execute-component(component, options)
else
- values(#(), $skipped)
+ values(#(), $skipped, 0, 0, 0)
end;
- make-result(component, subresults, perform-status)
+ make(component-result-type(component),
+ name: component.component-name,
+ status: status,
+ subresults: subresults,
+ seconds: seconds,
+ microseconds: microseconds,
+ bytes: bytes)
end method maybe-execute-component;
View
15 library.dylan
@@ -8,9 +8,8 @@ Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define library testworks
use command-line-parser;
- use common-dylan;
- use io;
- use system;
+ use common-dylan, import: { common-dylan, threads };
+ use io, import: { format-out, standard-io, streams };
export testworks;
end library testworks;
@@ -69,9 +68,6 @@ define module testworks
check-instance?,
check-true;
- // Benchmarks
- export benchmark;
-
// Tests
export <test>,
test-definer,
@@ -113,12 +109,7 @@ define module testworks
do-results,
<check-result>,
- <test-unit-result>,
- <benchmark-result>,
- $benchmark-result-divider,
- print-one-benchmark-result,
- print-benchmark-result-header,
- print-benchmark-result-footer;
+ <test-unit-result>;
// Progress functions
export *default-progress-function*,
View
5 report/initialize.dylan
@@ -156,11 +156,6 @@ define method argument-value
value
end method argument-value;
-// ---*** carlg 99-02-12 I think it would be a good idea to change the arguments
-// as follows:
-// -report [all | failures | summary]
-// and the rest can be figured out based on whether one or two log files
-// were specified. No time now though...
define constant $help-format-string =
"Application: %s\n"
"\n"
View
231 reports.dylan
@@ -63,8 +63,10 @@ define method count-results
not-executed := not-executed + 1;
$not-implemented =>
not-implemented := not-implemented + 1;
- otherwise =>
+ $crashed =>
crashes := crashes + 1;
+ otherwise =>
+ error("Invalid result status: %=", result.result-status);
end
end,
result,
@@ -72,194 +74,31 @@ define method count-results
values(passes, failures, not-executed, not-implemented, crashes)
end method count-results;
-/*
-define function sum-benchmark-results
- (result :: <result>)
- => (seconds, microseconds, bytes-allocated)
- let seconds = 0;
- let microseconds = 0;
- let allocation = 0;
- local method sum-benches (result :: <benchmark-result>)
- let sec = result-seconds(result);
- let usec = result-microseconds(result);
- let bytes = result-bytes(result);
- if (sec & usec & bytes)
- microseconds := microseconds + usec;
- if (microseconds >= 1000000)
- microseconds := microseconds - 1000000;
- seconds := seconds + 1;
- end if;
- seconds := seconds + sec;
- allocation := allocation + bytes;
- end if;
- end method;
- do-results(sum-benches, result,
- test: method (result :: <result>) => (b :: <boolean>)
- instance?(result, <benchmark-result>)
- end);
- values((seconds > 0) & seconds,
- (microseconds > 0) & microseconds,
- (allocation > 0) & allocation)
-end function sum-benchmark-results;
-*/
-define constant $benchmark-result-divider
- = " -------------------------------------------------------------------------------";
-
-define method print-benchmark-result-header () => ()
- print-one-benchmark-result("Benchmark", "Time (sec)", "Bytes allocated");
- test-output("%s\n", $benchmark-result-divider);
-end method print-benchmark-result-header;
-
-define method print-one-benchmark-result
- (name :: <string>, time :: <string>, allocation :: <string>) => ()
- local method pad-to (name, columns, align-left?)
- let len = size(name);
- if (len > columns)
- name
- else
- let filler = make(<string>, size: columns - len, fill: ' ');
- if (align-left?)
- concatenate(name, filler)
- else
- concatenate(filler, name)
- end if
- end if
- end method;
- test-output(" %s %s %s\n",
- pad-to(name, 50, #t),
- pad-to(time, 10, #f),
- pad-to(allocation, 12, #f));
-end method print-one-benchmark-result;
-
-define method print-benchmark-result-footer
- (title :: <string>, time :: <string>,
- allocation :: <string>, crashes :: <integer>, #key divider? = #t)
- => ()
- divider? & test-output("%s\n", $benchmark-result-divider);
- print-one-benchmark-result(title, time, allocation);
- if (crashes > 0)
- test-output("\n [*] %d benchmark%s crashed.\n", crashes, plural(crashes));
- end if;
-end method print-benchmark-result-footer;
-
-// ---*** carlg 99-02-17 Currently this displays each test's output in a separate
-// table. It may be preferable to display all benchmarks in a single flat
-// table? It sort of depends on how we expect the benchmarks to be organized...
-define method print-benchmark-results
- (result :: <result>)
- => ()
- let total-seconds = 0;
- let total-microseconds = 0;
- let total-allocation = 0;
- let any-displayed? = #f;
- local method do-one-component (result :: <component-result>) => ()
- let seconds = 0;
- let microseconds = 0;
- let allocation = 0;
- let crashed = 0;
- let header-displayed? = #f;
- local method maybe-display-header () => ()
- if (~header-displayed?)
- header-displayed? := #t;
- any-displayed? := #t;
- test-output("\n %s %s\n",
- result-type-name(result), result-name(result));
- print-benchmark-result-header();
- end if;
- end method;
- local method maybe-display-footer () => ()
- if (header-displayed?)
- print-benchmark-result-footer
- ("Subtotals:",
- time-to-string(seconds, microseconds),
- integer-to-string(allocation),
- crashed);
- let (newsec, newusec) = addtimes(total-seconds, total-microseconds,
- seconds, microseconds);
- total-seconds := newsec;
- total-microseconds := newusec;
- total-allocation := total-allocation + allocation;
- end if;
- end method;
- for (bench in result-subresults(result))
- if (instance?(bench, <benchmark-result>))
- let sec = result-seconds(bench);
- let usec = result-microseconds(bench);
- let bytes = result-bytes(bench);
- let name = result-name(bench);
- let time = result-time(bench);
- let sbytes = result-bytes(bench) & integer-to-string(result-bytes(bench));
- if (result-status(bench) == $passed)
- let (newsec, newusec) = addtimes(seconds, microseconds, sec, usec);
- seconds := newsec;
- microseconds := newusec;
- allocation := allocation + bytes;
- else
- crashed := crashed + 1;
- name := concatenate(name, " [*]");
- time := "N/A";
- sbytes := "N/A";
- end if;
- maybe-display-header();
- print-one-benchmark-result(name, time, sbytes);
- end if;
- end for;
- maybe-display-footer();
- for (subresult in result-subresults(result))
- if (instance?(subresult, <component-result>))
- do-one-component(subresult);
- end if;
- end for;
- end method;
- do-one-component(result);
- if (any-displayed?)
- test-output("\n Totals: %s seconds, %d bytes allocated.\n",
- time-to-string(total-seconds, total-microseconds), total-allocation);
- end if;
-end method print-benchmark-results;
/// Summary generation
-define method print-percentage
- (count :: <integer>, size :: <integer>,
- #key decimal-places = 1) => ()
- case
- size > 0 =>
- let shift = 10; // 10 ^ decimal-places;
- let percentage = ceiling/(count * 100 * shift, size);
- let (integer, remainder) = floor/(percentage, shift);
- test-output("%d.%d%%", integer, floor(remainder));
- otherwise =>
- test-output("100%%");
- end
-end method print-percentage;
-
define method print-result-summary
- (result :: <result>, name :: <string>,
- #key test = always(#t))
+ (result :: <result>, name :: <string>, #key test = always(#t))
=> ()
let (passes, failures, not-executed, not-implemented, crashes)
= count-results(result, test: test);
- let total-results = passes + failures + not-implemented + crashes;
- test-output(" Ran %d %s%s %d passed (",
- total-results,
+ let total = passes + failures + not-implemented + crashes;
+ let percent = 100.0 * if (total = 0)
+ 1
+ else
+ as(<float>, passes) / total
+ end;
+ test-output(" Ran %d %s%s: %d passed (%s%%), %d failed, %d skipped, "
+ "%d not implemented, %d crashed\n",
+ total,
name,
- if (total-results == 1) ": " else "s: " end,
- passes);
- print-percentage(passes, total-results);
- test-output("), %d failed, %d skipped, %d not implemented, %d crashed\n",
+ if (total == 1) "" else "s" end,
+ passes,
+ percent,
failures, not-executed, not-implemented, crashes);
end method print-result-summary;
-define method print-result-class-summary
- (result :: <result>, name :: <string>, class :: <class>) => ()
- print-result-summary(result, name,
- test: method (subresult)
- instance?(subresult, class)
- end)
-end method print-result-class-summary;
-
define method print-result-info
(result :: <result>, #key indent = "", test)
=> ()
@@ -269,7 +108,7 @@ define method print-result-info
test-output("\n%s%s %s",
indent, result.result-name, status-name(result-status));
if (result-status == $passed
- & instance?(result, <benchmark-result>))
+ & instance?(result, <component-result>))
test-output(" in %s seconds with %s bytes allocated.",
result-time(result), result-bytes(result) | "?");
end if
@@ -299,13 +138,18 @@ define method null-report-function (result :: <result>) => ()
#f
end method null-report-function;
-define method summary-report-function (result :: <result>) => ()
- print-benchmark-results(result);
+define method summary-report-function
+ (result :: <result>) => ()
test-output("\n\n%s summary:\n", result-name(result));
- print-result-class-summary(result, "suite", <suite-result>);
- print-result-class-summary(result, "test", <test-result>);
- print-result-class-summary(result, "check", <check-result>);
- print-result-class-summary(result, "benchmark", <benchmark-result>);
+ local method print-class-summary (result, name, class) => ()
+ print-result-summary(result, name,
+ test: method (subresult)
+ instance?(subresult, class)
+ end)
+ end;
+ print-class-summary(result, "suite", <suite-result>);
+ print-class-summary(result, "test", <test-result>);
+ print-class-summary(result, "check", <check-result>);
end method summary-report-function;
define method failures-report-function (result :: <result>) => ()
@@ -370,7 +214,7 @@ define method log-report-function (result :: <result>) => ()
if (reason)
test-output("Reason: %s\n", remove-newlines(reason));
end;
- if (~reason & instance?(result, <benchmark-result>))
+ if (~reason & instance?(result, <test-result>))
test-output("Seconds: %s\nAllocation: %d bytes\n",
result-time(result), result-bytes(result) | 0);
end if;
@@ -420,10 +264,10 @@ define function xml-output-pcdata (text :: <string>) => ()
end iterate;
end function;
-define function do-xml-element (gi :: <string>, body :: <function>) => ()
- test-output("<%s>", gi);
+define function do-xml-element (element-name :: <string>, body :: <function>) => ()
+ test-output("<%s>", element-name);
body();
- test-output("</%s>\n", gi);
+ test-output("</%s>\n", element-name);
end function;
define method do-xml-result-body (result :: <result>) => ();
@@ -441,7 +285,7 @@ define method do-xml-result-body (result :: <check-result>) => ();
end if;
end method;
-define method do-xml-result-body (result :: <benchmark-result>) => ();
+define method do-xml-result-body (result :: <component-result>) => ();
next-method();
do-xml-element("seconds",
method ()
@@ -455,15 +299,10 @@ define method do-xml-result-body (result :: <benchmark-result>) => ();
method ()
test-output("%d", result.result-bytes)
end);
-end method;
-
-define method do-xml-result-body (result :: <component-result>) => ();
- next-method();
- let status = result.result-status;
- if (instance?(status, <error>))
+ if (result.result-reason)
do-xml-element("reason",
method ()
- xml-output-pcdata(safe-error-to-string(status));
+ xml-output-pcdata(result.result-reason);
end);
end if;
do(do-xml-result, result-subresults(result));
View
47 suites.dylan
@@ -179,15 +179,32 @@ end method list-component;
define method execute-component
(suite :: <suite>, options :: <perform-options>)
- => (subresults :: <sequence>, status :: <result-status>)
+ => (subresults :: <sequence>, status :: <result-status>,
+ seconds :: <integer>, microseconds :: <integer>, bytes :: <integer>)
let subresults :: <stretchy-vector> = make(<stretchy-vector>);
+ let seconds :: <integer> = 0;
+ let microseconds :: <integer> = 0;
+ let bytes :: <integer> = 0;
let status
= block ()
suite.suite-setup-function();
for (component in suite.suite-components)
let subresult = maybe-execute-component(component, options);
- add!(subresults, subresult)
- end;
+ add!(subresults, subresult);
+ if (instance?(subresult, <component-result>)
+ & subresult.result-seconds
+ & subresult.result-microseconds)
+ let (sec, usec) = add-times(seconds, microseconds,
+ subresult.result-seconds,
+ subresult.result-microseconds);
+ seconds := sec;
+ microseconds := usec;
+ bytes := bytes + subresult.result-bytes;
+ else
+ test-output("subresult has no profiling info: %s\n",
+ subresult.result-name);
+ end;
+ end for;
case
empty?(subresults) =>
$not-implemented;
@@ -199,18 +216,20 @@ define method execute-component
$passed;
otherwise =>
$failed
- end
+ end case
cleanup
suite.suite-cleanup-function();
- end;
- values(subresults, status)
+ end block;
+ values(subresults, status, seconds, microseconds, bytes)
end method execute-component;
-define method make-result
- (suite :: <suite>, subresults :: <sequence>, status :: <result-status>)
- => (result :: <component-result>)
- make(<suite-result>,
- name: suite.component-name,
- status: status,
- subresults: subresults)
-end method make-result;
+define function add-times
+ (sec1, usec1, sec2, usec2) => (sec, usec)
+ let sec = sec1 + sec2;
+ let usec = usec1 + usec2;
+ if (usec >= 1000000)
+ usec := usec - 1000000;
+ sec1 := sec1 + 1;
+ end if;
+ values(sec, usec)
+end function add-times;
View
84 tests.dylan
@@ -57,28 +57,26 @@ define method result-type-name
"Test-unit"
end;
-define class <benchmark-result> (<unit-result>)
- constant slot result-seconds :: false-or(<integer>),
- required-init-keyword: seconds:;
- constant slot result-microseconds :: false-or(<integer>),
- required-init-keyword: microseconds:;
- // Hopefully no benchmarks will allocated more than 536MB...
- constant slot result-bytes :: false-or(<integer>),
- required-init-keyword: bytes:;
-end;
-
-define method result-type-name
- (result :: <benchmark-result>) => (name :: <string>)
- "Benchmark"
-end;
-
define method result-time
- (result :: <benchmark-result>, #key pad-seconds-to :: false-or(<integer>))
+ (result :: <component-result>, #key pad-seconds-to :: false-or(<integer>))
=> (seconds :: <string>)
- time-to-string(result-seconds(result), result-microseconds(result),
+ time-to-string(result.result-seconds, result.result-microseconds,
pad-seconds-to: pad-seconds-to)
end method result-time;
+define function time-to-string
+ (seconds :: false-or(<integer>), microseconds :: false-or(<integer>),
+ #key pad-seconds-to :: false-or(<integer>))
+ => (seconds :: <string>)
+ if (seconds & microseconds)
+ concatenate(integer-to-string(seconds, size: pad-seconds-to | 1, fill: ' '),
+ ".",
+ integer-to-string(microseconds, size: 6))
+ else
+ "N/A"
+ end
+end function time-to-string;
+
// the test macro
//---*** We could use 'define function' but it doesn't debug as well right now
@@ -178,22 +176,30 @@ end method list-component;
define method execute-component
(test :: <test>, options :: <perform-options>)
=> (subresults :: <sequence>, status :: <result-status>,
- seconds, useconds, bytes)
+ seconds :: <integer>, usec :: <integer>, bytes :: <integer>)
let subresults = make(<stretchy-vector>);
+ let (seconds, microseconds, bytes) = values(0, 0, 0);
let status :: <result-status>
- = dynamic-bind
- (*debug?* = options.perform-debug?,
- *check-recording-function* =
- method (result :: <result>)
- add!(subresults, result);
- options.perform-progress-function(result);
- result
- end,
- *test-unit-options* = options)
- let cond = maybe-trap-errors(test.test-function());
+ = dynamic-bind (*debug?* = options.perform-debug?,
+ *check-recording-function* =
+ method (result :: <result>)
+ add!(subresults, result);
+ options.perform-progress-function(result);
+ result
+ end,
+ *test-unit-options* = options)
+ let cond = #f;
+ profiling (cpu-time-seconds, cpu-time-microseconds, allocation)
+ cond := maybe-trap-errors(test.test-function());
+ results
+ seconds := cpu-time-seconds;
+ microseconds := cpu-time-microseconds;
+ bytes := allocation;
+ end profiling;
case
instance?(cond, <serious-condition>) =>
- cond;
+ // TODO(cgay): Capture the failure reason here.
+ $crashed;
empty?(subresults) & ~test.test-allow-empty? =>
$not-implemented;
every?(method (result :: <unit-result>) => (passed? :: <boolean>)
@@ -205,27 +211,9 @@ define method execute-component
$failed
end
end;
- values(subresults, status)
+ values(subresults, status, seconds, microseconds, bytes)
end method execute-component;
-define method make-result
- (test :: <test>, subresults :: <sequence>, status :: <result-status>)
- => (result :: <component-result>)
- make(<test-result>,
- name: test.component-name,
- status: status,
- subresults: subresults)
-end method make-result;
-
-define method make-result
- (test :: <test-unit>, subresults :: <sequence>, status :: <result-status>)
- => (result :: <component-result>)
- make(<test-unit-result>,
- name: test.component-name,
- status: status,
- subresults: subresults)
-end method make-result;
-
/// Some progress functions
define method null-progress-function
View
18 testworks.dylan
@@ -56,23 +56,10 @@ define open generic result-type-name
define method \=
(result1 :: <result>, result2 :: <result>)
=> (equal? :: <boolean>)
- // We want to know if two error messages are the same, so that "crashed"
- // tests aren't always presented as differences. However, \= isn't
- // specialized on <error>, so we create our own test:
- local method same-error-message?
- (s1 :: <object>, s2 :: <object>)
- => (same? :: <boolean>)
- instance?(s1, <simple-error>)
- & instance?(s2, <simple-error>)
- & format-to-string(condition-format-string(s1),
- condition-format-arguments(s1))
- = format-to-string(condition-format-string(s2),
- condition-format-arguments(s2));
- end method same-error-message?;
result1.result-name = result2.result-name
& (result1.result-status = result2.result-status
- | same-error-message?(result1.result-status, result2.result-status))
-end method \=;
+ | result1.result-reason = result2.result-reason)
+end;
///*** State Variables ***///
@@ -153,4 +140,3 @@ define open class <perform-options> (<object>)
slot perform-debug? = *debug?*,
init-keyword: debug?:;
end class <perform-options>;
-
View
1  testworks.lid
@@ -6,7 +6,6 @@ Files: library
testworks
components
checks
- benchmarks
tests
suites
reports
Please sign in to comment.
Something went wrong with that request. Please try again.