16 use Getopt::Long qw(:config no_ignore_case);
19 # We execute lots of subprocesses.
20 # Without this, our stdout output can get flushed multiple times,
21 # which is harmless but looks bizarre.
25 my ($do_regex, $no_regex);
26 GetOptions ("v|verbose+" => \$verbose,
27 "h|help" => sub { usage (0) },
28 "d|do-tests=s" => \$do_regex,
29 "n|no-tests=s" => \$no_regex,
30 "c|clean" => sub { set_action ('clean'); },
31 "x|extract" => sub { set_action ('extract'); },
32 "b|build" => sub { set_action ('build'); },
33 "t|test" => sub { set_action ('test'); },
34 "a|assemble" => sub { set_action ('assemble'); })
35 or die "Malformed command line; use --help for help.\n";
36 die "Non-option arguments not supported; use --help for help.\n"
38 @TESTS = split(/,/, join (',', @TESTS)) if defined @TESTS;
40 if (!defined $action) {
41 $action = -e 'review.txt' ? 'assemble' : 'test';
44 my (@default_tests) = @_;
45 @TESTS = @default_tests;
46 @TESTS = grep (/$do_regex/, @TESTS) if defined $do_regex;
47 @TESTS = grep (!/$no_regex/, @TESTS) if defined $no_regex;
51 my ($new_action) = @_;
52 die "actions `$action' and `$new_action' conflict\n"
53 if defined ($action) && $action ne $new_action;
54 $action = $new_action;
60 run-tests, for grading Pintos $hw projects.
62 Invoke from a directory containing a student tarball named by
63 the submit script, e.g. username.MMM.DD.YY.hh.mm.ss.tar.gz.
67 1. Extracts the source tree into pintos/src and applies patches.
69 2. Builds the source tree. (The threads project modifies and rebuilds
70 the source tree for every test.)
72 3. Runs the tests on the source tree and grades them. Writes
73 "tests.out" with a summary of the test results, and "details.out"
74 with test failure and warning details.
76 4. By hand, copy "review.txt" from the tests directory and use it as a
77 template for grading design documents.
79 5. Assembles "grade.txt", "tests.out", "review.txt", and "tests.out"
80 into "grade.out". This is primarily simple concatenation, but
81 point totals are tallied up as well.
84 -c, --clean Delete test results and temporary files, then exit.
85 -d, --do-tests=RE Run only tests that match the given regular expression.
86 -n, --no-tests=RE Do not run tests that match the given regular expression.
87 -x, --extract Stop after step 1.
88 -b, --build Stop after step 2.
89 -t, --test Stop after step 3 (default if "review.txt" not present).
90 -a, --assemble Stop after step 5 (default if "review.txt" exists).
91 -v, --verbose Print command lines of subcommands before executing them.
92 -h, --help Print this help message.
99 # Extracts the group's source files into pintos/src,
100 # applies any patches providing in the grading directory,
101 # and installs a default pintos/src/constants.h
102 sub extract_sources {
103 # Make sure the output dir exists.
104 -d ("output") || mkdir ("output") or die "output: mkdir: $!\n";
106 # Nothing else to do if we already have a source tree.
107 return if -d "pintos";
109 my ($tarball) = choose_tarball ();
112 print "Creating pintos/src...\n";
113 mkdir "pintos" or die "pintos: mkdir: $!\n";
114 mkdir "pintos/src" or die "pintos/src: mkdir: $!\n";
116 print "Extracting $tarball into pintos/src...\n";
117 xsystem ("cd pintos/src && tar xzf ../../$tarball",
118 DIE => "extraction failed\n");
120 # Run custom script for this submission, if provided.
122 print "Running fixme.sh...\n";
123 xsystem ("sh -e fixme.sh", DIE => "fix script failed\n");
125 print "No fixme.sh, assuming no custom changes needed.\n";
128 # Apply patches from grading directory.
129 # Patches are applied in lexicographic order, so they should
130 # probably be named 00debug.patch, 01bitmap.patch, etc.
131 # Filenames in patches should be in the format pintos/src/...
132 print "Patching...\n";
133 for my $patch (glob ("$GRADES_DIR/patches/*.patch")) {
135 ($stem = $patch) =~ s%^$GRADES_DIR/patches/%% or die;
136 print "Applying $patch...\n";
137 xsystem ("patch -fs -p0 < $patch",
138 LOG => $stem, DIE => "applying patch $stem failed\n");
141 # Install default pintos/src/constants.h.
142 open (CONSTANTS, ">pintos/src/constants.h")
143 or die "constants.h: create: $!\n";
144 print CONSTANTS "#define THREAD_JOIN_IMPLEMENTED 1\n";
148 # Returns the name of the tarball to extract.
151 = grep (/^[a-z0-9]+\.[A-Za-z]+\.\d+\.\d+\.\d+\.\d+.\d+\.tar\.gz$/,
153 die "no pintos dir, no files matching username.MMM.DD.YY.hh.mm.ss.tar.gz\n"
154 if scalar (@tarballs) == 0;
157 # Sort tarballs in order by time.
158 @tarballs = sort { ext_mdyHMS ($a) cmp ext_mdyHMS ($b) } @tarballs;
160 print "Multiple tarballs:\n";
161 print "\t$_ submitted ", ext_mdyHMS ($_), "\n" foreach @tarballs;
162 print "Choosing $tarballs[$#tarballs]\n";
164 return $tarballs[$#tarballs];
167 # Extract the date within a tarball name into a string that compares
168 # lexicographically in chronological order.
171 my ($ms, $d, $y, $H, $M, $S) =
172 $s =~ /.([A-Za-z]+)\.(\d+)\.(\d+)\.(\d+)\.(\d+).(\d+)\.tar\.gz$/
174 my ($m) = index ("janfebmaraprmayjunjulaugsepoctnovdec", lc $ms) / 3
176 return sprintf "%02d-%02d-%02d %02d:%02d:%02d", $y, $m, $d, $H, $M, $S;
182 print "Compiling...\n";
183 xsystem ("cd pintos/src/$hw && make", LOG => "make") eq 'ok'
184 or return "Build error";
187 # Run and grade the tests.
188 sub run_and_grade_tests {
191 my ($result) = get_test_result ();
194 my ($grade) = grade_test ($test);
197 my ($msg) = $result eq 'ok' ? $grade : "$result - $grade";
198 $msg .= " - with warnings"
199 if $grade eq 'ok' && defined $details{$test};
202 $result{$test} = $grade;
206 # Write test grades to tests.out.
208 my (@summary) = snarf ("$GRADES_DIR/tests.txt");
214 for (my ($i) = 0; $i <= $#summary; $i++) {
215 local ($_) = $summary[$i];
216 if (my ($loss, $test) = /^ -(\d+) ([-a-zA-Z0-9]+):/) {
217 my ($result) = $result{$test} || "Not tested.";
219 if ($result eq 'ok') {
220 if (!defined $details{$test}) {
221 # Test successful and no warnings.
222 splice (@summary, $i, 1);
225 # Test successful with warnings.
228 splice (@summary, $i + 1, 0,
229 " Test passed with warnings. "
230 . "Details at end of file.");
236 splice (@summary, $i + 1, 0,
237 map (" $_", split ("\n", $result)));
239 } elsif (my ($ptotal) = /^Score: \/(\d+)$/) {
241 $summary[$i] = "Score: " . ($ptotal - $ploss) . "/$ptotal";
242 splice (@summary, $i, 0, " All tests passed.")
243 if $ploss == 0 && !$warnings;
249 my ($ts) = "(" . ($total - $tloss) . "/" . $total . ")";
250 $summary[0] =~ s/\[\[total\]\]/$ts/;
252 open (SUMMARY, ">tests.out");
253 print SUMMARY map ("$_\n", @summary);
257 # Write failure and warning details to details.out.
259 open (DETAILS, ">details.out");
262 next if $result{$test} eq 'ok' && !defined $details{$test};
264 my ($details) = $details{$test};
265 next if !defined ($details) && ! -e "output/$test/run.out";
268 if ($result{$test} ne 'ok') {
269 $banner = "$test failure details";
271 $banner = "$test warnings";
274 print DETAILS "\n" if $n++;
275 print DETAILS "--- $banner ", '-' x (50 - length ($banner));
276 print DETAILS "\n\n";
278 if (!defined $details) {
279 my (@output) = snarf ("output/$test/run.out");
281 # Print only the first in a series of recursing panics.
283 for my $i (0...$#output) {
284 local ($_) = $output[$i];
285 if (/PANIC/ && $panic++ > 0) {
286 @output = @output[0...$i];
288 "[...details of recursive panic(s) omitted...]");
292 $details = "Output:\n\n" . join ('', map ("$_\n", @output));
294 print DETAILS $details;
296 print DETAILS "\n", "-" x 10, "\n\n$extra{$test}"
297 if defined $extra{$test};
303 my ($command, %options) = @_;
304 print "$command\n" if $verbose || $options{VERBOSE};
306 my ($log) = $options{LOG};
310 local $SIG{ALRM} = sub { die "alarm\n" };
311 alarm $options{TIMEOUT} if defined $options{TIMEOUT};
313 die "fork: $!\n" if !defined $pid;
316 open (STDOUT, ">output/$log.out");
317 open (STDERR, ">output/$log.err");
319 chdir $options{CHDIR} or die "$options{CHDIR}: chdir: $!\n"
320 if defined ($options{CHDIR});
321 if (!defined ($options{EXEC})) {
324 exec (@{$options{EXEC}});
335 die unless $@ eq "alarm\n"; # propagate unexpected errors
337 for ($i = 0; $i < 10; $i++) {
338 kill ('SIGTERM', $pid);
340 my ($retval) = waitpid ($pid, WNOHANG);
341 last if $retval == $pid || $retval == -1;
342 print "Timed out - Waiting for $pid to die" if $i == 0;
348 if (WIFSIGNALED ($status)) {
349 my ($signal) = WTERMSIG ($status);
350 die "Interrupted\n" if $signal == SIGINT;
351 print "Child terminated with signal $signal\n";
354 $result = $status == 0 ? "ok" : "error";
357 if ($result eq 'error' && defined $options{DIE}) {
358 my ($msg) = $options{DIE};
359 if (defined ($log)) {
361 $msg .= "; see output/$log.err and output/$log.out for details\n";
364 } elsif ($result ne 'error' && defined ($log)) {
365 unlink ("output/$log.err");
371 sub get_test_result {
372 my ($cache_file) = "output/$test/run.result";
373 # Reuse older results if any.
374 if (open (RESULT, "<$cache_file")) {
382 # If there's residue from an earlier test, move it to .old.
383 # If there's already a .old, delete it.
384 xsystem ("rm -rf output/$test.old", VERBOSE => 1) if -d "output/$test.old";
385 rename "output/$test", "output/$test.old" or die "rename: $!\n"
386 if -d "output/$test";
388 # Make output directory.
389 mkdir "output/$test";
392 my ($result) = run_test ($test);
394 # Delete any disks in the output directory because they take up
396 unlink (glob ("output/$test/*.dsk"));
398 # Save the results for later.
399 open (DONE, ">$cache_file") or die "$cache_file: create: $!\n";
400 print DONE "$result\n";
407 my ($cmd_line, %args) = @_;
408 unshift (@$cmd_line, 'pintos');
409 my ($retval) = xsystem (join (' ', @$cmd_line), %args, EXEC => $cmd_line);
410 return 'ok' if $retval eq 'ok';
411 if ($retval eq 'timeout') {
412 my ($msg) = "Timed out after $args{TIMEOUT} seconds";
413 my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
414 $msg .= " - $load_avg" if defined $load_avg;
417 return 'Error running Bochs' if $retval eq 'error';
424 my ($outfile) = "output/$test/run.out";
425 die "$outfile: missing test output file (make failed?)" if ! -e $outfile;
426 my (@output) = snarf ($outfile);
428 # If there's a function "grade_$test", use it to evaluate the output.
429 # If there's a file "$GRADES_DIR/$test.exp", compare its contents
430 # against the output.
431 # (If both exist, prefer the function.)
433 # If the test was successful, it returns normally.
434 # If it failed, it invokes `die' with an error message terminated
435 # by a new-line. The message will be given as an explanation in
436 # the output file tests.out.
437 # (Internal errors will invoke `die' without a terminating
438 # new-line, in which case we detect it and propagate the `die'
440 my ($grade_func) = "grade_$test";
441 $grade_func =~ s/-/_/g;
442 if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
444 verify_common (@output);
445 compare_output ("$GRADES_DIR/$test.exp", @output);
448 eval "$grade_func (\@output)";
451 die $@ if $@ =~ /at \S+ line \d+$/;
458 # Combines grade.txt, tests.out, review.txt, and details.out,
459 # producing grade.out.
460 sub assemble_final_grade {
461 open (OUT, ">grade.out") or die "grade.out: create: $!\n";
463 open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
470 my (@tests) = snarf ("tests.out");
471 my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
473 my (@review) = snarf ("review.txt");
474 my ($part_lost) = (0, 0);
475 for (my ($i) = $#review; $i >= 0; $i--) {
476 local ($_) = $review[$i];
477 if (my ($loss) = /^\s*([-+]\d+)/) {
479 } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
480 my ($got) = $out_of + $part_lost;
481 $got = 0 if $got < 0;
482 $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
489 die "Lost points outside a section\n" if $part_lost;
491 for (my ($i) = 1; $i <= $#review; $i++) {
492 if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
493 $review[$i] = '-' x (length ($review[$i - 1]));
497 print OUT "\nOVERALL SCORE\n";
498 print OUT "-------------\n";
499 print OUT "$p_got points out of $p_pos total\n\n";
501 print OUT map ("$_\n", @tests), "\n";
502 print OUT map ("$_\n", @review), "\n";
504 print OUT "DETAILS\n";
505 print OUT "-------\n\n";
506 print OUT map ("$_\n", snarf ("details.out"));
509 # Clean up our generated files.
511 # Verify that we're roughly in the correct directory
512 # before we go blasting away files.
515 # Blow away everything.
516 xsystem ("rm -rf output pintos", VERBOSE => 1);
517 xsystem ("rm -f details.out tests.out", VERBOSE => 1);
520 # Provided a test's output as an array, verifies that it, in general,
521 # looks sensible; that is, that there are no PANIC or FAIL messages,
522 # that Pintos started up and shut down normally, and so on.
523 # Die if something odd found.
527 die "No output at all\n" if @output == 0;
529 look_for_panic (@output);
530 look_for_fail (@output);
531 look_for_triple_fault (@output);
533 die "Didn't start up properly: no \"Pintos booting\" startup message\n"
534 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
535 die "Didn't start up properly: no \"Boot complete\" startup message\n"
536 if !grep (/Boot complete/, @output);
537 die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
538 if !grep (/Timer: \d+ ticks/, @output);
539 die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
540 if !grep (/Powering off/, @output);
546 my ($panic) = grep (/PANIC/, @output);
547 return unless defined $panic;
549 my ($details) = "Kernel panic:\n $panic\n";
551 my (@stack_line) = grep (/Call stack:/, @output);
552 if (@stack_line != 0) {
553 $details .= " $stack_line[0]\n\n";
554 $details .= "Translation of backtrace:\n";
555 my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
559 =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
562 $A2L = "i386-elf-addr2line";
565 if ($hw eq 'threads') {
566 $kernel_o = "output/$test/kernel.o";
568 $kernel_o = "pintos/src/$hw/build/kernel.o";
570 open (A2L, "$A2L -fe $kernel_o @addrs|");
572 my ($function, $line);
573 last unless defined ($function = <A2L>);
577 $details .= " $function ($line)\n";
581 if ($panic =~ /sec_no < d->capacity/) {
583 \nThis assertion commonly fails when accessing a file via an inode that
584 has been closed and freed. Freeing an inode clears all its sector
585 indexes to 0xcccccccc, which is not a valid sector number for disks
586 smaller than about 1.6 TB.
590 $extra{$test} = $details;
591 die "Kernel panic. Details at end of file.\n";
597 my ($failure) = grep (/FAIL/, @output);
598 return unless defined $failure;
600 # Eliminate uninteresting header and trailer info if possible.
601 # The `eval' catches the `die' from get_core_output() in the "not
604 my (@core) = get_core_output (@output);
605 $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
608 # Most output lines are prefixed by (test-name). Eliminate this
609 # from our `die' message for brevity.
610 $failure =~ s/^\([^\)]+\)\s+//;
611 die "$failure. Details at end of file.\n";
614 sub look_for_triple_fault {
617 return unless grep (/Pintos booting/, @output) > 1;
619 my ($details) = <<EOF;
620 Pintos spontaneously rebooted during this test. This is most often
621 due to unhandled page faults. Output from initial boot through the
622 first reboot is shown below:
630 last if /Pintos booting/ && ++$i > 1;
632 $details{$test} = $details;
633 die "Triple-fault caused spontaneous reboot(s). "
634 . "Details at end of file.\n";
637 # Get @output without header or trailer.
638 # Die if not possible.
639 sub get_core_output {
643 for ($first = 0; $first <= $#output; $first++) {
644 my ($line) = $output[$first];
646 if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
648 && grep (/^Boot complete.$/, @output[0...$first - 1])
649 && $line =~ /^\s*$/);
653 for ($last = $#output; $last >= 0; $last--) {
654 $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
657 if ($last < $first) {
658 my ($no_first) = $first > $#output;
659 my ($no_last) = $last < $#output;
660 die "Couldn't locate output.\n";
663 return @output[$first ... $last];
666 sub canonicalize_exit_codes {
669 # Exit codes are supposed to be printed in the form "process: exit(code)"
670 # but people get unfortunately creative with it.
671 for my $i (0...$#output) {
672 local ($_) = $output[$i];
674 my ($process, $code);
675 if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
676 || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
677 || (($process, $code)
678 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
679 || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
680 || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
682 # We additionally truncate to 15 character and strip all
683 # but the first word.
684 $process = substr ($process, 0, 15);
685 $process =~ s/\s.*//;
686 $output[$i] = "$process: exit($code)\n";
693 sub strip_exit_codes {
694 return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
698 my ($exp, @actual) = @_;
700 # Canonicalize output for comparison.
701 @actual = get_core_output (map ("$_\n", @actual));
702 if ($hw eq 'userprog') {
703 @actual = canonicalize_exit_codes (@actual);
704 } elsif ($hw eq 'vm' || $hw eq 'filesys') {
705 @actual = strip_exit_codes (@actual);
708 # There *was* some output, right?
709 die "Program produced no output.\n" if !@actual;
711 # Read expected output.
712 my (@exp) = map ("$_\n", snarf ($exp));
714 # Pessimistically, start preparation of detailed failure message.
716 $details .= "$test actual output:\n";
717 $details .= join ('', map (" $_", @actual));
719 # Set true when we find expected output that matches our actual
720 # output except for some extra actual output (that doesn't seem to
721 # be an error message etc.).
722 my ($fuzzy_match) = 0;
724 # Compare actual output against each allowed output.
726 # Grab one set of allowed output from @exp into @expected.
729 my ($s) = shift (@exp);
730 last if $s eq "--OR--\n";
731 push (@expected, $s);
734 $details .= "\n$test acceptable output:\n";
735 $details .= join ('', map (" $_", @expected));
737 # Check whether actual and expected match.
738 # If it's a perfect match, return.
739 if ($#actual == $#expected) {
741 for (my ($i) = 0; $i <= $#expected; $i++) {
742 $eq = 0 if $actual[$i] ne $expected[$i];
747 # They differ. Output a diff.
749 my ($d) = Algorithm::Diff->new (\@expected, \@actual);
750 my ($not_fuzzy_match) = 0;
751 while ($d->Next ()) {
752 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
754 push (@diff, map (" $_", $d->Items (1)));
756 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
757 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
759 || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
761 $not_fuzzy_match = 1;
766 # If we didn't find anything that means it's not,
767 # it's a fuzzy match.
768 $fuzzy_match = 1 if !$not_fuzzy_match;
770 $details .= "Differences in `diff -u' format:\n";
771 $details .= join ('', @diff);
772 $details .= "(This is considered a `fuzzy match'.)\n"
773 if !$not_fuzzy_match;
776 # Failed to match. Report failure.
779 "This test passed, but with extra, unexpected output.\n"
780 . "Please inspect your code to make sure that it does not\n"
781 . "produce output other than as specified in the project\n"
786 "This test failed because its output did not match any\n"
787 . "of the acceptable form(s).\n\n"
791 $details{$test} = $details;
792 die "Output differs from expected. Details at end of file.\n"
796 # Reads and returns the contents of the specified file.
797 # In an array context, returns the file's contents as an array of
798 # lines, omitting new-lines.
799 # In a scalar context, returns the file's contents as a single string.
802 open (OUTPUT, $file) or die "$file: open: $!\n";
803 my (@lines) = <OUTPUT>;
806 return wantarray ? @lines : join ('', map ("$_\n", @lines));
809 # Returns true if the two specified files are byte-for-byte identical,
814 open (A, "<$a") or die "$a: open: $!\n";
815 open (B, "<$b") or die "$b: open: $!\n";
821 sysread (A, $sa, 1024);
822 sysread (B, $sb, 1024);
823 $equal = 0, last if $sa ne $sb;
824 $equal = 1, last if $sa eq '';
832 # Returns true if the specified file is byte-for-byte identical with
833 # the specified string.
835 my ($file, $expected) = @_;
836 open (FILE, "<$file") or die "$file: open: $!\n";
838 sysread (FILE, $actual, -s FILE);
839 my ($equal) = $actual eq $expected;
845 for my $test (@TESTS) {
846 return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';