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