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";
426 if (-s "output/$test/make.err") {
428 $details{$test} = snarf ("output/$test/make.err");
429 return "make failed. Error messages at end of file.";
431 die "$outfile: missing test output file";
433 my (@output) = snarf ($outfile);
435 # If there's a function "grade_$test", use it to evaluate the output.
436 # If there's a file "$GRADES_DIR/$test.exp", compare its contents
437 # against the output.
438 # (If both exist, prefer the function.)
440 # If the test was successful, it returns normally.
441 # If it failed, it invokes `die' with an error message terminated
442 # by a new-line. The message will be given as an explanation in
443 # the output file tests.out.
444 # (Internal errors will invoke `die' without a terminating
445 # new-line, in which case we detect it and propagate the `die'
447 my ($grade_func) = "grade_$test";
448 $grade_func =~ s/-/_/g;
449 if (-e "$GRADES_DIR/$test.exp" && !defined (&$grade_func)) {
451 verify_common (@output);
452 compare_output ("$GRADES_DIR/$test.exp", @output);
455 eval "$grade_func (\@output)";
458 die $@ if $@ =~ /at \S+ line \d+$/;
465 # Combines grade.txt, tests.out, review.txt, and details.out,
466 # producing grade.out.
467 sub assemble_final_grade {
468 open (OUT, ">grade.out") or die "grade.out: create: $!\n";
470 open (GRADE, "<grade.txt") or die "grade.txt: open: $!\n";
477 my (@tests) = snarf ("tests.out");
478 my ($p_got, $p_pos) = $tests[0] =~ m%\((\d+)/(\d+)\)% or die;
480 my (@review) = snarf ("review.txt");
481 my ($part_lost) = (0, 0);
482 for (my ($i) = $#review; $i >= 0; $i--) {
483 local ($_) = $review[$i];
484 if (my ($loss) = /^\s*([-+]\d+)/) {
486 } elsif (my ($out_of) = m%\[\[/(\d+)\]\]%) {
487 my ($got) = $out_of + $part_lost;
488 $got = 0 if $got < 0;
489 $review[$i] =~ s%\[\[/\d+\]\]%($got/$out_of)% or die;
496 die "Lost points outside a section\n" if $part_lost;
498 for (my ($i) = 1; $i <= $#review; $i++) {
499 if ($review[$i] =~ /^-{3,}\s*$/ && $review[$i - 1] !~ /^\s*$/) {
500 $review[$i] = '-' x (length ($review[$i - 1]));
504 print OUT "\nOVERALL SCORE\n";
505 print OUT "-------------\n";
506 print OUT "$p_got points out of $p_pos total\n\n";
508 print OUT map ("$_\n", @tests), "\n";
509 print OUT map ("$_\n", @review), "\n";
511 print OUT "DETAILS\n";
512 print OUT "-------\n\n";
513 print OUT map ("$_\n", snarf ("details.out"));
516 # Clean up our generated files.
518 # Verify that we're roughly in the correct directory
519 # before we go blasting away files.
522 # Blow away everything.
523 xsystem ("rm -rf output pintos", VERBOSE => 1);
524 xsystem ("rm -f details.out tests.out", VERBOSE => 1);
527 # Provided a test's output as an array, verifies that it, in general,
528 # looks sensible; that is, that there are no PANIC or FAIL messages,
529 # that Pintos started up and shut down normally, and so on.
530 # Die if something odd found.
534 die "No output at all\n" if @output == 0;
536 look_for_panic (@output);
537 look_for_fail (@output);
538 look_for_triple_fault (@output);
540 die "Didn't start up properly: no \"Pintos booting\" startup message\n"
541 if !grep (/Pintos booting with.*kB RAM\.\.\./, @output);
542 die "Didn't start up properly: no \"Boot complete\" startup message\n"
543 if !grep (/Boot complete/, @output);
544 die "Didn't shut down properly: no \"Timer: # ticks\" shutdown message\n"
545 if !grep (/Timer: \d+ ticks/, @output);
546 die "Didn't shut down properly: no \"Powering off\" shutdown message\n"
547 if !grep (/Powering off/, @output);
553 my ($panic) = grep (/PANIC/, @output);
554 return unless defined $panic;
556 my ($details) = "Kernel panic:\n $panic\n";
558 my (@stack_line) = grep (/Call stack:/, @output);
559 if (@stack_line != 0) {
560 $details .= " $stack_line[0]\n\n";
561 $details .= "Translation of backtrace:\n";
562 my (@addrs) = $stack_line[0] =~ /Call stack:((?: 0x[0-9a-f]+)+)/;
566 =~ /i.86|pentium.*|[pk][56]|nexgen|viac3|6x86|athlon.*/) {
569 $A2L = "i386-elf-addr2line";
572 if ($hw eq 'threads') {
573 $kernel_o = "output/$test/kernel.o";
575 $kernel_o = "pintos/src/$hw/build/kernel.o";
577 open (A2L, "$A2L -fe $kernel_o @addrs|");
579 my ($function, $line);
580 last unless defined ($function = <A2L>);
584 $details .= " $function ($line)\n";
588 if ($panic =~ /sec_no < d->capacity/) {
590 \nThis assertion commonly fails when accessing a file via an inode that
591 has been closed and freed. Freeing an inode clears all its sector
592 indexes to 0xcccccccc, which is not a valid sector number for disks
593 smaller than about 1.6 TB.
597 $extra{$test} = $details;
598 die "Kernel panic. Details at end of file.\n";
604 my ($failure) = grep (/FAIL/, @output);
605 return unless defined $failure;
607 # Eliminate uninteresting header and trailer info if possible.
608 # The `eval' catches the `die' from get_core_output() in the "not
611 my (@core) = get_core_output (@output);
612 $details{$test} = "Program output:\n\n" . join ('', map ("$_\n", @core));
615 # Most output lines are prefixed by (test-name). Eliminate this
616 # from our `die' message for brevity.
617 $failure =~ s/^\([^\)]+\)\s+//;
618 die "$failure. Details at end of file.\n";
621 sub look_for_triple_fault {
624 return unless grep (/Pintos booting/, @output) > 1;
626 my ($details) = <<EOF;
627 Pintos spontaneously rebooted during this test. This is most often
628 due to unhandled page faults. Output from initial boot through the
629 first reboot is shown below:
637 last if /Pintos booting/ && ++$i > 1;
639 $details{$test} = $details;
640 die "Triple-fault caused spontaneous reboot(s). "
641 . "Details at end of file.\n";
644 # Get @output without header or trailer.
645 # Die if not possible.
646 sub get_core_output {
650 for ($first = 0; $first <= $#output; $first++) {
651 my ($line) = $output[$first];
653 if ($hw ne 'threads' && $line =~ /^Executing '$test.*':$/)
655 && grep (/^Boot complete.$/, @output[0...$first - 1])
656 && $line =~ /^\s*$/);
660 for ($last = $#output; $last >= 0; $last--) {
661 $last--, last if $output[$last] =~ /^Timer: \d+ ticks$/;
664 if ($last < $first) {
665 my ($no_first) = $first > $#output;
666 my ($no_last) = $last < $#output;
667 die "Couldn't locate output.\n";
670 return @output[$first ... $last];
673 sub canonicalize_exit_codes {
676 # Exit codes are supposed to be printed in the form "process: exit(code)"
677 # but people get unfortunately creative with it.
678 for my $i (0...$#output) {
679 local ($_) = $output[$i];
681 my ($process, $code);
682 if ((($process, $code) = /^([-a-z0-9 ]+):.*[ \(](-?\d+)\b\)?$/)
683 || (($process, $code) = /^([-a-z0-9 ]+) exit\((-?\d+)\)$/)
684 || (($process, $code)
685 = /^([-a-z0-9 ]+) \(.*\): exit\((-?\d+)\)$/)
686 || (($process, $code) = /^([-a-z0-9 ]+):\( (-?\d+) \) $/)
687 || (($code, $process) = /^shell: exit\((-?\d+)\) \| ([-a-z0-9]+)/))
689 # We additionally truncate to 15 character and strip all
690 # but the first word.
691 $process = substr ($process, 0, 15);
692 $process =~ s/\s.*//;
693 $output[$i] = "$process: exit($code)\n";
700 sub strip_exit_codes {
701 return grep (!/^[-a-z0-9]+: exit\(-?\d+\)/, canonicalize_exit_codes (@_));
705 my ($exp, @actual) = @_;
707 # Canonicalize output for comparison.
708 @actual = get_core_output (map ("$_\n", @actual));
709 if ($hw eq 'userprog') {
710 @actual = canonicalize_exit_codes (@actual);
711 } elsif ($hw eq 'vm' || $hw eq 'filesys') {
712 @actual = strip_exit_codes (@actual);
715 # There *was* some output, right?
716 die "Program produced no output.\n" if !@actual;
718 # Read expected output.
719 my (@exp) = map ("$_\n", snarf ($exp));
721 # Pessimistically, start preparation of detailed failure message.
723 $details .= "$test actual output:\n";
724 $details .= join ('', map (" $_", @actual));
726 # Set true when we find expected output that matches our actual
727 # output except for some extra actual output (that doesn't seem to
728 # be an error message etc.).
729 my ($fuzzy_match) = 0;
731 # Compare actual output against each allowed output.
733 # Grab one set of allowed output from @exp into @expected.
736 my ($s) = shift (@exp);
737 last if $s eq "--OR--\n";
738 push (@expected, $s);
741 $details .= "\n$test acceptable output:\n";
742 $details .= join ('', map (" $_", @expected));
744 # Check whether actual and expected match.
745 # If it's a perfect match, return.
746 if ($#actual == $#expected) {
748 for (my ($i) = 0; $i <= $#expected; $i++) {
749 $eq = 0 if $actual[$i] ne $expected[$i];
754 # They differ. Output a diff.
756 my ($d) = Algorithm::Diff->new (\@expected, \@actual);
757 my ($not_fuzzy_match) = 0;
758 while ($d->Next ()) {
759 my ($ef, $el, $af, $al) = $d->Get (qw (min1 max1 min2 max2));
761 push (@diff, map (" $_", $d->Items (1)));
763 push (@diff, map ("- $_", $d->Items (1))) if $d->Items (1);
764 push (@diff, map ("+ $_", $d->Items (2))) if $d->Items (2);
766 || grep (/\($test\)|exit\(-?\d+\)|dying due to|Page fault/,
768 $not_fuzzy_match = 1;
773 # If we didn't find anything that means it's not,
774 # it's a fuzzy match.
775 $fuzzy_match = 1 if !$not_fuzzy_match;
777 $details .= "Differences in `diff -u' format:\n";
778 $details .= join ('', @diff);
779 $details .= "(This is considered a `fuzzy match'.)\n"
780 if !$not_fuzzy_match;
783 # Failed to match. Report failure.
786 "This test passed, but with extra, unexpected output.\n"
787 . "Please inspect your code to make sure that it does not\n"
788 . "produce output other than as specified in the project\n"
793 "This test failed because its output did not match any\n"
794 . "of the acceptable form(s).\n\n"
798 $details{$test} = $details;
799 die "Output differs from expected. Details at end of file.\n"
803 # Reads and returns the contents of the specified file.
804 # In an array context, returns the file's contents as an array of
805 # lines, omitting new-lines.
806 # In a scalar context, returns the file's contents as a single string.
809 open (OUTPUT, $file) or die "$file: open: $!\n";
810 my (@lines) = <OUTPUT>;
813 return wantarray ? @lines : join ('', map ("$_\n", @lines));
816 # Returns true if the two specified files are byte-for-byte identical,
821 open (A, "<$a") or die "$a: open: $!\n";
822 open (B, "<$b") or die "$b: open: $!\n";
828 sysread (A, $sa, 1024);
829 sysread (B, $sb, 1024);
830 $equal = 0, last if $sa ne $sb;
831 $equal = 1, last if $sa eq '';
839 # Returns true if the specified file is byte-for-byte identical with
840 # the specified string.
842 my ($file, $expected) = @_;
843 open (FILE, "<$file") or die "$file: open: $!\n";
845 sysread (FILE, $actual, -s FILE);
846 my ($equal) = $actual eq $expected;
852 for my $test (@TESTS) {
853 return 1 if !defined ($result{$test}) || $result{$test} ne 'ok';