pintos-os.org Git - pintos-anon/blob - src/utils/pintos

   1 #! /usr/bin/perl -w
   2
   3 use strict;
   4 use POSIX;
   5 use Fcntl;
   6 use File::Temp 'tempfile';
   7 use Getopt::Long qw(:config bundling);
   8
   9 # Command-line options.
  10 our ($start_time) = time ();
  11 our ($sim);                     # Simulator: bochs, qemu, or player.
  12 our ($debug) = "none";          # Debugger: none, monitor, or gdb.
  13 our ($mem) = 4;                 # Physical RAM in MB.
  14 our ($serial) = 1;              # Use serial port for input and output?
  15 our ($vga);                     # VGA output: window, terminal, or none.
  16 our ($jitter);                  # Seed for random timer interrupts, if set.
  17 our ($realtime);                # Synchronize timer interrupts with real time?
  18 our ($timeout);                 # Maximum runtime in seconds, if set.
  19 our ($kill_on_failure);         # Abort quickly on test failure?
  20 our (@puts);                    # Files to copy into the VM.
  21 our (@gets);                    # Files to copy out of the VM.
  22 our ($as_ref);                  # Reference to last addition to @gets or @puts.
  23 our (@kernel_args);             # Arguments to pass to kernel.
  24 our (%disks) = (OS => {DEF_FN => 'os.dsk'},             # Disks to give VM.
  25                 FS => {DEF_FN => 'fs.dsk'},
  26                 SCRATCH => {DEF_FN => 'scratch.dsk'},
  27                 SWAP => {DEF_FN => 'swap.dsk'});
  28 our (@disks_by_iface) = @disks{qw (OS FS SCRATCH SWAP)};
  29
  30 parse_command_line ();
  31 find_disks ();
  32 prepare_scratch_disk ();
  33 prepare_arguments ();
  34 run_vm ();
  35 finish_scratch_disk ();
  36
  37 exit 0;
  38 \f
  39 # Parses the command line.
  40 sub parse_command_line {
  41     usage (0) if @ARGV == 0 || (@ARGV == 1 && $ARGV[0] eq '--help');
  42
  43     @kernel_args = @ARGV;
  44     if (grep ($_ eq '--', @kernel_args)) {
  45         @ARGV = ();
  46         while ((my $arg = shift (@kernel_args)) ne '--') {
  47             push (@ARGV, $arg);
  48         }
  49         GetOptions ("sim=s" => sub { set_sim ($_[1]) },
  50                     "bochs" => sub { set_sim ("bochs") },
  51                     "qemu" => sub { set_sim ("qemu") },
  52                     "player" => sub { set_sim ("player") },
  53
  54                     "debug=s" => sub { set_debug ($_[1]) },
  55                     "no-debug" => sub { set_debug ("none") },
  56                     "monitor" => sub { set_debug ("monitor") },
  57                     "gdb" => sub { set_debug ("gdb") },
  58
  59                     "m|memory=i" => \$mem,
  60                     "j|jitter=i" => sub { set_jitter ($_[1]) },
  61                     "r|realtime" => sub { set_realtime () },
  62
  63                     "T|timeout=i" => \$timeout,
  64                     "k|kill-on-failure" => \$kill_on_failure,
  65
  66                     "v|no-vga" => sub { set_vga ('none'); },
  67                     "s|no-serial" => sub { $serial = 0; },
  68                     "t|terminal" => sub { set_vga ('terminal'); },
  69
  70                     "p|put-file=s" => sub { add_file (\@puts, $_[1]); },
  71                     "g|get-file=s" => sub { add_file (\@gets, $_[1]); },
  72                     "a|as=s" => sub { set_as ($_[1]); },
  73
  74                     "h|help" => sub { usage (0); },
  75
  76                     "os-disk=s" => \$disks{OS}{FILE_NAME},
  77                     "fs-disk=s" => \$disks{FS}{FILE_NAME},
  78                     "scratch-disk=s" => \$disks{SCRATCH}{FILE_NAME},
  79                     "swap-disk=s" => \$disks{SWAP}{FILE_NAME},
  80
  81                     "0|disk-0|hda=s" => \$disks_by_iface[0]{FILE_NAME},
  82                     "1|disk-1|hdb=s" => \$disks_by_iface[1]{FILE_NAME},
  83                     "2|disk-2|hdc=s" => \$disks_by_iface[2]{FILE_NAME},
  84                     "3|disk-3|hdd=s" => \$disks_by_iface[3]{FILE_NAME})
  85           or exit 1;
  86     }
  87
  88     $sim = "bochs" if !defined $sim;
  89     $debug = "none" if !defined $debug;
  90     $vga = "window" if !defined $vga;
  91
  92     undef $timeout, print "warning: disabling timeout with --$debug\n"
  93       if defined ($timeout) && $debug ne 'none';
  94
  95     print "warning: enabling serial port for -k or --kill-on-failure\n"
  96       if $kill_on_failure && !$serial;
  97 }
  98
  99 # usage($exitcode).
 100 # Prints a usage message and exits with $exitcode.
 101 sub usage {
 102     my ($exitcode) = @_;
 103     $exitcode = 1 unless defined $exitcode;
 104     print <<'EOF';
 105 pintos, a utility for running Pintos in a simulator
 106 Usage: pintos [OPTION...] -- [ARGUMENT...]
 107 where each OPTION is one of the following options
 108   and each ARGUMENT is passed to Pintos kernel verbatim.
 109 Simulator selection:
 110   --bochs                  (default) Use Bochs as simulator
 111   --qemu                   Use QEMU as simulator
 112   --player                 Use VMware Player as simulator
 113 Debugger selection:
 114   --no-debug               (default) No debugger
 115   --monitor                Debug with simulator's monitor
 116   --gdb                    Debug with gdb
 117 Display options: (default is both VGA and serial)
 118   -v, --no-vga             No VGA display or keyboard
 119   -s, --no-serial          No serial input or output
 120   -t, --terminal           Display VGA in terminal (Bochs only)
 121 Timing options: (Bochs only)
 122   -j SEED                  Randomize timer interrupts
 123   -r, --realtime           Use realistic, not reproducible, timings
 124 Testing options:
 125   -T, --timeout=N          Kill Pintos after N seconds CPU time or N*load_avg
 126                            seconds wall-clock time (whichever comes first)
 127   -k, --kill-on-failure    Kill Pintos a few seconds after a kernel or user
 128                            panic, test failure, or triple fault
 129 Configuration options:
 130   -m, --mem=N              Give Pintos N MB physical RAM (default: 4)
 131 File system commands (for `run' command):
 132   -p, --put-file=HOSTFN    Copy HOSTFN into VM, by default under same name
 133   -g, --get-file=GUESTFN   Copy GUESTFN out of VM, by default under same name
 134   -a, --as=FILENAME        Specifies guest (for -p) or host (for -g) file name
 135 Disk options: (name an existing FILE or specify SIZE in MB for a temp disk)
 136   --os-disk=FILE           Set OS disk file (default: os.dsk)
 137   --fs-disk=FILE|SIZE      Set FS disk file (default: fs.dsk)
 138   --scratch-disk=FILE|SIZE Set scratch disk (default: scratch.dsk)
 139   --swap-disk=FILE|SIZE    Set swap disk file (default: swap.dsk)
 140 Other options:
 141   -h, --help               Display this help message.
 142 EOF
 143     exit $exitcode;
 144 }
 145
 146 # Sets the simulator.
 147 sub set_sim {
 148     my ($new_sim) = @_;
 149     die "--$new_sim conflicts with --$sim\n"
 150         if defined ($sim) && $sim ne $new_sim;
 151     $sim = $new_sim;
 152 }
 153
 154 # Sets the debugger.
 155 sub set_debug {
 156     my ($new_debug) = @_;
 157     die "--$new_debug conflicts with --$debug\n"
 158         if $debug ne 'none' && $new_debug ne 'none' && $debug ne $new_debug;
 159     $debug = $new_debug;
 160 }
 161
 162 # Sets VGA output destination.
 163 sub set_vga {
 164     my ($new_vga) = @_;
 165     if (defined ($vga) && $vga ne $new_vga) {
 166         print "warning: conflicting vga display options\n";
 167     }
 168     $vga = $new_vga;
 169 }
 170
 171 # Sets randomized timer interrupts.
 172 sub set_jitter {
 173     my ($new_jitter) = @_;
 174     die "--realtime conflicts with --jitter\n" if defined $realtime;
 175     die "different --jitter already defined\n"
 176         if defined $jitter && $jitter != $new_jitter;
 177     $jitter = $new_jitter;
 178 }
 179
 180 # Sets real-time timer interrupts.
 181 sub set_realtime {
 182     die "--realtime conflicts with --jitter\n" if defined $jitter;
 183     $realtime = 1;
 184 }
 185
 186 # add_file(\@list, $file)
 187 #
 188 # Adds [$file] to @list, which should be @puts or @gets.
 189 # Sets $as_ref to point to the added element.
 190 sub add_file {
 191     my ($list, $file) = @_;
 192     $as_ref = [$file];
 193     push (@$list, $as_ref);
 194 }
 195
 196 # Sets the guest/host name for the previous put/get.
 197 sub set_as {
 198     my ($as) = @_;
 199     die "-a (or --as) is only allowed after -p or -g\n" if !defined $as_ref;
 200     die "Only one -a (or --as) is allowed after -p or -g\n"
 201       if defined $as_ref->[1];
 202     $as_ref->[1] = $as;
 203 }
 204 \f
 205 # Locates the files used to back each of the virtual disks,
 206 # and creates temporary disks.
 207 sub find_disks {
 208     for my $disk (values %disks) {
 209         # If there's no assigned file name but the default file exists,
 210         # try to assign a default file name.
 211         if (!defined ($disk->{FILE_NAME})) {
 212             for my $try_fn ($disk->{DEF_FN}, "build/" . $disk->{DEF_FN}) {
 213                 $disk->{FILE_NAME} = $try_fn, last
 214                   if -e $try_fn;
 215             }
 216         }
 217
 218         # If there's no file name, we're done.
 219         next if !defined ($disk->{FILE_NAME});
 220
 221         if ($disk->{FILE_NAME} =~ /^\d+(\.\d+)?|\.\d+$/) {
 222             # Create a temporary disk of approximately the specified
 223             # size in megabytes.
 224             die "OS disk can't be temporary\n" if $disk == $disks{OS};
 225
 226             my ($mb) = $disk->{FILE_NAME};
 227             undef $disk->{FILE_NAME};
 228
 229             my ($cyl_size) = 512 * 16 * 63;
 230             extend_disk ($disk, ceil ($mb * 2) * $cyl_size);
 231         } else {
 232             # The file must exist and have nonzero size.
 233             -e $disk->{FILE_NAME} or die "$disk->{FILE_NAME}: stat: $!\n";
 234             -s _ or die "$disk->{FILE_NAME}: disk has zero size\n";
 235         }
 236     }
 237
 238     # Warn about (potentially) missing disks.
 239     die "Cannot find OS disk\n" if !defined $disks{OS}{FILE_NAME};
 240     if (my ($project) = `pwd` =~ /\b(threads|userprog|vm|filesys)\b/) {
 241         if ((grep ($project eq $_, qw (userprog vm filesys)))
 242             && !defined ($disks{FS}{FILE_NAME})) {
 243             print STDERR "warning: it looks like you're running the $project ";
 244             print STDERR "project, but no file system disk is present\n";
 245         }
 246         if ($project eq 'vm' && !defined $disks{SWAP}{FILE_NAME}) {
 247             print STDERR "warning: it looks like you're running the $project ";
 248             print STDERR "project, but no swap disk is present\n";
 249         }
 250     }
 251 }
 252 \f
 253 # Prepare the scratch disk for gets and puts.
 254 sub prepare_scratch_disk {
 255     if (@puts) {
 256         # Write ustar header and data for each file.
 257         put_scratch_file ($_->[0],
 258                           defined $_->[1] ? $_->[1] : $_->[0])
 259           foreach @puts;
 260
 261         # Write end-of-archive marker.
 262         write_fully ($disks{SCRATCH}{HANDLE}, $disks{SCRATCH}{FILE_NAME},
 263                      "\0" x 1024);
 264     }
 265
 266     # Make sure the scratch disk is big enough to get big files.
 267     extend_disk ($disks{SCRATCH}, @gets * 1024 * 1024) if @gets;
 268 }
 269
 270 # Read "get" files from the scratch disk.
 271 sub finish_scratch_disk {
 272     # We need to start reading the scratch disk from the beginning again.
 273     if (@gets) {
 274         close ($disks{SCRATCH}{HANDLE});
 275         undef ($disks{SCRATCH}{HANDLE});
 276     }
 277
 278     # Read each file.
 279     # If reading fails, delete that file and all subsequent files.
 280     my ($ok) = 1;
 281     foreach my $get (@gets) {
 282         my ($name) = defined ($get->[1]) ? $get->[1] : $get->[0];
 283         my ($error) = get_scratch_file ($name);
 284         if ($error) {
 285             print STDERR "getting $name failed ($error)\n";
 286             die "$name: unlink: $!\n" if !unlink ($name) && !$!{ENOENT};
 287             $ok = 0;
 288         }
 289     }
 290 }
 291
 292 # mk_ustar_field($number, $size)
 293 #
 294 # Returns $number in a $size-byte numeric field in the format used by
 295 # the standard ustar archive header.
 296 sub mk_ustar_field {
 297     my ($number, $size) = @_;
 298     my ($len) = $size - 1;
 299     my ($out) = sprintf ("%0${len}o", $number) . "\0";
 300     die "$number: too large for $size-byte octal ustar field\n"
 301       if length ($out) != $size;
 302     return $out;
 303 }
 304
 305 # calc_ustar_chksum($s)
 306 #
 307 # Calculates and returns the ustar checksum of 512-byte ustar archive
 308 # header $s.
 309 sub calc_ustar_chksum {
 310     my ($s) = @_;
 311     die if length ($s) != 512;
 312     substr ($s, 148, 8, ' ' x 8);
 313     return unpack ("%32a*", $s);
 314 }
 315
 316 # put_scratch_file($src_file_name, $dst_file_name).
 317 #
 318 # Copies $src_file_name into the scratch disk for extraction as
 319 # $dst_file_name.
 320 sub put_scratch_file {
 321     my ($src_file_name, $dst_file_name) = @_;
 322     my ($disk_handle, $disk_file_name) = open_disk ($disks{SCRATCH});
 323
 324     print "Copying $src_file_name to scratch partition...\n";
 325
 326     # ustar format supports up to 100 characters for a file name, and
 327     # even longer names given some common properties, but our code in
 328     # the Pintos kernel only supports at most 99 characters.
 329     die "$dst_file_name: name too long (max 99 characters)\n"
 330       if length ($dst_file_name) > 99;
 331
 332     # Compose and write ustar header.
 333     stat $src_file_name or die "$src_file_name: stat: $!\n";
 334     my ($size) = -s _;
 335     my ($header) = (pack ("a100", $dst_file_name)       # name
 336                     . mk_ustar_field (0644, 8)          # mode
 337                     . mk_ustar_field (0, 8)             # uid
 338                     . mk_ustar_field (0, 8)             # gid
 339                     . mk_ustar_field ($size, 12)        # size
 340                     . mk_ustar_field (1136102400, 12)   # mtime
 341                     . (' ' x 8)                         # chksum
 342                     . '0'                               # typeflag
 343                     . ("\0" x 100)                      # linkname
 344                     . "ustar\0"                         # magic
 345                     . "00"                              # version
 346                     . "root" . ("\0" x 28)              # uname
 347                     . "root" . ("\0" x 28)              # gname
 348                     . "\0" x 8                          # devmajor
 349                     . "\0" x 8                          # devminor
 350                     . ("\0" x 155))                     # prefix
 351                     . "\0" x 12;                        # pad to 512 bytes
 352     substr ($header, 148, 8) = mk_ustar_field (calc_ustar_chksum ($header), 8);
 353     write_fully ($disk_handle, $disk_file_name, $header);
 354
 355     # Copy file data.
 356     my ($put_handle);
 357     sysopen ($put_handle, $src_file_name, O_RDONLY)
 358       or die "$src_file_name: open: $!\n";
 359     copy_file ($put_handle, $src_file_name, $disk_handle, $disk_file_name,
 360                $size);
 361     die "$src_file_name: changed size while being read\n"
 362       if $size != -s $put_handle;
 363     close ($put_handle);
 364
 365     # Round up disk data to beginning of next sector.
 366     write_fully ($disk_handle, $disk_file_name, "\0" x (512 - $size % 512))
 367       if $size % 512;
 368 }
 369
 370 # get_scratch_file($file).
 371 #
 372 # Copies from the scratch disk to $file.
 373 # Returns 1 if successful, 0 on failure.
 374 sub get_scratch_file {
 375     my ($get_file_name) = @_;
 376     my ($disk_handle, $disk_file_name) = open_disk ($disks{SCRATCH});
 377
 378     print "Copying $get_file_name out of $disk_file_name...\n";
 379
 380     # Read ustar header sector.
 381     my ($header) = read_fully ($disk_handle, $disk_file_name, 512);
 382     return "scratch disk tar archive ends unexpectedly"
 383       if $header eq ("\0" x 512);
 384
 385     # Verify magic numbers.
 386     return "corrupt ustar signature" if substr ($header, 257, 6) ne "ustar\0";
 387     return "invalid ustar version" if substr ($header, 263, 2) ne '00';
 388
 389     # Verify checksum.
 390     my ($chksum) = oct (unpack ("Z*", substr ($header, 148, 8)));
 391     my ($correct_chksum) = calc_ustar_chksum ($header);
 392     return "checksum mismatch" if $chksum != $correct_chksum;
 393
 394     # Get type.
 395     my ($typeflag) = substr ($header, 156, 1);
 396     return "not a regular file" if $typeflag ne '0' && $typeflag ne "\0";
 397
 398     # Get size.
 399     my ($size) = oct (unpack ("Z*", substr ($header, 124, 12)));
 400     return "bad size $size\n" if $size < 0;
 401
 402     # Copy file data.
 403     my ($get_handle);
 404     sysopen ($get_handle, $get_file_name, O_WRONLY | O_CREAT, 0666)
 405       or die "$get_file_name: create: $!\n";
 406     copy_file ($disk_handle, $disk_file_name, $get_handle, $get_file_name,
 407                $size);
 408     close ($get_handle);
 409
 410     # Skip forward in disk up to beginning of next sector.
 411     read_fully ($disk_handle, $disk_file_name, 512 - $size % 512)
 412       if $size % 512;
 413
 414     return 0;
 415 }
 416 \f
 417 # Prepares the arguments to pass to the Pintos kernel,
 418 # and then write them into Pintos bootloader.
 419 sub prepare_arguments {
 420     my (@args);
 421     push (@args, shift (@kernel_args))
 422       while @kernel_args && $kernel_args[0] =~ /^-/;
 423     push (@args, 'extract') if @puts;
 424     push (@args, @kernel_args);
 425     push (@args, 'append', $_->[0]) foreach @gets;
 426     write_cmd_line ($disks{OS}, @args);
 427 }
 428
 429 # Writes @args into the Pintos bootloader at the beginning of $disk.
 430 sub write_cmd_line {
 431     my ($disk, @args) = @_;
 432
 433     # Figure out command line to write.
 434     my ($arg_cnt) = pack ("V", scalar (@args));
 435     my ($args) = join ('', map ("$_\0", @args));
 436     die "command line exceeds 128 bytes" if length ($args) > 128;
 437     $args .= "\0" x (128 - length ($args));
 438
 439     # Write command line.
 440     my ($handle, $file_name) = open_disk_copy ($disk);
 441     print "Writing command line to $file_name...\n";
 442     sysseek ($handle, 0x17a, 0) == 0x17a or die "$file_name: seek: $!\n";
 443     syswrite ($handle, "$arg_cnt$args") or die "$file_name: write: $!\n";
 444 }
 445 \f
 446 # Running simulators.
 447
 448 # Runs the selected simulator.
 449 sub run_vm {
 450     if ($sim eq 'bochs') {
 451         run_bochs ();
 452     } elsif ($sim eq 'qemu') {
 453         run_qemu ();
 454     } elsif ($sim eq 'player') {
 455         run_player ();
 456     } else {
 457         die "unknown simulator `$sim'\n";
 458     }
 459 }
 460
 461 # Runs Bochs.
 462 sub run_bochs {
 463     # Select Bochs binary based on the chosen debugger.
 464     my ($bin) = $debug eq 'monitor' ? 'bochs-dbg' : 'bochs';
 465
 466     my ($squish_pty);
 467     if ($serial) {
 468         $squish_pty = find_in_path ("squish-pty");
 469         print "warning: can't find squish-pty, so terminal input will fail\n"
 470           if !defined $squish_pty;
 471     }
 472
 473     # Write bochsrc.txt configuration file.
 474     open (BOCHSRC, ">", "bochsrc.txt") or die "bochsrc.txt: create: $!\n";
 475     print BOCHSRC <<EOF;
 476 romimage: file=\$BXSHARE/BIOS-bochs-latest
 477 vgaromimage: file=\$BXSHARE/VGABIOS-lgpl-latest
 478 boot: disk
 479 cpu: ips=1000000
 480 megs: $mem
 481 log: bochsout.txt
 482 panic: action=fatal
 483 EOF
 484     print BOCHSRC "gdbstub: enabled=1\n" if $debug eq 'gdb';
 485     if ($realtime) {
 486         print BOCHSRC "clock: sync=realtime\n";
 487     } else {
 488         print BOCHSRC "clock: sync=none, time0=0\n";
 489     }
 490     print_bochs_disk_line ("ata0-master", 0);
 491     print_bochs_disk_line ("ata0-slave", 1);
 492     if (defined ($disks_by_iface[2]{FILE_NAME})
 493         || defined ($disks_by_iface[3]{FILE_NAME})) {
 494         print BOCHSRC "ata1: enabled=1, ioaddr1=0x170, ",
 495           "ioaddr2=0x370, irq=15\n";
 496         print_bochs_disk_line ("ata1-master", 2);
 497         print_bochs_disk_line ("ata1-slave", 3);
 498     }
 499     if ($vga ne 'terminal') {
 500         if ($serial) {
 501             my $mode = defined ($squish_pty) ? "term" : "file";
 502             print BOCHSRC "com1: enabled=1, mode=$mode, dev=/dev/stdout\n";
 503         }
 504         print BOCHSRC "display_library: nogui\n" if $vga eq 'none';
 505     } else {
 506         print BOCHSRC "display_library: term\n";
 507     }
 508     close (BOCHSRC);
 509
 510     # Compose Bochs command line.
 511     my (@cmd) = ($bin, '-q');
 512     unshift (@cmd, $squish_pty) if defined $squish_pty;
 513     push (@cmd, '-j', $jitter) if defined $jitter;
 514
 515     # Run Bochs.
 516     print join (' ', @cmd), "\n";
 517     my ($exit) = xsystem (@cmd);
 518     if (WIFEXITED ($exit)) {
 519         # Bochs exited normally.
 520         # Ignore the exit code; Bochs normally exits with status 1,
 521         # which is weird.
 522     } elsif (WIFSIGNALED ($exit)) {
 523         die "Bochs died with signal ", WTERMSIG ($exit), "\n";
 524     } else {
 525         die "Bochs died: code $exit\n";
 526     }
 527 }
 528
 529 # print_bochs_disk_line($device, $iface)
 530 #
 531 # If IDE interface $iface has a disk attached, prints a bochsrc.txt
 532 # line for attaching it to $device.
 533 sub print_bochs_disk_line {
 534     my ($device, $iface) = @_;
 535     my ($disk) = $disks_by_iface[$iface];
 536     my ($file) = $disk->{FILE_NAME};
 537     if (defined $file) {
 538         my (%geom) = disk_geometry ($disk);
 539         print BOCHSRC "$device: type=disk, path=$file, mode=flat, ";
 540         print BOCHSRC "cylinders=$geom{C}, heads=$geom{H}, spt=$geom{S}, ";
 541         print BOCHSRC "translation=none\n";
 542     }
 543 }
 544
 545 # Runs QEMU.
 546 sub run_qemu {
 547     print "warning: qemu doesn't support --terminal\n"
 548       if $vga eq 'terminal';
 549     print "warning: qemu doesn't support jitter\n"
 550       if defined $jitter;
 551     my (@cmd) = ('qemu');
 552     for my $iface (0...3) {
 553         my ($option) = ('-hda', '-hdb', '-hdc', '-hdd')[$iface];
 554         push (@cmd, $option, $disks_by_iface[$iface]{FILE_NAME})
 555           if defined $disks_by_iface[$iface]{FILE_NAME};
 556     }
 557     push (@cmd, '-m', $mem);
 558     push (@cmd, '-net', 'none');
 559     push (@cmd, '-nographic') if $vga eq 'none';
 560     push (@cmd, '-serial', 'stdio') if $serial && $vga ne 'none';
 561     push (@cmd, '-S') if $debug eq 'monitor';
 562     push (@cmd, '-s', '-S') if $debug eq 'gdb';
 563     push (@cmd, '-monitor', 'null') if $vga eq 'none' && $debug eq 'none';
 564     run_command (@cmd);
 565 }
 566
 567 # player_unsup($flag)
 568 #
 569 # Prints a message that $flag is unsupported by VMware Player.
 570 sub player_unsup {
 571     my ($flag) = @_;
 572     print "warning: no support for $flag with VMware Player\n";
 573 }
 574
 575 # Runs VMware Player.
 576 sub run_player {
 577     player_unsup ("--$debug") if $debug ne 'none';
 578     player_unsup ("--no-vga") if $vga eq 'none';
 579     player_unsup ("--terminal") if $vga eq 'terminal';
 580     player_unsup ("--jitter") if defined $jitter;
 581     player_unsup ("--timeout"), undef $timeout if defined $timeout;
 582     player_unsup ("--kill-on-failure"), undef $kill_on_failure
 583       if defined $kill_on_failure;
 584
 585     # Memory size must be multiple of 4.
 586     $mem = int (($mem + 3) / 4) * 4;
 587
 588     open (VMX, ">", "pintos.vmx") or die "pintos.vmx: create: $!\n";
 589     chmod 0777 & ~umask, "pintos.vmx";
 590     print VMX <<EOF;
 591 #! /usr/bin/vmware -G
 592 config.version = 8
 593 guestOS = "linux"
 594 memsize = $mem
 595 floppy0.present = FALSE
 596 usb.present = FALSE
 597 sound.present = FALSE
 598 gui.exitAtPowerOff = TRUE
 599 gui.exitOnCLIHLT = TRUE
 600 gui.powerOnAtStartUp = TRUE
 601 EOF
 602
 603
 604
 605     print VMX <<EOF if $serial;
 606 serial0.present = TRUE
 607 serial0.fileType = "pipe"
 608 serial0.fileName = "pintos.socket"
 609 serial0.pipe.endPoint = "client"
 610 serial0.tryNoRxLoss = "TRUE"
 611 EOF
 612
 613     for (my ($i) = 0; $i < 4; $i++) {
 614         my ($disk) = $disks_by_iface[$i];
 615         my ($dsk) = $disk->{FILE_NAME};
 616         next if !defined $dsk;
 617
 618         my ($device) = "ide" . int ($i / 2) . ":" . ($i % 2);
 619         my ($pln) = "$device.pln";
 620         print VMX <<EOF;
 621
 622 $device.present = TRUE
 623 $device.deviceType = "plainDisk"
 624 $device.fileName = "$pln"
 625 EOF
 626
 627         open (URANDOM, '<', '/dev/urandom') or die "/dev/urandom: open: $!\n";
 628         my ($bytes);
 629         sysread (URANDOM, $bytes, 4) == 4 or die "/dev/urandom: read: $!\n";
 630         close (URANDOM);
 631         my ($cid) = unpack ("L", $bytes);
 632
 633         my (%geom) = disk_geometry ($disk);
 634         open (PLN, ">", $pln) or die "$pln: create: $!\n";
 635         print PLN <<EOF;
 636 version=1
 637 CID=$cid
 638 parentCID=ffffffff
 639 createType="monolithicFlat"
 640
 641 RW $geom{CAPACITY} FLAT "$dsk" 0
 642
 643 # The Disk Data Base
 644 #DDB
 645
 646 ddb.adapterType = "ide"
 647 ddb.virtualHWVersion = "4"
 648 ddb.toolsVersion = "2"
 649 ddb.geometry.cylinders = "$geom{C}"
 650 ddb.geometry.heads = "$geom{H}"
 651 ddb.geometry.sectors = "$geom{S}"
 652 EOF
 653         close (PLN);
 654     }
 655     close (VMX);
 656
 657     my ($squish_unix);
 658     if ($serial) {
 659         $squish_unix = find_in_path ("squish-unix");
 660         print "warning: can't find squish-unix, so terminal input ",
 661           "and output will fail\n" if !defined $squish_unix;
 662     }
 663
 664     my ($vmx) = getcwd () . "/pintos.vmx";
 665     my (@cmd) = ("vmplayer", $vmx);
 666     unshift (@cmd, $squish_unix, "pintos.socket") if $squish_unix;
 667     print join (' ', @cmd), "\n";
 668     xsystem (@cmd);
 669 }
 670 \f
 671 # Disk utilities.
 672
 673 # open_disk($disk)
 674 #
 675 # Opens $disk, if it is not already open, and returns its file handle
 676 # and file name.
 677 sub open_disk {
 678     my ($disk) = @_;
 679     if (!defined ($disk->{HANDLE})) {
 680         if ($disk->{FILE_NAME}) {
 681             sysopen ($disk->{HANDLE}, $disk->{FILE_NAME}, O_RDWR)
 682               or die "$disk->{FILE_NAME}: open: $!\n";
 683         } else {
 684             ($disk->{HANDLE}, $disk->{FILE_NAME}) = tempfile (UNLINK => 1,
 685                                                              SUFFIX => '.dsk');
 686         }
 687     }
 688     return ($disk->{HANDLE}, $disk->{FILE_NAME});
 689 }
 690
 691 # open_disk_copy($disk)
 692 #
 693 # Makes a temporary copy of $disk and returns its file handle and file name.
 694 sub open_disk_copy {
 695     my ($disk) = @_;
 696     die if !$disk->{FILE_NAME};
 697
 698     my ($orig_handle, $orig_file_name) = open_disk ($disk);
 699     my ($cp_handle, $cp_file_name) = tempfile (UNLINK => 1, SUFFIX => '.dsk');
 700     copy_file ($orig_handle, $orig_file_name, $cp_handle, $cp_file_name,
 701                -s $orig_handle);
 702     return ($disk->{HANDLE}, $disk->{FILE_NAME}) = ($cp_handle, $cp_file_name);
 703 }
 704
 705 # extend_disk($disk, $size)
 706 #
 707 # Extends $disk, if necessary, so that it is at least $size bytes
 708 # long.
 709 sub extend_disk {
 710     my ($disk, $size) = @_;
 711     my ($handle, $file_name) = open_disk ($disk);
 712     if (-s ($handle) < $size) {
 713         sysseek ($handle, $size - 1, 0) == $size - 1
 714           or die "$file_name: seek: $!\n";
 715         syswrite ($handle, "\0") == 1
 716           or die "$file_name: write: $!\n";
 717     }
 718 }
 719
 720 # disk_geometry($file)
 721 #
 722 # Examines $file and returns a valid IDE disk geometry for it, as a
 723 # hash.
 724 sub disk_geometry {
 725     my ($disk) = @_;
 726     my ($file) = $disk->{FILE_NAME};
 727     my ($size) = -s $file;
 728     die "$file: stat: $!\n" if !defined $size;
 729     die "$file: size not a multiple of 512 bytes\n" if $size % 512;
 730     my ($cyl_size) = 512 * 16 * 63;
 731     my ($cylinders) = ceil ($size / $cyl_size);
 732     extend_disk ($disk, $cylinders * $cyl_size) if $size % $cyl_size;
 733
 734     return (CAPACITY => $size / 512,
 735             C => $cylinders,
 736             H => 16,
 737             S => 63);
 738 }
 739
 740 # copy_file($from_handle, $from_file_name, $to_handle, $to_file_name, $size)
 741 #
 742 # Copies $size bytes from $from_handle to $to_handle.
 743 # $from_file_name and $to_file_name are used in error messages.
 744 sub copy_file {
 745     my ($from_handle, $from_file_name, $to_handle, $to_file_name, $size) = @_;
 746
 747     while ($size > 0) {
 748         my ($chunk_size) = 4096;
 749         $chunk_size = $size if $chunk_size > $size;
 750         $size -= $chunk_size;
 751
 752         my ($data) = read_fully ($from_handle, $from_file_name, $chunk_size);
 753         write_fully ($to_handle, $to_file_name, $data);
 754     }
 755 }
 756
 757 # read_fully($handle, $file_name, $bytes)
 758 #
 759 # Reads exactly $bytes bytes from $handle and returns the data read.
 760 # $file_name is used in error messages.
 761 sub read_fully {
 762     my ($handle, $file_name, $bytes) = @_;
 763     my ($data);
 764     my ($read_bytes) = sysread ($handle, $data, $bytes);
 765     die "$file_name: read: $!\n" if !defined $read_bytes;
 766     die "$file_name: unexpected end of file\n" if $read_bytes != $bytes;
 767     return $data;
 768 }
 769
 770 # write_fully($handle, $file_name, $data)
 771 #
 772 # Write $data to $handle.
 773 # $file_name is used in error messages.
 774 sub write_fully {
 775     my ($handle, $file_name, $data) = @_;
 776     my ($written_bytes) = syswrite ($handle, $data);
 777     die "$file_name: write: $!\n" if !defined $written_bytes;
 778     die "$file_name: short write\n" if $written_bytes != length $data;
 779 }
 780 \f
 781 # Subprocess utilities.
 782
 783 # run_command(@args)
 784 #
 785 # Runs xsystem(@args).
 786 # Also prints the command it's running and checks that it succeeded.
 787 sub run_command {
 788     print join (' ', @_), "\n";
 789     die "command failed\n" if xsystem (@_);
 790 }
 791
 792 # xsystem(@args)
 793 #
 794 # Creates a subprocess via exec(@args) and waits for it to complete.
 795 # Relays common signals to the subprocess.
 796 # If $timeout is set then the subprocess will be killed after that long.
 797 sub xsystem {
 798     # QEMU turns off local echo and does not restore it if killed by a signal.
 799     # We compensate by restoring it ourselves.
 800     my $cleanup = sub {};
 801     if (isatty (0)) {
 802         my $termios = POSIX::Termios->new;
 803         $termios->getattr (0);
 804         $cleanup = sub { $termios->setattr (0, &POSIX::TCSANOW); }
 805     }
 806
 807     # Create pipe for filtering output.
 808     pipe (my $in, my $out) or die "pipe: $!\n" if $kill_on_failure;
 809
 810     my ($pid) = fork;
 811     if (!defined ($pid)) {
 812         # Fork failed.
 813         die "fork: $!\n";
 814     } elsif (!$pid) {
 815         # Running in child process.
 816         dup2 (fileno ($out), STDOUT_FILENO) or die "dup2: $!\n"
 817           if $kill_on_failure;
 818         exec_setitimer (@_);
 819     } else {
 820         # Running in parent process.
 821         close $out if $kill_on_failure;
 822
 823         my ($cause);
 824         local $SIG{ALRM} = sub { timeout ($pid, $cause, $cleanup); };
 825         local $SIG{INT} = sub { relay_signal ($pid, "INT", $cleanup); };
 826         local $SIG{TERM} = sub { relay_signal ($pid, "TERM", $cleanup); };
 827         alarm ($timeout * get_load_average () + 1) if defined ($timeout);
 828
 829         if ($kill_on_failure) {
 830             # Filter output.
 831             my ($buf) = "";
 832             my ($boots) = 0;
 833             local ($|) = 1;
 834             for (;;) {
 835                 if (waitpid ($pid, WNOHANG) != 0) {
 836                     # Subprocess died.  Pass through any remaining data.
 837                     print $buf while sysread ($in, $buf, 4096) > 0;
 838                     last;
 839                 }
 840
 841                 # Read and print out pipe data.
 842                 my ($len) = length ($buf);
 843                 waitpid ($pid, 0), last
 844                   if sysread ($in, $buf, 4096, $len) <= 0;
 845                 print substr ($buf, $len);
 846
 847                 # Remove full lines from $buf and scan them for keywords.
 848                 while ((my $idx = index ($buf, "\n")) >= 0) {
 849                     local $_ = substr ($buf, 0, $idx + 1, '');
 850                     next if defined ($cause);
 851                     if (/(Kernel PANIC|User process ABORT)/ ) {
 852                         $cause = "\L$1\E";
 853                         alarm (5);
 854                     } elsif (/Pintos booting/ && ++$boots > 1) {
 855                         $cause = "triple fault";
 856                         alarm (5);
 857                     } elsif (/FAILED/) {
 858                         $cause = "test failure";
 859                         alarm (5);
 860                     }
 861                 }
 862             }
 863         } else {
 864             waitpid ($pid, 0);
 865         }
 866         alarm (0);
 867         &$cleanup ();
 868
 869         if (WIFSIGNALED ($?) && WTERMSIG ($?) == SIGVTALRM ()) {
 870             seek (STDOUT, 0, 2);
 871             print "\nTIMEOUT after $timeout seconds of host CPU time\n";
 872             exit 0;
 873         }
 874
 875         return $?;
 876     }
 877 }
 878
 879 # relay_signal($pid, $signal, &$cleanup)
 880 #
 881 # Relays $signal to $pid and then reinvokes it for us with the default
 882 # handler.  Also cleans up temporary files and invokes $cleanup.
 883 sub relay_signal {
 884     my ($pid, $signal, $cleanup) = @_;
 885     kill $signal, $pid;
 886     eval { File::Temp::cleanup() };     # Not defined in old File::Temp.
 887     &$cleanup ();
 888     $SIG{$signal} = 'DEFAULT';
 889     kill $signal, getpid ();
 890 }
 891
 892 # timeout($pid, $cause, &$cleanup)
 893 #
 894 # Interrupts $pid and dies with a timeout error message,
 895 # after invoking $cleanup.
 896 sub timeout {
 897     my ($pid, $cause, $cleanup) = @_;
 898     kill "INT", $pid;
 899     waitpid ($pid, 0);
 900     &$cleanup ();
 901     seek (STDOUT, 0, 2);
 902     if (!defined ($cause)) {
 903         my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
 904         print "\nTIMEOUT after ", time () - $start_time,
 905           " seconds of wall-clock time";
 906         print  " - $load_avg" if defined $load_avg;
 907         print "\n";
 908     } else {
 909         print "Simulation terminated due to $cause.\n";
 910     }
 911     exit 0;
 912 }
 913
 914 # Returns the system load average over the last minute.
 915 # If the load average is less than 1.0 or cannot be determined, returns 1.0.
 916 sub get_load_average {
 917     my ($avg) = `uptime` =~ /load average:\s*([^,]+),/;
 918     return $avg >= 1.0 ? $avg : 1.0;
 919 }
 920
 921 # Calls setitimer to set a timeout, then execs what was passed to us.
 922 sub exec_setitimer {
 923     if (defined $timeout) {
 924         if ($\16 ge 5.8.0) {
 925             eval "
 926               use Time::HiRes qw(setitimer ITIMER_VIRTUAL);
 927               setitimer (ITIMER_VIRTUAL, $timeout, 0);
 928             ";
 929         } else {
 930             { exec ("setitimer-helper", $timeout, @_); };
 931             exit 1 if !$!{ENOENT};
 932             print STDERR "warning: setitimer-helper is not installed, so ",
 933               "CPU time limit will not be enforced\n";
 934         }
 935     }
 936     exec (@_);
 937     exit (1);
 938 }
 939
 940 sub SIGVTALRM {
 941     use Config;
 942     my $i = 0;
 943     foreach my $name (split(' ', $Config{sig_name})) {
 944         return $i if $name eq 'VTALRM';
 945         $i++;
 946     }
 947     return 0;
 948 }
 949
 950 # find_in_path ($program)
 951 #
 952 # Searches for $program in $ENV{PATH}.
 953 # Returns $program if found, otherwise undef.
 954 sub find_in_path {
 955     my ($program) = @_;
 956     -x "$_/$program" and return $program foreach split (':', $ENV{PATH});
 957     return;
 958 }