*** cons.pl-1.6b1 Sun Feb 6 21:10:15 2000 --- cons.pl-1.6b1+p5 Sun Feb 6 21:03:20 2000 *************** *** 2,8 **** # Cons: A Software Construction Tool. # Bob Sidebotham (rns@fore.com), FORE Systems, 1996. ! # $Id: //depot/proj/cons/src/cons.pl#4 $ $cons_history = q( --- 2,8 ---- # Cons: A Software Construction Tool. # Bob Sidebotham (rns@fore.com), FORE Systems, 1996. ! # $Id$ $cons_history = q( *************** *** 32,44 **** Fix Repository to include appropriate library paths. - Fix SourcePath to return correct repository path. - Win32 Fix to work with generic perl. - - Fix futil::copy - ); $ver_num = 1.6; ! $ver_rev = "b1"; $version = "This is Cons $ver_num$ver_rev " . ! '($Id: //depot/proj/cons/src/cons.pl#4 $)'. "\n"; # Copyright (c) 1996-1999 FORE Systems, Inc. All rights reserved. --- 32,43 ---- Fix Repository to include appropriate library paths. - Fix SourcePath to return correct repository path. - Win32 Fix to work with generic perl. - ); $ver_num = 1.6; ! $ver_rev = "b1+p5"; $version = "This is Cons $ver_num$ver_rev " . ! '($Id$)'. "\n"; # Copyright (c) 1996-1999 FORE Systems, Inc. All rights reserved. *************** *** 71,76 **** --- 70,76 ---- $PATH_SEPARATOR = ':'; $FLAG_CHARACTER = '-'; $LIB_FLAG_PREFIX = '-L'; + $JOB_CLASS = 'job'; # if the version is 5.003, we can check $^O if ($] < 5.003) { eval("require Win32"); *************** *** 83,88 **** --- 83,89 ---- $PATH_SEPARATOR = ';'; $FLAG_CHARACTER = '/'; $LIB_FLAG_PREFIX = '/LIBPATH:'; + $JOB_CLASS = 'job::win32'; } } *************** *** 131,142 **** -h Show a help message local to the current build if one such is defined, and exit. - -o Read override file . - -k Keep going as far as possible after errors. -m Show cons modification history and exit. -p Show construction products in specified trees. -pa Show construction products and associated actions. -pw Show products and where they are defined. --- 132,143 ---- -h Show a help message local to the current build if one such is defined, and exit. -k Keep going as far as possible after errors. -m Show cons modification history and exit. + -o Read override file . + -p Show construction products in specified trees. -pa Show construction products and associated actions. -pw Show products and where they are defined. *************** *** 177,182 **** --- 178,184 ---- $param::salt = undef; # Salt derived file signatures with this. $param::rep_sig_times_ok = 1; # Repository .consign times are in sync w/files. $param::quiet = 0; # should we show the command being executed. + $param::maxjobs = 1; # Maximum number of simultaneous jobs. # Display a command while executing or otherwise. This # should be called by command builder action methods. *************** *** 232,290 **** } sub option { ! if ($_ eq 'm') { ! print($version, $cons_history), exit(0); ! } elsif ($_ eq 'v') { ! print($version); ! } elsif ($_ eq 'V') { ! print($version), exit(0); ! } elsif ($_ eq 'o') { ! $param::overfile = shift(@ARGV); ! die("$0: -o option requires a filename argument.\n") if !$param::overfile; ! } elsif ($_ eq 'f') { ! $param::topfile = shift(@ARGV); ! die("$0: -f option requires a filename argument.\n") if !$param::topfile; ! } elsif ($_ eq 'wf') { ! $param::depfile = shift(@ARGV); ! die("$0: -wf option requires a filename argument.\n") if !$param::depfile; ! } elsif ($_ eq 'k') { ! $param::kflag = 1; ! } elsif ($_ eq 'p') { ! $param::pflag = 1; ! $param::build = 0; ! } elsif ($_ eq 'pa') { ! $param::pflag = $param::aflag = 1; ! $param::build = 0; ! $indent = "... "; ! } elsif ($_ eq 'pw') { ! $param::pflag = $param::wflag = 1; ! $param::build = 0; ! } elsif ($_ eq 'q') { ! $param::quiet = 1; ! } elsif ($_ eq 'r') { ! $param::rflag = 1; ! $param::build = 0; ! } elsif ($_ eq 'h') { ! $param::localhelp =1; ! } elsif ($_ eq 'x') { ! print($usage); ! exit 0; ! } elsif ($_ eq 'd') { ! $param::depends = 1; ! } elsif ($_ eq 'cc') { ! $param::cachecom = 1; ! } elsif ($_ eq 'cd') { ! $param::cachedisable = 1; ! } elsif ($_ eq 'cr') { ! $param::random = 1; ! } elsif ($_ eq 'cs') { ! $param::cachesync = 1; ! } elsif ($_ eq 'R') { ! my($repository) = shift(@ARGV); ! die("$0: -R option requires a repository argument.\n") if !$repository; ! script::Repository($repository); } else { ! die qq($0: unrecognized option "-$_". Use -x for a usage message.\n) if $_; } } --- 234,292 ---- } sub option { ! my %opt_tab = ( ! 'cc' => sub { $param::cachecom = 1; }, ! 'cd' => sub { $param::cachedisable = 1; }, ! 'cr' => sub { $param::random = 1; }, ! 'cs' => sub { $param::cachesync = 1; }, ! 'd' => sub { $param::depends = 1; }, ! 'h' => sub { $param::localhelp = 1; }, ! 'k' => sub { $param::kflag = 1; }, ! 'm' => sub { print($version, $cons_history), exit(0); }, ! 'p' => sub { $param::pflag = 1; ! $param::build = 0; }, ! 'pa' => sub { $param::pflag = $param::aflag = 1; ! $indent = "... "; ! $param::build = 0; }, ! 'pw' => sub { $param::pflag = $param::wflag = 1; ! $param::build = 0; }, ! 'q' => sub { $param::quiet = 1; }, ! 'r' => sub { $param::rflag = 1; ! $param::build = 0; }, ! 'v' => sub { print($version); }, ! 'V' => sub { print($version), exit(0); }, ! 'x' => sub { print($usage), exit 0; }, ! ); ! ! my %opt_arg = ( ! 'f' => sub { $param::topfile = shift; }, ! 'j' => sub { die("$0: -j not supported (yet?) ". ! "on WIN32 systems.\n") if $main::_WIN32; ! $param::maxjobs = shift; }, ! 'o' => sub { $param::overfile = shift; }, ! 'R' => sub { script::Repository(shift); }, ! ); ! ! if (defined $opt_tab{$_}) { ! &{$opt_tab{$_}}; } else { ! $_ =~ m/(.)(.*)/; ! if (defined $opt_arg{$1}) { ! if ($2) { ! $_ = $2; ! } else { ! $_ = shift @ARGV; ! die("$0: -$1 option requires an argument.\n") if ! $_; ! } ! &{$opt_arg{$1}}($_); ! } elsif ($_ eq 'wf') { ! $param::depfile = shift(@ARGV); ! die "$0: -wf option requires a filename argument.\n" ! if !$param::depfile; ! } else { ! die "$0: unrecognized option \"-$_\". " . ! "Use -x for a usage message.\n" if $_; ! } } } *************** *** 297,323 **** # Define file signature protocol. sig->select($param::sigpro); # Cleanup after an interrupt. $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub { $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE'; warn("\n$0: killed\n"); ! # Call this first, to make sure that this processing ! # occurs even if a child process does not die (and we ! # hang on the wait). ! sig::hash::END(); ! wait(); ! exit(1); }; # Cleanup after a broken pipe (someone piped our stdout?) $SIG{PIPE} = sub { $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE'; warn("\n$0: broken pipe\n"); ! sig::hash::END(); ! wait(); ! exit(1); }; if ($param::depfile) { open (main::DEPFILE, ">".$param::depfile) || die ("$0: couldn't open $param::depfile ($!)\n"); --- 299,340 ---- # Define file signature protocol. sig->select($param::sigpro); + # Common cleanup-and-exit routine. + sub END { + # Call this first, to make sure that this processing + # occurs even if a child process does not die (and we + # hang on the wait). + &sig::hash::on_exit(); + on_exit $main::JOB_CLASS; + # Call it agin, in case reaping children yielded any + # additional signatures to flush. + &sig::hash::on_exit(); + #exit(1); + } + # Cleanup after an interrupt. $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub { $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE'; warn("\n$0: killed\n"); ! main::END(); ! exit (1); }; # Cleanup after a broken pipe (someone piped our stdout?) $SIG{PIPE} = sub { $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE'; warn("\n$0: broken pipe\n"); ! main::END(); ! exit (1); }; + sub arrange_immediate_exit { + $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub { + $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE'; + exit(1); + } + } + if ($param::depfile) { open (main::DEPFILE, ">".$param::depfile) || die ("$0: couldn't open $param::depfile ($!)\n"); *************** *** 363,369 **** # Read the top-level construct file and its included scripts. doscripts($param::topfile); ! # Status priorities. This let's us aggregate status for directories and print # an appropriate message (at the top-level). %priority = ('none' => 1, 'handled' => 2, 'built' => 3, 'unknown' => 4, 'errors' => 5); --- 380,386 ---- # Read the top-level construct file and its included scripts. doscripts($param::topfile); ! # Status priorities. This lets us aggregate status for directories and print # an appropriate message (at the top-level). %priority = ('none' => 1, 'handled' => 2, 'built' => 3, 'unknown' => 4, 'errors' => 5); *************** *** 371,446 **** # If no targets were specified, supply default targets (if any). @targets = @param::default_targets if ! @targets; ! # Build the supplied target patterns. ! for $tgt (map($dir::top->lookup($_), @targets)) { ! my($status) = buildtarget($tgt); ! if ($status ne 'built') { ! my($path) = $tgt->path; ! if ($status eq "errors") { ! print qq($0: "$path" not remade because of errors.\n); ! $errors++; ! } elsif ($status eq "handled") { ! print qq($0: "$path" is up-to-date.\n); ! } elsif ($status eq "unknown") { ! # cons error already reported. ! $errors++; ! } elsif ($status eq "none") { ! #??? ! } else { ! print qq($0: don't know how to construct "$path".\n"); #' ! $errors++; ! } ! } ! } ! exit 0 + ($errors != 0); ! # Build the supplied target directory or files. Return aggregated status. ! sub buildtarget { ! my($tgt) = @_; ! if (ref($tgt) eq "dir") { ! my($result) = "none"; ! my($priority) = $priority{$result}; ! if (exists $tgt->{member}) { ! my($members) = $tgt->{member}; ! for $entry (sort keys %$members) { ! next if $entry =~ /^\./; # ignore hidden files ! my($tgt) = $members->{$entry}; ! next if ref($tgt) eq "file" && !exists($tgt->{builder}); ! my($stat) = buildtarget($members->{$entry}); ! my($pri) = $priority{$stat}; ! if ($pri > $priority) { ! $priority = $pri; ! $result = $stat; } } } ! return $result; ! } ! if ($param::build) { ! return build $tgt; ! } elsif ($param::depends) { ! my($path) = $tgt->path; ! if ($tgt->{builder}) { ! my(@dep) = (@{$tgt->{dep}}, @{$tgt->{sources}}); ! my($dep) = join(' ',map($_->path, @dep)); ! print("$path: $dep\n"); ! } else { ! print("$path: not a derived file\n"); ! } ! } elsif ($param::pflag || $param::wflag || $param::aflag) { ! if ($tgt->{builder}) { ! if ($param::wflag) { ! print qq(${\$tgt->path}: $tgt->{script}\n); ! } elsif ($param::pflag) { ! print qq(${\$tgt->path}:\n) if $param::aflag; ! print qq(${\$tgt->path}\n) if !$param::aflag; } ! if ($param::aflag) { ! $tgt->{builder}->action($tgt); } } ! } elsif ($param::rflag && $tgt->{builder}) { my($path) = $tgt->path; if (-f $path) { if (unlink($path)) { --- 388,511 ---- # If no targets were specified, supply default targets (if any). @targets = @param::default_targets if ! @targets; ! @targets = map($dir::top->lookup($_), @targets); ! if ($param::build) { ! foreach $tgt (@targets) { ! my($status) = 'none'; ! my(@subtargets) = ($tgt); ! while ($subtgt = shift @subtargets) { ! # This takes care of the case where a given subtgt ! # gets on the list twice because it's a dependency ! # of multiple things. ! next if $subtgt->{status} || $subtgt->{started}; ! ! # Fetch the current dependencies of the target. ! my @deps; ! $subtgt->static_dependencies(\@deps); ! ! if (@deps) { ! # Before we make decisions based on what we think ! # has or hasn't been built, give any children that ! # finished while we were starting the last job a ! # chance to notify the world. ! my $t = wait_non_blocking $JOB_CLASS; ! while ($t) { ! if ($t->{status} eq 'errors') { ! $status = 'errors'; ! # We could do this here: ! # last SUBTGT unless $param::kflag; ! # but we should probably just build everything. ! } ! my $t = wait_non_blocking $JOB_CLASS; ! } ! ! my @not_built = grep(! defined($_->{status}), @deps); ! my @not_started = grep(! defined($_->{started}), @not_built); ! ! if (@not_started) { ! # There are dependencies that haven't even been ! # started. Put them in front of the queue, and ! # this subtgt back on the queue after them. ! # The subtgt will then have its dependencies ! # re-evaluated for dynamic changes (e.g., to a ! # generated .h file) when it comes around again. ! unshift(@subtargets, @not_started, $subtgt); ! next; ! } ! if (@not_built) { ! # All of the dependencies have at least been ! # started, but there are some still being built. ! # Arrange to have the subtgt put back on the ! # list only when all of the dependencies have ! # finished, by adding the subtgt to the ! # nofication list of each dependency. ! map(push(@{$_->{notify}}, $subtgt), @not_built); ! $subtgt->{num_deps} = @not_built; ! next; ! } ! } ! ! if (! fstart $subtgt $tgt) { ! # Now that we know we want to build this subtgt, ! # wait until a suitable slot is available. ! # (In the serial-build case, this always waits ! # for the previous target to finish.) ! while ($job::njobs >= $param::maxjobs) { ! my $t = wait_blocking $JOB_CLASS; ! if ($t->{status} eq 'errors') { ! $status = 'errors'; ! # We could do this here: ! # last SUBTGT unless $param::kflag; ! # but we should probably just build everything. ! } ! } ! ! $subtgt->{builder}->bstart($subtgt); ! if ($subtgt->{status} eq 'errors') { ! $status = 'errors'; ! last unless $param::kflag; } } } ! if ($status ne 'errors') { ! # foreach $subtgt (@tgts) { ! # fwait $subtgt; ! # if ($subtgt->{status} ne $status) { ! # $status = $subtgt->{status} ! # if $priority{$subtgt->{status}} > $priority{$status}; ! # } ! # } ! while ($jobs > 0) { ! my $subtgt = wait_blocking $JOB_CLASS; ! if ($subtgt->{status} ne $status) { ! $status = $subtgt->{status} ! if $priority{$subtgt->{status}} > $priority{$status}; ! } } ! } ! if ($status ne 'built') { ! if ($status eq "errors") { ! print qq($0: "${\$tgt->path}" not remade because of errors.\n); ! $errors++; ! } elsif ($status eq "handled") { ! print qq($0: "${\$tgt->path}" is up-to-date.\n); ! } elsif ($status eq "unknown") { ! # cons error already reported. ! $errors++; ! } elsif ($status eq "none") { ! #??? ! } else { ! print qq($0: don't know how to construct "${\$tgt->path}".\n"); #' ! $errors++; } } ! } ! } elsif ($param::rflag) { ! foreach $tgt (@targets) { ! next if $tgt->static_dependencies(\@targets); ! next if ! $tgt->{builder}; my($path) = $tgt->path; if (-f $path) { if (unlink($path)) { *************** *** 450,459 **** } } } ! ! return "none"; } # Support for "building" scripts, importing and exporting variables. # With the expection of the top-level routine here (invoked from the # main package by cons), these are all invoked by user scripts. --- 515,625 ---- } } } ! } else { ! die("$0: no support yet"); } + # Build the supplied target patterns. + #while ($tgt = shift @targets) { + # my(@tgts); + # $tgt->enumerate(\@tgts); + # if ($param::build) { + # my($status) = 'none'; + # foreach $subtgt (@tgts) { + # if (!defined $subtgt->{status}) { + # if ((fstart $subtgt $tgt) eq 'errors') { + # $status = 'errors'; + # last unless $param::kflag; + # } + # } + # } + # if ($status ne 'errors') { + # foreach $subtgt (@tgts) { + # fwait $subtgt; + # if ($subtgt->{status} ne $status) { + # $status = $subtgt->{status} + # if $priority{$subtgt->{status}} > $priority{$status}; + # } + # } + # } + # if ($status ne 'built') { + # my($path) = $tgt->path; + # if ($status eq "errors") { + # print qq($0: "$path" not remade because of errors.\n); + # $errors++; + # } elsif ($status eq "handled") { + # print qq($0: "$path" is up-to-date.\n); + # } elsif ($status eq "unknown") { + # # cons error already reported. + # $errors++; + # } elsif ($status eq "none") { + # #??? + # } else { + # print qq($0: don't know how to construct "$path".\n"); #' + # $errors++; + # } + # } + # } elsif ($param::depends) { + # foreach $subtgt (@tgts) { + # my($path) = $subtgt->path; + # if ($subtgt->{builder}) { + # my(@dep) = (@{$subtgt->{dep}}, @{$subtgt->{sources}}); + # my($dep) = join(' ',map($_->path, @dep)); + # print("$path: $dep\n"); + # } else { + # print("$path: not a derived file\n"); + # } + # } + # } elsif ($param::pflag || $param::wflag || $param::aflag) { + # foreach $subtgt (@tgts) { + # if ($subtgt->{builder}) { + # if ($param::wflag) { + # print qq(${\$subtgt->path}: $subtgt->{script}\n); + # } elsif ($param::pflag) { + # print qq(${\$subtgt->path}:\n) if $param::aflag; + # print qq(${\$subtgt->path}\n) if !$param::aflag; + # } + # if ($param::aflag) { + # $subtgt->{builder}->bstart($subtgt); + # } + # } + # } + # } elsif ($param::rflag) { + # foreach $subtgt (@tgts) { + # if ($subtgt->{builder}) { + # my($path) = $subtgt->path; + # if (-f $path) { + # if (unlink($subtgt->path)) { + # print("Removed $path\n") unless ($param::quiet); + # } else { + # warn("$0: couldn't remove $path\n"); + # } + # } + # } + # } + # } + #} + + exit 0 + ($errors != 0); + + # Recursively enumerate the supplied directory or file, and return all + # the buildable targets contained within. + #sub enumerate { + # my($list, $tgt) = @_; + # if (ref($tgt) eq "file" && exists($tgt->{builder})) { + # push(@$list, $tgt); + # } elsif (ref($tgt) eq "dir") { + # if (exists $tgt->{member}) { + # my($members) = $tgt->{member}; + # for $entry (sort keys %$members) { + # next if $entry =~ /^\./; # ignore hidden files + # my($tgt) = $members->{$entry}; + # enumerate($list, $tgt); + # } + # } + # } + #} + # Support for "building" scripts, importing and exporting variables. # With the expection of the top-level routine here (invoked from the # main package by cons), these are all invoked by user scripts. *************** *** 674,680 **** $param::salt = 'M' . $param::salt; $param::mixtargets = 1; } else { ! die qq($0: UseCache unrecognized option "$_"\n"); } } if ($param::cachedisable) { --- 840,846 ---- $param::salt = 'M' . $param::salt; $param::mixtargets = 1; } else { ! die qq($0: UseCache unrecognized option "$_"\n); } } if ($param::cachedisable) { *************** *** 762,767 **** --- 928,993 ---- $str; } + # Enumerate the library dependencies in an environment. + sub static_dependencies { + if (defined $_[0]->{libs}) { + push(@$_[1], @{$_[0]->{libs}}); + return; + } + my($env, $list) = @_; + $env->{libs} = []; + my($ewd) = $env->{_cwd}; + my($ldirs) = $env->{LIBPATH}; + if (ref($ldirs) ne 'ARRAY') { + $ldirs = [ split(/$main::PATH_SEPARATOR/o, $ldirs) ]; + } + my(@lpath) = map($ewd->lookupdir($_), @$ldirs); + my(@names); + if ($main::_WIN32) { + # Pass %LIBS symbol through %-substitution + # 1998-06-18 + @names = split(' ', $env->_subst($env->{LIBS})); + } else { + @names = split(' ', $env->{LIBS}); + } + for $name (@names) { + my($lpath, @allnames); + if ($name =~ /^-l(.*)/) { + # -l style names are looked up on LIBPATH, using all + # possible lib suffixes in the same search order the + # linker uses (according to SUFLIBS). + # Recognize new PREFLIB symbol, which should be 'lib' on + # Unix, and empty on Win32. TODO: What about shared + # library suffixes? 1998-05-13 + @allnames = map("$env->{PREFLIB}$1$_", + split(/:/, $env->{SUFLIBS})); + $lpath = \@lpath; + } else { + @allnames = ($name); + # On Win32, all library names are looked up in LIBPATH + # 1998-05-13 + if ($main::_WIN32) { + $lpath = [$dir::top, @lpath]; + } else { + $lpath = [$dir::top]; + } + } + DIR: + for $dir (@$lpath) { + for $n (@allnames) { + my($lib) = $dir->lookup($n); + if ($lib->accessible) { + if (! $lib->ignore) { + $lib->static_dependencies($list); + push(@{$env->{libs}}, $lib); + } + last DIR; + } + } + } + } + } + sub Install { my($env) = shift; my($tgtdir) = $dir::cwd->lookupdir(shift); *************** *** 932,938 **** # Generic builder module. Just a few default methods. Every derivable # file must have a builder object of some sort attached. Usually ! # builder objects are shared. package build; # Null signature for dynamic includes. --- 1158,1170 ---- # Generic builder module. Just a few default methods. Every derivable # file must have a builder object of some sort attached. Usually ! # builder objects are shared. Each subclass must provide start and ! # wait methods. Start arranges to start building the target, and ! # wait awaits completion of the build. If the action fails, the ! # status attribute of the target must be set to 'errors', otherwise ! # nothing is updated . The file package takes care of ! # making sure that only one attempt to build the target ever ! # occurs. package build; # Null signature for dynamic includes. *************** *** 944,949 **** --- 1176,1188 ---- # Not compatible with any other builder, by default. sub compatible { 0 } + # Combined start/wait action method. + sub action { + my($self, $tgt) = @_; + $self->bstart($tgt); + $self->bwait($tgt); + } + # Builder module for the Install command. package build::install; *************** *** 962,977 **** sub cachout { } # Do the installation. ! sub action { my($self, $tgt) = @_; my($src) = $tgt->{sources}[0]; main::showcom("Install ${\$src->rpath} as ${\$tgt->path}") if ($param::install && !$param::quiet); return unless $param::build; ! futil::install($src->rpath, $tgt); ! return 1; } # Builder module for generic UNIX commands. package build::command; --- 1201,1221 ---- sub cachout { } # Do the installation. ! sub bstart { my($self, $tgt) = @_; my($src) = $tgt->{sources}[0]; main::showcom("Install ${\$src->rpath} as ${\$tgt->path}") if ($param::install && !$param::quiet); return unless $param::build; ! if (! futil::install($src->rpath, $tgt)) { ! $tgt->{status} = 'errors'; ! } } + # Optimized version of these routines for install. + sub bwait { $_[1]->set_status($_[1]->{status}) } + sub action { &bstart } + # Builder module for generic UNIX commands. package build::command; *************** *** 1077,1152 **** @coms } ! # Build the target using the previously specified commands. ! sub action { my($self, $tgt) = @_; - my($env) = $self->{env}; if ($param::build) { futil::mkdir($tgt->{dir}); unlink($tgt->path); # is this done already? ! } ! ! # Set environment. ! map(delete $ENV{$_}, keys %ENV); ! %ENV = %{$env->{ENV}}; ! ! # Handle multi-line commands. ! for $com ($self->getcoms($tgt)) { ! main::showcom($com); ! if ($param::build) { ! ! #--------------------- ! # Can't fork on Win32 ! #--------------------- ! ! if ($main::_WIN32) { ! system($com); ! } else { ! my($pid) = fork(); ! die("$0: unable to fork child process ($!)\n") if !defined $pid; ! if (!$pid) { ! # This is the child. ! exec($com); ! $com =~ s/\s.*//; ! die qq($0: failed to execute "$com" ($!). ) ! . qq(Is this an executable on path "$ENV{PATH}"?\n); ! } ! for (;;) { ! do {} until wait() == $pid; ! my($b0, $b1 ) = ($? & 0xFF, $? >> 8); ! # Don't actually see 0177 on stopped process; is this necessary? ! next if $b0 == 0177; # process stopped; we can wait. ! if ($b0) { ! my($core, $sig) = ($b0 & 0200, $b0 & 0177); ! my($coremsg) = $core ? "; core dumped" : ""; ! $com =~ s/\s.*//; ! my($path) = $tgt->path; ! warn qq($0: *** [$path] $com terminated by signal $sig$coremsg\n); ! return undef; ! } ! if ($b1) { ! my($path) = $tgt->path; ! warn qq($0: *** [$path] Error $b1\n); # trying to be like make. ! return undef; ! } ! last; ! } ! } ! } ! ! if ($main::_WIN32) { ! my($err) = $?; ! if ($err) { ! my($path) = $tgt->path; ! warn qq($0: *** [$path] Error $err\n); # trying to be like make. ! return undef; ! } } ! } ! # success. ! return 1; } # Return script signature. --- 1321,1348 ---- @coms } ! # Arrange to start building the target. ! sub bstart { my($self, $tgt) = @_; if ($param::build) { + my($job); futil::mkdir($tgt->{dir}); unlink($tgt->path); # is this done already? ! $job = new $main::JOB_CLASS $tgt, $self->{env}->{ENV}, $self->getcoms($tgt); ! $tgt->{job} = $job; ! $job->jstart; ! } else { ! for $com ($self->getcoms($tgt)) { ! main::showcom($com); } ! } ! } ! sub bwait { ! my($self, $tgt) = @_; ! $tgt->{job}->jwait; ! delete $tgt->{job}; } # Return script signature. *************** *** 1425,1431 **** $self->{builder}->cachout($tgt, $sig); } ! sub action { my($self, $invoked_tgt) = @_; return $self->{built} if exists $self->{built}; --- 1621,1627 ---- $self->{builder}->cachout($tgt, $sig); } ! sub bstart { my($self, $invoked_tgt) = @_; return $self->{built} if exists $self->{built}; *************** *** 1460,1465 **** --- 1656,1665 ---- $self->{built}; } + sub bwait { + $_[1]; + } + # Generic scanning module. package scan; *************** *** 1644,1649 **** --- 1844,2067 ---- $iflags } + # Job package. This handles the scheduling of actual construction + # activity. Different job classes exist, only one of which is active + # for any given cons invocation. The job class is also reponsible + # for handling all job-related output. Note that only the serial + # class allows handling of stdin: if you have an application such + # as metaconfig that requires interaction, then this must be invoked + # with the serial class. + package job; + + use POSIX ":sys_wait_h"; + + sub new { + my($class, $tgt, $execenv, @commands) = @_; + bless {tgt => $tgt, ENV => $execenv, commands => \@commands}, $class; + } + + sub _start { + my($job, $com) = @_; + my($pid) = fork(); + die("$0: unable to fork child process ($!)\n") if !defined $pid; + if (! $pid) { + # This is the child. + exec($com); + $com =~ s/\s.*//; + die qq($0: failed to execute "$com" ($!). ) + . qq(Is this an executable on path "$ENV{PATH}"?\n); + } + # This is the parent. + $job->{com} = $com; + return $pid; + } + + sub _waitpid { + for (;;) { + my($pid) = waitpid(-1, &WNOHANG); + my($err) = $?; + if ($err) { + my($b0, $b1) = ($err & 0xFF, $err >> 8); + # Don't actually see 0177 on stopped process; is this necessary? + next if $b0 == 0177; # process stopped; we can wait. + } + return ($pid, $err); + } + } + + sub _wait { + for (;;) { + my($pid) = wait(); + my($err) = $?; + if ($err) { + my($b0, $b1) = ($err & 0xFF, $err >> 8); + # Don't actually see 0177 on stopped process; is this necessary? + next if $b0 == 0177; # process stopped; we can wait. + } + return ($pid, $err); + } + } + + sub _waiterr { + my($job, $err) = @_; + my($b0, $b1) = ($err & 0xFF, $err >> 8); + my($path) = $job->{tgt}->path; + if ($b0) { + my($core, $sig) = ($b0 & 0200, $b0 & 0177); + my($coremsg) = $core ? "; core dumped" : ""; + ($com = $job->{com}) =~ s/\s.*//; + warn qq($0: *** [$path] $com terminated by signal $sig$coremsg\n); + } + if ($b1) { + warn qq($0: *** [$path] Error $b1\n); # trying to be like make. + } + return $b1; + } + + my $njobs = 0; + + my %job; + + sub wait_non_blocking { + my($class) = @_; + my($wpid, $err) = _waitpid; + return undef if $wpid == -1; + $err = _waiterr($err) if $err; + $job{$wpid}->{tgt}->set_status($err); + #delete $job{$wpid}; + #$njobs--; + #return ($wpid, $err); + + my $tgt = $job{$wpid}; + delete $job{$wpid}; + $njobs--; + return $tgt; + } + + sub wait_blocking { + my($class) = @_; + my($wpid, $err) = _wait; + die("$0: wait returned an error ($!)\n") if $wpid == -1; + $err = _waiterr($err) if $err; + $job{$wpid}->{tgt}->set_status($err); + #delete $job{$wpid}; + #$njobs--; + #return ($wpid, $err); + + my $tgt = $job{$wpid}; + delete $job{$wpid}; + $njobs--; + return $tgt; + } + + sub jstart { + my($job) = @_; + my($pid); + + # Set environment. + map(delete $ENV{$_}, keys %ENV); + %ENV = %{$job->{ENV}}; + + #while ($njobs >= $param::maxjobs) { + # $job->wait; + #} + if (@{$job->{commands}} > 1) { + $pid = fork(); + die("$0: unable to fork child process ($!)\n") if !defined $pid; + if ($pid) { + # If there is more than one command to execute for this job, + # this is the parent. + $job->{jpid} = $pid; + $job{$pid} = $job; + $njobs++; + } else { + # If this job has more than one command to execute, this is the + # child that controls sequential execution of those commands. + # If there is only one command, then we didn't fork and + # we'll execute it directly. + main::arrange_immediate_exit(); + my($err) = 0; + foreach my $com (@{$job->{commands}}) { + main::showcom($com); + my $waitpid = $job->_start($com); + my($wpid); + do { + ($wpid, $err) = $job->_wait; + die("$0: wait returned an error ($!)\n") if $wpid == -1; + $err = $job->_waiterr($err) if $err; + } until $wpid == $waitpid; + last if $err; # stop on error and pass back the value + } + exit ($err); + } + } else { + $com = @{$job->{commands}}[0]; + main::showcom($com); + $pid = $job->_start($com); + $job->{jpid} = $pid; + $job{$pid} = $job; + $njobs++; + } + } + + # Wait for a specific job to finish. + #sub jwait { + # $_[0]->{status} || do { + # my($job) = @_; + # my($waitpid) = $job->{jpid}; + # do { + # ($wpid, $err) = $job->wait; + # } until $wpid == $waitpid; + # $job->{status}; + # } + #} + + sub on_exit { + my($save) = $?; + while ($njobs > 0) { + ($wpid, $err) = &_wait; + if (defined $job{$wpid}) { + $err = $job{$wpid}->_waiterr($err) if $err; + $job{$wpid}->{tgt}->set_status($err); + delete $job{$wpid}; + } + $njobs--; + } + $? = $save; + } + + # WIN32 job package. + # Inherit the external interface from the job package, + # and supply our own internal execution methods to take care + # of the lack of fork()/exec() on WIN32. These return a dummy + # PID of 0 to satisfy the calling requirements. + package job::win32; + + BEGIN { @ISA = qw(job) } + + sub _start { + my($job, $com) = @_; + system($com); + $job->{err} = $?; + return 0; + } + + sub _wait { + my($job) = @_; + return (0, $job->{err}); + } + + sub _waiterr { + my($job, $err) = @_; + my($path) = $job->{tgt}->path; + warn qq($0: *** [$path] Error $err\n); # trying to be like make. + return $err; + } + + sub on_exit { + return; + } + # Directory and file handling. Files/dirs are represented by objects. # Other packages are welcome to add component-specific attributes. package dir; *************** *** 1765,1770 **** --- 2183,2211 ---- die(qq($0: you have attempted to use path "$path" both as a file and as a directory!\n)); } + # Enumerate the specified directory, + # return all the buildable targets contained within. + sub static_dependencies { + if ($_[0]->{static_dependencies}) { + push(@$_[1], $_[0]->{static_dependencies}; + return; + } + my($self, $list) = @_; + if (exists $self->{member}) { + my($members) = $self->{member}; + for my $entry (sort keys %$members) { + next if $entry =~ /^\./; # ignore hidden files + my($tgt) = $members->{$entry}; + $tgt->enumerate($list); + } + } + $self->{static_dependencies} = 1; + } + + sub fstart { + return $_[0]->{status} = 'handled'; + } + package file; *************** *** 1970,1982 **** # Build the file, if necessary. sub build { ! $_[0]->{status} || &file::_build; } ! sub _build { ! my($self) = @_; ! print main::DEPFILE $self->path, "\n" if param::depfile; ! print((' ' x $level), $self->path, "\n") if $param::depends; if (!exists $self->{builder}) { # We don't know how to build the file. This is OK, if # the file is present as a source file, under either the --- 2411,2426 ---- # Build the file, if necessary. sub build { ! $_[0]->{status} || (&fstart, &fwait); } ! # Start build, asynchronously if possible. ! # Parent object may be passed in optionally for better diagnostics. ! sub fstart { ! my($self, $parent) = @_; ! # return if $self->{started}; ! # print main::DEPFILE $self->path, "\n" if param::depfile; ! # print((' ' x $level), $self->path, "\n") if $param::depends; if (!exists $self->{builder}) { # We don't know how to build the file. This is OK, if # the file is present as a source file, under either the *************** *** 1985,1993 **** return $self->{status} = 'handled'; } else { my($name) = $self->path; ! print("$0: don't know how to construct \"$name\"\n"); ! exit(1) unless $param::kflag; ! return $self->{status} = 'errors'; # xxx used to be 'unknown' } } --- 2429,2439 ---- return $self->{status} = 'handled'; } else { my($name) = $self->path; ! my($warn) = qq($0: don't know how to construct \"$name\"); ! $warn .= qq( needed by "${\$parent->path}") if $parent; ! print("$warn\n"); ! exit (1) unless $param::kflag; ! return $self->{status} = 'errors'; } } *************** *** 1996,2027 **** # on its dependendencies, then only rebuild the file if the # signature has changed. my($builder) = $self->{builder}; ! $level += 2; ! my(@deps) = (@{$self->{dep}}, @{$self->{sources}}); ! my($rdeps) = \@deps; ! if ($param::random) { ! # If requested, build in a random order, instead of the ! # order that the dependencies were listed. ! my(%rdeps); ! map { $rdeps{$_,'*' x int(rand(0,10))} = $_ } @deps; ! $rdeps = [values(%rdeps)]; ! } ! ! for $dep (@$rdeps) { ! if ((build $dep) eq 'errors') { ! # Propagate dependent errors to target. ! # but try to build all dependents regardless of errors. ! $self->{status} = 'errors'; ! } ! } ! ! # If any dependents had errors, then we abort. ! if ($self->{status} eq 'errors') { ! $level -= 2; ! return 'errors'; ! } # Compute the final signature of the file, based on # the static dependencies (in order), dynamic dependencies, --- 2442,2482 ---- # on its dependendencies, then only rebuild the file if the # signature has changed. my($builder) = $self->{builder}; ! # $level += 2; ! # my(@deps) = (@{$self->{dep}}, @{$self->{sources}}); ! # my($rdeps) = \@deps; ! # if ($param::random) { ! # # If requested, build in a random order, instead of the ! # # order that the dependencies were listed. ! # my(%rdeps); ! # map { $rdeps{$_,'*' x int(rand(10))} = $_ } @deps; ! # $rdeps = [values(%rdeps)]; ! # } ! ! # # Start any asynchronous builds we can. ! # for $dep (@$rdeps) { ! # if ((fstart $dep $self) eq 'errors') { ! # return $self->{status} = 'errors'; ! # } ! # } ! ! # # Get signatures of statically defined dependents. ! # # XXX Some question here about -k vs. not -k semantics. ! # for $dep (@$rdeps) { ! # if ((fwait $dep) eq 'errors') { ! # # Propagate dependent errors to target. ! # # but try to build all dependents regardless of errors. ! # $self->{status} = 'errors'; ! # } ! # } ! ! # # If any dependents had errors, then we abort. ! # if ($self->{status} eq 'errors') { ! # $level -= 2; ! # return 'errors'; ! # } # Compute the final signature of the file, based on # the static dependencies (in order), dynamic dependencies, *************** *** 2032,2038 **** # May have gotten errors during computation of dynamic # dependency signature, above. ! $level -= 2; return 'errors' if $self->{status} eq 'errors'; if (@param::rpath && $self->derived_exists) { --- 2487,2493 ---- # May have gotten errors during computation of dynamic # dependency signature, above. ! # $level -= 2; return 'errors' if $self->{status} eq 'errors'; if (@param::rpath && $self->derived_exists) { *************** *** 2044,2050 **** # our calculated signature). if ($self->local) { # ...but they want a local copy, so provide it. ! main::showcom("Local copy of ${\$self->path} from ${\$self->rpath}"); futil::install($self->rpath, $self); sig->set($self, $sig); } --- 2499,2506 ---- # our calculated signature). if ($self->local) { # ...but they want a local copy, so provide it. ! main::showcom("Local copy of ${\$self->path} from ${\$self->rpath}") ! unless ($param::quiet); futil::install($self->rpath, $self); sig->set($self, $sig); } *************** *** 2065,2077 **** if ($builder->cachin($self, $sig)) { sig->set($self, $sig); return $self->{status} = 'built'; - } elsif ($builder->action($self)) { - $builder->cachout($self, $sig); - sig->set($self, $sig); - return $self->{status} = 'built'; } else { ! die("$0: errors constructing ${\$self->path}\n") unless $param::kflag; ! return $self->{status} = 'errors'; } } else { # Push this out to the cache if we've been asked to (-C option). --- 2521,2530 ---- if ($builder->cachin($self, $sig)) { sig->set($self, $sig); return $self->{status} = 'built'; } else { ! # $builder->bstart($self); ! $self->{started} = $sig; ! return undef; } } else { # Push this out to the cache if we've been asked to (-C option). *************** *** 2088,2093 **** --- 2541,2573 ---- } } + # Wait for build already started. + sub fwait { + $_[0]->{status} || do { + my($self) = @_; + # We now expect bwait to set the status, preferably + # by calling the set_status method, below, so that + # the signature and cache will be handled properly. + $self->{builder}->bwait($self); + return $self->{status} + } + } + + # Set the proper errors/built status for a file. If the file is + # properly 'built', then we also push it out to the cache and set + # the signature for writing to the .consign file. + sub set_status { + my($self, $err) = @_; + if ($err) { + die("$0: errors constructing ${\$self->path}\n") unless $param::kflag; + $self->{status} = 'errors'; + } else { + $self->{builder}->cachout($self, $self->{started}); + sig->set($self, $self->{started}); + $self->{status} = 'built'; + } + } + # Bind an action to a file, with the specified sources. No return value. sub bind { my($self, $builder, @sources) = @_; *************** *** 2113,2118 **** --- 2593,2625 ---- $self->{builder} = $builder; push(@{$self->{sources}}, @sources); } + + # Enumerate the specified file, + # returning it as a buildable target. + sub static_dependencies { + return if $_[0]->{enumerated} || ! exists($_[0]->{builder}); + my($self, $list) = @_; + my(@deplist); + # Enumerate library dependencies first? + my($env) = $self->{builder}->{env}; + $env->static_dependencies(\@deplist) if $env; + # Now the static dependencies of this target. + my(@static_deps) = (@{$self->{dep}}, @{$self->{sources}}); + my($rdeps) = \@static_deps; + if ($param::random) { + # If requested, build in a random order, instead of the + # order that the dependencies were listed. + my(%rdeps); + map { $rdeps{$_,'*' x int(rand(10))} = $_ } @static_deps; + $rdeps = [values(%rdeps)]; + } + foreach my $dep (@$rdeps) { + $dep->static_dependencies(\@deplist); + } + # Give the dependencies we found to our caller. + push(@$list, @deplist, $self); + $self->{enumerated} = 1; + } # File utilities package futil; *************** *** 2174,2180 **** ($file,$sig) = split(/:/,$_); $dhash->{$file} = $sig; } ! close(HASH); } $dhash } --- 2681,2687 ---- ($file,$sig) = split(/:/,$_); $dhash->{$file} = $sig; } ! close(CONSIGN); } $dhash } *************** *** 2194,2205 **** } # Flush hash entries. Called at end or via ^C interrupt. ! sub END { return if $called++; # May be called twice. close(CONSIGN); # in case this came in via ^C. for $dir (values %sig::hash::dirty) { my($consign) = $dir->prefix . ".consign"; ! my($constemp) = $consign . ".$$"; if (! open(CONSIGN, ">$constemp")) { die("$0: can't create $constemp ($!)\n"); } --- 2701,2712 ---- } # Flush hash entries. Called at end or via ^C interrupt. ! sub on_exit { return if $called++; # May be called twice. close(CONSIGN); # in case this came in via ^C. for $dir (values %sig::hash::dirty) { my($consign) = $dir->prefix . ".consign"; ! my($constemp) = $consign . ".new"; if (! open(CONSIGN, ">$constemp")) { die("$0: can't create $constemp ($!)\n"); } *************** *** 2218,2223 **** --- 2725,2731 ---- } } } + $called--; } *************** *** 2246,2252 **** my($dir) = substr($sig, 0, 1); my($sp) = $file->path; my($cp) = "$param::cache/$dir/$sig"; ! if (-f $cp) { # Already cached: try to use that instead, to save space. # This can happen if the -cs option is used on a previously # uncached build, or if two builds occur simultaneously. --- 2754,2763 ---- my($dir) = substr($sig, 0, 1); my($sp) = $file->path; my($cp) = "$param::cache/$dir/$sig"; ! if (! -d "$param::cache/$dir") { ! mkdir("$param::cache/$dir", 0777) || ! die("$0: can't create cache directory $param::cache/$dir ($!).\n"); ! } elsif (-f $cp) { # Already cached: try to use that instead, to save space. # This can happen if the -cs option is used on a previously # uncached build, or if two builds occur simultaneously. *************** *** 2525,2530 **** --- 3036,3063 ---- the makefiles. + =item B + + One generally-accepted technique for speeding up the software development + process is to build software components in parallel--that is, start + multiple compilations simultaneously. Although the additional context + switches usually increase the CPU time used, parallelizing a build greatly + decreases the amount of "wall clock" time that the software developer + spends waiting for the build to complete. Most modern versions of make + support a -j option which is used to specify the number of tasks that + make will execute in parallel. Unfortunately, the make -j option is of + limited usefulness for builds in large directory trees, where it would be + most helpful. The recursive use of make means that even small -j values + can threaten to swamp a system, as each recursive make invocation spawns N + separate processes for subdirectories which, in turn, execute N separate + make processes for their subdirectories... Worse still, a make -j value + that works for the directory tree today may still swamp a system tomorrow + when someone adds directories to the tree structure. Lacking any way + to coordinate the total number of processes used by the entire build, + make's parall build support doesn't adapt well to changes either in the + build process itself or in the availability of system resources. + + =head1 B A few of the difficulties with make have been cited above. In this and *************** *** 3510,3515 **** --- 4043,4073 ---- subdirectories for version builds established via C to a source subdirectory. Cons will search for derived files in the appropriate build subdirectories under the repository tree. + + + =head1 B + + Like make, Cons provides a -j flag that takes an argument to specify + how many targets can be built in parallel. For example: + + % cons -j 10 . + + Will build the entire directory tree, keeping (up to) ten targets building + simultaneously in the background. + + The big difference between parallel builds with Cons and parallel builds + with make is that Cons coordinates, across the entire directory tree, + the number of simultaneous targets being built in the background. + When you use -j to specify that 10 targets can be built in parallel, + Cons will keep 10 targets building in the background, regardless of the + subdirectory in which the target resides. This allows for much greater + control over parallel builds and their impact on a system's load than + is possible with recursive use of make. + + + =item B + + T.B.S. =head1 B