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