Note that struct file, struct dir are per-thread.
[pintos-anon] / 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 (@_) },
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 (@_) },
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 (@_) },
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     # Copy the files to put onto the scratch disk.
256     put_scratch_file ($_->[0]) foreach @puts;
257
258     # Make sure the scratch disk is big enough to get big files.
259     extend_disk ($disks{SCRATCH}, @gets * 1024 * 1024) if @gets;
260 }
261
262 # Read "get" files from the scratch disk.
263 sub finish_scratch_disk {
264     # We need to start reading the scratch disk from the beginning again.
265     if (@gets) {
266         close ($disks{SCRATCH}{HANDLE});
267         undef ($disks{SCRATCH}{HANDLE});
268     }
269
270     # Read each file.
271     get_scratch_file (defined ($_->[1]) ? $_->[1] : $_->[0]) foreach @gets;
272 }
273
274 # put_scratch_file($file).
275 #
276 # Copies $file into the scratch disk.
277 sub put_scratch_file {
278     my ($put_file_name) = @_;
279     my ($disk_handle, $disk_file_name) = open_disk ($disks{SCRATCH});
280
281     print "Copying $put_file_name into $disk_file_name...\n";
282
283     # Write metadata sector, which consists of a 4-byte signature
284     # followed by the file size.
285     stat $put_file_name or die "$put_file_name: stat: $!\n";
286     my ($size) = -s _;
287     my ($metadata) = pack ("a4 V x504", "PUT\0", $size);
288     write_fully ($disk_handle, $disk_file_name, $metadata);
289
290     # Copy file data.
291     my ($put_handle);
292     sysopen ($put_handle, $put_file_name, O_RDONLY)
293       or die "$put_file_name: open: $!\n";
294     copy_file ($put_handle, $put_file_name, $disk_handle, $disk_file_name,
295                $size);
296     close ($put_handle);
297
298     # Round up disk data to beginning of next sector.
299     write_fully ($disk_handle, $disk_file_name, "\0" x (512 - $size % 512))
300       if $size % 512;
301 }
302
303 # get_scratch_file($file).
304 #
305 # Copies from the scratch disk to $file.
306 sub get_scratch_file {
307     my ($get_file_name) = @_;
308     my ($disk_handle, $disk_file_name) = open_disk ($disks{SCRATCH});
309
310     print "Copying $get_file_name out of $disk_file_name...\n";
311
312     # Read metadata sector, which has a 4-byte signature followed by
313     # the file size.
314     my ($metadata) = read_fully ($disk_handle, $disk_file_name, 512);
315     my ($signature, $size) = unpack ("a4 V", $metadata);
316     die "bad signature reading scratch disk--did Pintos run correctly?\n"
317       if $signature ne "GET\0";
318
319     # Copy file data.
320     my ($get_handle);
321     sysopen ($get_handle, $get_file_name, O_WRONLY | O_CREAT, 0666)
322       or die "$get_file_name: create: $!\n";
323     copy_file ($disk_handle, $disk_file_name, $get_handle, $get_file_name,
324                $size);
325     close ($get_handle);
326
327     # Skip forward in disk up to beginning of next sector.
328     read_fully ($disk_handle, $disk_file_name, 512 - $size % 512)
329       if $size % 512;
330 }
331 \f
332 # Prepares the arguments to pass to the Pintos kernel,
333 # and then write them into Pintos bootloader.
334 sub prepare_arguments {
335     my (@args);
336     push (@args, shift (@kernel_args))
337       while @kernel_args && $kernel_args[0] =~ /^-/;
338     push (@args, 'put', defined $_->[1] ? $_->[1] : $_->[0]) foreach @puts;
339     push (@args, @kernel_args);
340     push (@args, 'get', $_->[0]) foreach @gets;
341     write_cmd_line ($disks{OS}, @args);
342 }
343
344 # Writes @args into the Pintos bootloader at the beginning of $disk.
345 sub write_cmd_line {
346     my ($disk, @args) = @_;
347
348     # Figure out command line to write.
349     my ($arg_cnt) = pack ("V", scalar (@args));
350     my ($args) = join ('', map ("$_\0", @args));
351     die "command line exceeds 128 bytes" if length ($args) > 128;
352     $args .= "\0" x (128 - length ($args));
353
354     # Write command line.
355     my ($handle, $file_name) = open_disk_copy ($disk);
356     print "Writing command line to $file_name...\n";
357     sysseek ($handle, 0x17a, 0) == 0x17a or die "$file_name: seek: $!\n";
358     syswrite ($handle, "$arg_cnt$args") or die "$file_name: write: $!\n";
359 }
360 \f
361 # Running simulators.
362
363 # Runs the selected simulator.
364 sub run_vm {
365     if ($sim eq 'bochs') {
366         run_bochs ();
367     } elsif ($sim eq 'qemu') {
368         run_qemu ();
369     } elsif ($sim eq 'player') {
370         run_player ();
371     } else {
372         die "unknown simulator `$sim'\n";
373     }
374 }
375
376 # Runs Bochs.
377 sub run_bochs {
378     # Select Bochs binary based on the chosen debugger.
379     my ($bin) = $debug eq 'monitor' ? 'bochs-dbg' : 'bochs';
380
381     my ($squish_pty);
382     if ($serial) {
383         $squish_pty = find_in_path ("squish-pty");
384         print "warning: can't find squish-pty, so terminal input will fail\n"
385           if !defined $squish_pty;
386     }
387
388     # Write bochsrc.txt configuration file.
389     open (BOCHSRC, ">", "bochsrc.txt") or die "bochsrc.txt: create: $!\n";
390     print BOCHSRC <<EOF;
391 romimage: file=\$BXSHARE/BIOS-bochs-latest, address=0xf0000
392 vgaromimage: file=\$BXSHARE/VGABIOS-lgpl-latest
393 boot: disk
394 cpu: ips=1000000
395 megs: $mem
396 log: bochsout.txt
397 panic: action=fatal
398 EOF
399     print BOCHSRC "gdbstub: enabled=1\n" if $debug eq 'gdb';
400     print BOCHSRC "clock: sync=", $realtime ? 'realtime' : 'none',
401       " time0=0\n";
402     print_bochs_disk_line ("ata0-master", 0);
403     print_bochs_disk_line ("ata0-slave", 1);
404     if (defined ($disks_by_iface[2]{FILE_NAME})
405         || defined ($disks_by_iface[3]{FILE_NAME})) {
406         print BOCHSRC "ata1: enabled=1, ioaddr1=0x170, ",
407           "ioaddr2=0x370, irq=15\n";
408         print_bochs_disk_line ("ata1-master", 2);
409         print_bochs_disk_line ("ata1-slave", 3);
410     }
411     if ($vga ne 'terminal') {
412         if ($serial) {
413             my $mode = defined ($squish_pty) ? "term" : "file";
414             print BOCHSRC "com1: enabled=1, mode=$mode, dev=/dev/stdout\n";
415         }
416         print BOCHSRC "display_library: nogui\n" if $vga eq 'none';
417     } else {
418         print BOCHSRC "display_library: term\n";
419     }
420     close (BOCHSRC);
421
422     # Compose Bochs command line.
423     my (@cmd) = ($bin, '-q');
424     unshift (@cmd, $squish_pty) if defined $squish_pty;
425     push (@cmd, '-j', $jitter) if defined $jitter;
426
427     # Run Bochs.
428     print join (' ', @cmd), "\n";
429     my ($exit) = xsystem (@cmd);
430     if (WIFEXITED ($exit)) {
431         # Bochs exited normally.
432         # Ignore the exit code; Bochs normally exits with status 1,
433         # which is weird.
434     } elsif (WIFSIGNALED ($exit)) {
435         die "Bochs died with signal ", WTERMSIG ($exit), "\n";
436     } else {
437         die "Bochs died: code $exit\n";
438     }
439 }
440
441 # print_bochs_disk_line($device, $iface)
442 #
443 # If IDE interface $iface has a disk attached, prints a bochsrc.txt
444 # line for attaching it to $device.
445 sub print_bochs_disk_line {
446     my ($device, $iface) = @_;
447     my ($disk) = $disks_by_iface[$iface];
448     my ($file) = $disk->{FILE_NAME};
449     if (defined $file) {
450         my (%geom) = disk_geometry ($disk);
451         print BOCHSRC "$device: type=disk, path=$file, mode=flat, ";
452         print BOCHSRC "cylinders=$geom{C}, heads=$geom{H}, spt=$geom{S}, ";
453         print BOCHSRC "translation=none\n";
454     }
455 }
456
457 # Runs QEMU.
458 sub run_qemu {
459     print "warning: qemu doesn't support --terminal\n"
460       if $vga eq 'terminal';
461     print "warning: qemu doesn't support jitter\n"
462       if defined $jitter;
463     my (@cmd) = ('qemu');
464     for my $iface (0...3) {
465         my ($option) = ('-hda', '-hdb', '-hdc', '-hdd')[$iface];
466         push (@cmd, $option, $disks_by_iface[$iface]{FILE_NAME})
467           if defined $disks_by_iface[$iface]{FILE_NAME};
468     }
469     push (@cmd, '-m', $mem);
470     push (@cmd, '-net', 'none');
471     push (@cmd, '-nographic') if $vga eq 'none';
472     push (@cmd, '-serial', 'stdio') if $serial && $vga ne 'none';
473     push (@cmd, '-S') if $debug eq 'monitor';
474     push (@cmd, '-s', '-S') if $debug eq 'gdb';
475     push (@cmd, '-monitor', 'null') if $vga eq 'none' && $debug eq 'none';
476     run_command (@cmd);
477 }
478
479 # player_unsup($flag)
480 #
481 # Prints a message that $flag is unsupported by VMware Player.
482 sub player_unsup {
483     my ($flag) = @_;
484     print "warning: no support for $flag with VMware Player\n";
485 }
486
487 # Runs VMware Player.
488 sub run_player {
489     player_unsup ("--$debug") if $debug ne 'none';
490     player_unsup ("--no-vga") if $vga eq 'none';
491     player_unsup ("--terminal") if $vga eq 'terminal';
492     player_unsup ("--jitter") if defined $jitter;
493     player_unsup ("--timeout"), undef $timeout if defined $timeout;
494     player_unsup ("--kill-on-failure"), undef $kill_on_failure
495       if defined $kill_on_failure;
496
497     # Memory size must be multiple of 4.
498     $mem = int (($mem + 3) / 4) * 4;
499
500     open (VMX, ">", "pintos.vmx") or die "pintos.vmx: create: $!\n";
501     chmod 0777 & ~umask, "pintos.vmx";
502     print VMX <<EOF;
503 #! /usr/bin/vmware -G
504 config.version = 8
505 guestOS = "linux"
506 memsize = $mem
507 floppy0.present = FALSE
508 usb.present = FALSE
509 sound.present = FALSE
510 gui.exitAtPowerOff = TRUE
511 gui.exitOnCLIHLT = TRUE
512 gui.powerOnAtStartUp = TRUE
513 EOF
514
515
516
517     print VMX <<EOF if $serial;
518 serial0.present = TRUE
519 serial0.fileType = "pipe"
520 serial0.fileName = "pintos.socket"
521 serial0.pipe.endPoint = "client"
522 serial0.tryNoRxLoss = "TRUE"
523 EOF
524
525     for (my ($i) = 0; $i < 4; $i++) {
526         my ($disk) = $disks_by_iface[$i];
527         my ($dsk) = $disk->{FILE_NAME};
528         next if !defined $dsk;
529
530         my ($device) = "ide" . int ($i / 2) . ":" . ($i % 2);
531         my ($pln) = "$device.pln";
532         print VMX <<EOF;
533
534 $device.present = TRUE
535 $device.deviceType = "plainDisk"
536 $device.fileName = "$pln"
537 EOF
538
539         open (URANDOM, '<', '/dev/urandom') or die "/dev/urandom: open: $!\n";
540         my ($bytes);
541         sysread (URANDOM, $bytes, 4) == 4 or die "/dev/urandom: read: $!\n";
542         close (URANDOM);
543         my ($cid) = unpack ("L", $bytes);
544
545         my (%geom) = disk_geometry ($disk);
546         open (PLN, ">", $pln) or die "$pln: create: $!\n";
547         print PLN <<EOF;
548 version=1
549 CID=$cid
550 parentCID=ffffffff
551 createType="monolithicFlat"
552
553 RW $geom{CAPACITY} FLAT "$dsk" 0
554
555 # The Disk Data Base
556 #DDB
557
558 ddb.adapterType = "ide"
559 ddb.virtualHWVersion = "4"
560 ddb.toolsVersion = "2"
561 ddb.geometry.cylinders = "$geom{C}"
562 ddb.geometry.heads = "$geom{H}"
563 ddb.geometry.sectors = "$geom{S}"
564 EOF
565         close (PLN);
566     }
567     close (VMX);
568
569     my ($squish_unix);
570     if ($serial) {
571         $squish_unix = find_in_path ("squish-unix");
572         print "warning: can't find squish-unix, so terminal input ",
573           "and output will fail\n" if !defined $squish_unix;
574     }
575
576     my ($vmx) = getcwd () . "/pintos.vmx";
577     my (@cmd) = ("vmplayer", $vmx);
578     unshift (@cmd, $squish_unix, "pintos.socket") if $squish_unix;
579     print join (' ', @cmd), "\n";
580     xsystem (@cmd);
581 }
582 \f
583 # Disk utilities.
584
585 # open_disk($disk)
586 #
587 # Opens $disk, if it is not already open, and returns its file handle
588 # and file name.
589 sub open_disk {
590     my ($disk) = @_;
591     if (!defined ($disk->{HANDLE})) {
592         if ($disk->{FILE_NAME}) {
593             sysopen ($disk->{HANDLE}, $disk->{FILE_NAME}, O_RDWR)
594               or die "$disk->{FILE_NAME}: open: $!\n";
595         } else {
596             ($disk->{HANDLE}, $disk->{FILE_NAME}) = tempfile (UNLINK => 1,
597                                                              SUFFIX => '.dsk');
598         }
599     }
600     return ($disk->{HANDLE}, $disk->{FILE_NAME});
601 }
602
603 # open_disk_copy($disk)
604 #
605 # Makes a temporary copy of $disk and returns its file handle and file name.
606 sub open_disk_copy {
607     my ($disk) = @_;
608     die if !$disk->{FILE_NAME};
609
610     my ($orig_handle, $orig_file_name) = open_disk ($disk);
611     my ($cp_handle, $cp_file_name) = tempfile (UNLINK => 1, SUFFIX => '.dsk');
612     copy_file ($orig_handle, $orig_file_name, $cp_handle, $cp_file_name,
613                -s $orig_handle);
614     return ($disk->{HANDLE}, $disk->{FILE_NAME}) = ($cp_handle, $cp_file_name);
615 }
616
617 # extend_disk($disk, $size)
618 #
619 # Extends $disk, if necessary, so that it is at least $size bytes
620 # long.
621 sub extend_disk {
622     my ($disk, $size) = @_;
623     my ($handle, $file_name) = open_disk ($disk);
624     if (-s ($handle) < $size) {
625         sysseek ($handle, $size - 1, 0) == $size - 1
626           or die "$file_name: seek: $!\n";
627         syswrite ($handle, "\0") == 1
628           or die "$file_name: write: $!\n";
629     }
630 }
631
632 # disk_geometry($file)
633 #
634 # Examines $file and returns a valid IDE disk geometry for it, as a
635 # hash.
636 sub disk_geometry {
637     my ($disk) = @_;
638     my ($file) = $disk->{FILE_NAME};
639     my ($size) = -s $file;
640     die "$file: stat: $!\n" if !defined $size;
641     die "$file: size not a multiple of 512 bytes\n" if $size % 512;
642     my ($cyl_size) = 512 * 16 * 63;
643     my ($cylinders) = ceil ($size / $cyl_size);
644     extend_disk ($disk, $cylinders * $cyl_size) if $size % $cyl_size;
645
646     return (CAPACITY => $size / 512,
647             C => $cylinders,
648             H => 16,
649             S => 63);
650 }
651
652 # copy_file($from_handle, $from_file_name, $to_handle, $to_file_name, $size)
653 #
654 # Copies $size bytes from $from_handle to $to_handle.
655 # $from_file_name and $to_file_name are used in error messages.
656 sub copy_file {
657     my ($from_handle, $from_file_name, $to_handle, $to_file_name, $size) = @_;
658
659     while ($size > 0) {
660         my ($chunk_size) = 4096;
661         $chunk_size = $size if $chunk_size > $size;
662         $size -= $chunk_size;
663
664         my ($data) = read_fully ($from_handle, $from_file_name, $chunk_size);
665         write_fully ($to_handle, $to_file_name, $data);
666     }
667 }
668
669 # read_fully($handle, $file_name, $bytes)
670 #
671 # Reads exactly $bytes bytes from $handle and returns the data read.
672 # $file_name is used in error messages.
673 sub read_fully {
674     my ($handle, $file_name, $bytes) = @_;
675     my ($data);
676     my ($read_bytes) = sysread ($handle, $data, $bytes);
677     die "$file_name: read: $!\n" if !defined $read_bytes;
678     die "$file_name: unexpected end of file\n" if $read_bytes != $bytes;
679     return $data;
680 }
681
682 # write_fully($handle, $file_name, $data)
683 #
684 # Write $data to $handle.
685 # $file_name is used in error messages.
686 sub write_fully {
687     my ($handle, $file_name, $data) = @_;
688     my ($written_bytes) = syswrite ($handle, $data);
689     die "$file_name: write: $!\n" if !defined $written_bytes;
690     die "$file_name: short write\n" if $written_bytes != length $data;
691 }
692 \f
693 # Subprocess utilities.
694
695 # run_command(@args)
696 #
697 # Runs xsystem(@args).
698 # Also prints the command it's running and checks that it succeeded.
699 sub run_command {
700     print join (' ', @_), "\n";
701     die "command failed\n" if xsystem (@_);
702 }
703
704 # xsystem(@args)
705 #
706 # Creates a subprocess via exec(@args) and waits for it to complete.
707 # Relays common signals to the subprocess.
708 # If $timeout is set then the subprocess will be killed after that long.
709 sub xsystem {
710     # QEMU turns off local echo and does not restore it if killed by a signal.
711     # We compensate by restoring it ourselves.
712     my $cleanup = sub {};
713     if (isatty (0)) {
714         my $termios = POSIX::Termios->new;
715         $termios->getattr (0);
716         $cleanup = sub { $termios->setattr (0, &POSIX::TCSANOW); }
717     }
718
719     # Create pipe for filtering output.
720     pipe (my $in, my $out) or die "pipe: $!\n" if $kill_on_failure;
721
722     my ($pid) = fork;
723     if (!defined ($pid)) {
724         # Fork failed.
725         die "fork: $!\n";
726     } elsif (!$pid) {
727         # Running in child process.
728         dup2 (fileno ($out), STDOUT_FILENO) or die "dup2: $!\n"
729           if $kill_on_failure;
730         exec_setitimer (@_);
731     } else {
732         # Running in parent process.
733         close $out if $kill_on_failure;
734
735         my ($cause);
736         local $SIG{ALRM} = sub { timeout ($pid, $cause, $cleanup); };
737         local $SIG{INT} = sub { relay_signal ($pid, "INT", $cleanup); };
738         local $SIG{TERM} = sub { relay_signal ($pid, "TERM", $cleanup); };
739         alarm ($timeout * get_load_average () + 1) if defined ($timeout);
740
741         if ($kill_on_failure) {
742             # Filter output.
743             my ($buf) = "";
744             my ($boots) = 0;
745             local ($|) = 1;
746             for (;;) {
747                 if (waitpid ($pid, WNOHANG) != 0) {
748                     # Subprocess died.  Pass through any remaining data.
749                     print $buf while sysread ($in, $buf, 4096) > 0;
750                     last;
751                 }
752
753                 # Read and print out pipe data.
754                 my ($len) = length ($buf);
755                 waitpid ($pid, 0), last
756                   if sysread ($in, $buf, 4096, $len) <= 0;
757                 print substr ($buf, $len);
758
759                 # Remove full lines from $buf and scan them for keywords.
760                 while ((my $idx = index ($buf, "\n")) >= 0) {
761                     local $_ = substr ($buf, 0, $idx + 1, '');
762                     next if defined ($cause);
763                     if (/(Kernel PANIC|User process ABORT)/ ) {
764                         $cause = "\L$1\E";
765                         alarm (5);
766                     } elsif (/Pintos booting/ && ++$boots > 1) {
767                         $cause = "triple fault";
768                         alarm (5);
769                     } elsif (/FAILED/) {
770                         $cause = "test failure";
771                         alarm (5);
772                     }
773                 }
774             }
775         } else {
776             waitpid ($pid, 0);
777         }
778         alarm (0);
779         &$cleanup ();
780
781         if (WIFSIGNALED ($?) && WTERMSIG ($?) == SIGVTALRM ()) {
782             seek (STDOUT, 0, 2);
783             print "\nTIMEOUT after $timeout seconds of host CPU time\n";
784             exit 0;
785         }
786
787         return $?;
788     }
789 }
790
791 # relay_signal($pid, $signal, &$cleanup)
792 #
793 # Relays $signal to $pid and then reinvokes it for us with the default
794 # handler.  Also cleans up temporary files and invokes $cleanup.
795 sub relay_signal {
796     my ($pid, $signal, $cleanup) = @_;
797     kill $signal, $pid;
798     eval { File::Temp::cleanup() };     # Not defined in old File::Temp.
799     &$cleanup ();
800     $SIG{$signal} = 'DEFAULT';
801     kill $signal, getpid ();
802 }
803
804 # timeout($pid, $cause, &$cleanup)
805 #
806 # Interrupts $pid and dies with a timeout error message,
807 # after invoking $cleanup.
808 sub timeout {
809     my ($pid, $cause, $cleanup) = @_;
810     kill "INT", $pid;
811     waitpid ($pid, 0);
812     &$cleanup ();
813     seek (STDOUT, 0, 2);
814     if (!defined ($cause)) {
815         my ($load_avg) = `uptime` =~ /(load average:.*)$/i;
816         print "\nTIMEOUT after ", time () - $start_time,
817           " seconds of wall-clock time";
818         print  " - $load_avg" if defined $load_avg;
819         print "\n";
820     } else {
821         print "Simulation terminated due to $cause.\n";
822     }
823     exit 0;
824 }
825
826 # Returns the system load average over the last minute.
827 # If the load average is less than 1.0 or cannot be determined, returns 1.0.
828 sub get_load_average {
829     my ($avg) = `uptime` =~ /load average:\s*([^,]+),/;
830     return $avg >= 1.0 ? $avg : 1.0;
831 }
832
833 # Calls setitimer to set a timeout, then execs what was passed to us.
834 sub exec_setitimer {
835     if (defined $timeout) {
836         if ($\16 ge 5.8.0) {
837             eval "
838               use Time::HiRes qw(setitimer ITIMER_VIRTUAL);
839               setitimer (ITIMER_VIRTUAL, $timeout, 0);
840             ";
841         } else {
842             { exec ("setitimer-helper", $timeout, @_); };
843             exit 1 if !$!{ENOENT};
844             print STDERR "warning: setitimer-helper is not installed, so ",
845               "CPU time limit will not be enforced\n";
846         }
847     }
848     exec (@_);
849     exit (1);
850 }
851
852 sub SIGVTALRM {
853     use Config;
854     my $i = 0;
855     foreach my $name (split(' ', $Config{sig_name})) {
856         return $i if $name eq 'VTALRM';
857         $i++;
858     }
859     return 0;
860 }
861
862 # find_in_path ($program)
863 #
864 # Searches for $program in $ENV{PATH}.
865 # Returns $program if found, otherwise undef.
866 sub find_in_path {
867     my ($program) = @_;
868     -x "$_/$program" and return $program foreach split (':', $ENV{PATH});
869     return;
870 }