use Midas
::Preprocess
':all';
use Midas
::PostProcessing
':asm';
our @EXPORT = qw(assemble_diag);
@
{$Midas::Setup
::EXPORT_TAGS
{all
}},
@
{$Midas::Preprocess
::EXPORT_TAGS
{all
}},
@
{$Midas::Setup
::EXPORT_TAGS
{internals
}},
@
{$Midas::Preprocess
::EXPORT_TAGS
{internals
}}
Exporter
::export_ok_tags
('internals', 'all');
##############################################################################
GetOptions
(\
%opt, @Options) or
fatal
"Error in arguments to assemble_diag!\n", M_ARGERR
;
tie
%phases, 'Tie::IxHash';
if(exists $opt{phase
} and defined $opt{phase
}) {
foreach my $key (keys %phases) {
foreach my $phase (@
{$opt{phase
}}) {
fatal
"No such phase $phase!\n", M_ARGERR
unless exists $phases{$phase};
$CONFIG{force_build
} = 1;
if(exists $opt{start_phase
} and defined $opt{start_phase
}) {
fatal
"No such phase $opt{start_phase}!\n", M_ARGERR
unless exists $phases{$opt{start_phase
}};
foreach my $phase (keys %phases) {
last if $phase eq $opt{start_phase
};
$CONFIG{force_build
} = 1;
if(exists $opt{state} and defined $opt{state}) {
fatal
"State argument isn't a Midas::State object!\n", M_ARGERR
unless
(ref $state) && $state->isa('Midas::State');
if(exists $opt{start_dir
} and defined $opt{start_dir
}) {
chat
"WARNING: -start_dir ignored when -state is also present.\n"
if(exists $opt{dest_dir
} and defined $opt{dest_dir
}) {
chat
"WARNING: -dest_dir ignored when -state is also present.\n"
if(exists $opt{diag_root
} and defined $opt{diag_root
}) {
chat
"WARNING: -diag_root ignored when -state is also present.\n"
$opt{start_dir
} = getcwd
unless defined $opt{start_dir
};
$opt{dest_dir
} = getcwd
unless defined $opt{dest_dir
};
$opt{diag_root
} = $ENV{DV_ROOT
} unless defined $opt{diag_root
};
init_state
($opt{diag_root
}, $opt{start_dir
}, $opt{dest_dir
});
fatal
"No diag specified to assemble_diag!\n", M_ARGERR
chat
"Running from $0\n", 2;
my $argsfile = path_to_build_file
($CONFIG{local_cmdfile
}, $STATE);
my $oldargsfile = path_to_build_file
($CONFIG{local_oldcmdfile
}, $STATE);
my $m4file = path_to_build_file
($CONFIG{local_m4
}, $STATE);
my $oldm4file = path_to_build_file
($CONFIG{local_oldm4
}, $STATE);
unlink $oldargsfile if -e
$oldargsfile;
unlink $oldm4file if -e
$oldm4file;
move
$argsfile, $oldargsfile if -e
$argsfile;
move
$m4file, $oldm4file if -e
$m4file;
setup_files
($diag) if $phases{setup
};
# Recompute these after setup since cwd has probably changed
$argsfile = path_to_build_file
($CONFIG{local_cmdfile
}, $STATE);
$oldargsfile = path_to_build_file
($CONFIG{local_oldcmdfile
}, $STATE);
$m4file = path_to_build_file
($CONFIG{local_m4
}, $STATE);
$oldm4file = path_to_build_file
($CONFIG{local_oldm4
}, $STATE);
my $ofh = IO
::File
->new(">$argsfile") or
fatal
"Can't open '$argsfile': $!\n", M_FILE
;
print $ofh "midas $opt{argv}\n";
preprocess
() if $phases{preprocess
};
if((!$CONFIG{force_build
}) and
(are_files_same
($oldargsfile, $argsfile)) and
(are_files_same
($oldm4file, $m4file)))
my @req_source_files = map { expand_product_file
($_) }
@
{$CONFIG{product_files
}{required
}};
my @opt_source_files = map { expand_product_file
($_) }
@
{$CONFIG{product_files
}{optional
}};
foreach my $req_source (@req_source_files) {
next if $req_source =~ /\*/;
$have_sources &&= (-e
$req_source);
# Want to get the right exe files. Big hack here. Create
# some application objects so that the copy phase will work correctly.
`$CONFIG{perl_cmd} -n -e 'print if /^\\s*APPLICATION/' $m4file`;
# Can't get app lines. Oh well, just build normally.
foreach my $app_line (@app_lines) {
if($app_line =~ /^\s*APPLICATION\s*(\S+)/) {
$has_default = 1 if $name eq 'default';
push @apps, 'default' unless $has_default;
foreach my $app (@apps) {
my $appobj = Midas
::Application
->new(name
=> $app);
$STATE->{apps
}{$app} = $appobj;
chat
"Same args, same input, old products still exist. ".
"My work here is done.\n", 1;
$STATE->skipping_build($skip_build);
my @product_files = map { expand_product_file
($_) }
@
{$CONFIG{product_files
}{clean
}};
my $files_string = join ' ', @product_files;
run_command
("rm -f $files_string", -errcode
=> M_FILE
);
my $gf_version = `$CONFIG{goldfinger_cmd} -version`;
fatal
"Can't find a working version of goldfinger!\n", M_GOLDFINGERMISC
;
if($gf_version < $CONFIG{goldfinger_version
}) {
my $v = $CONFIG{goldfinger_version
};
fatal
"This version of midas requires at least \n".
"version $v of goldfinger.\n".
"Found version $gf_version.\n", M_GOLDFINGERMISC
;
create_sections
() if $phases{sectioning
};
assemble_sections
() if $phases{assemble
};
link_diag
() if $phases{link};
postprocess_assembly
() if $phases{postprocess
};
copy_dest_files
() if $phases{copydest
};
cd
$STATE->get_start_dir;
assembly_cleanup
() if $phases{cleanup
};
##############################################################################
my $cmd = "$CONFIG{diff_cmd} $file1 $file2 > /dev/null 2>&1";
my $waitstatus = system($cmd);
my $exitstatus = $waitstatus >> 8;
return 1 if !$exitstatus;
return 0 if ($exitstatus == 1);
fatal
"Command '$cmd' failed with status $exitstatus.\n", M_CMDFAIL
;
##############################################################################
sub expand_product_file
{
return path_to_build_file
($CONFIG{$configname}, $STATE);
##############################################################################
return ($filename) unless $filename =~ /\*/;
foreach my $app (keys %{$STATE->{apps
}}) {
my $file = $STATE->{apps
}{$app}->expand_file($filename);
if($STATE->skipping_build and $app eq 'default'
push @list, $STATE->{apps
}{$app}->expand_file($filename);
##############################################################################
my @req_source_files = map { expand_product_file
($_) }
@
{$CONFIG{product_files
}{required
}};
my @opt_source_files = map { expand_product_file
($_) }
@
{$CONFIG{product_files
}{optional
}};
@req_source_files = map { expand_for_apps
($_); } @req_source_files;
@opt_source_files = map { expand_for_apps
($_); } @opt_source_files;
foreach my $req_src (@req_source_files) {
$file_importance{$req_src} = 'required';
foreach my $opt_src (@opt_source_files) {
$file_importance{$opt_src} = 'optional';
my @src_files = (@req_source_files, @opt_source_files);
my $dest_dir = $STATE->get_dest_dir();
return if $dest_dir eq '.';
my @dest_files = map { File
::Spec
->catfile($dest_dir, basename
$_) }
my $dest_files = join ' ', @dest_files;
run_command
("rm -f $dest_files") if @dest_files;
foreach my $src (@src_files) {
if($CONFIG{copy_products
}) {
chat
"Copying $src to '$dest_dir'.\n", 2;
fatal
"Could not copy $src to '$dest_dir': $!\n", M_FILE
;
chat
"Hard linking $src to '$dest_dir'.\n", 2;
my $dest_file = File
::Spec
->catfile($dest_dir, basename
$src);
if(not link($src, $dest_file)) {
chat
"Hard linking of $src failed. Copying instead.\n", 2;
fatal
"Could not copy $src to '$dest_dir': $!\n", M_FILE
;
if($file_importance{$src} ne 'optional') {
fatal
"$src does not exist in build dir!\n";
##############################################################################
return unless $CONFIG{cleanup
};
if($STATE->get_created_build_dir() or $CONFIG{force_cleanup
}) {
my $build_dir = $STATE->get_build_dir();
chat
"Build directory is the same as start directory. Can't remove.\n";
run_command
("rm -rf " . $STATE->get_build_dir());
chat
"Build directory already existed, so not removing it.\n";
##############################################################################
my $pushd = Midas
::Paths
->pushd($STATE->get_build_dir);
banner
"SECTION PARSING PHASE";
my $mmu = $STATE->get_mmu();
my $m4file = path_to_build_file
($CONFIG{local_m4
}, $STATE);
my $directives = path_to_build_file
($CONFIG{local_directives
}, $STATE);
my $verbose = ($CONFIG{verbose
} == 0) ?
'-silent ' :
($CONFIG{verbose
} == 2) ?
'-v ' : '';
my $error_opt = $Midas::Error
::Print_Errors ?
'' : '-noprint_errors ';
run_command
("$CONFIG{goldfinger_cmd} ${verbose}-splitsec $m4file ".
"-midasfile $directives ${error_opt}".
"-prefix '${Midas::Error::Prg}: '",
my (%sections, %section_count);
tie
%tsbs, 'Tie::IxHash';
tie
%tsblinks, 'Tie::IxHash';
my ($smartlines, $srcfile, $srcline);
my $app = Midas
::Application
->new(name
=> 'default');
$STATE->{apps
}{$app->name()} = $app;
chat
"Finding sections in $directives\n";
# First pass, create sections first so attr_ blocks can reference them
$ifh = IO
::File
->new("<$directives") or
fatal
"Can't open $directives: $!\n", M_FILE
;
my $appname = lc $app->name();
my $first_appname = $appname;
if(/^\#\s*(?:line\s*)?(\d+)\s+\"(.*)\"/) {
if(/^\s*APPLICATION\s*(\S+)\s*(.*)?$/) {
$app = Midas
::Application
->new(name
=> $name,
if(exists $apps{$appname}) {
"App '$appname' already exists at file=$srcfile, line=$srcline!\n",
$STATE->{apps
}{$name} = $app;
if(/^\s*goldfinger_cmd\s*\{/) {
$string =~ s/^\s*goldfinger_cmd\s*\{//;
if(/^\#\s*(?:line\s*)?(\d+)\s+\"(.*)\"/) {
$app->add_goldfinger_cmd($string);
if(/^\s*SECTION\s+(\S+)/) {
if(not exists $sections{$appname}{$name}) {
my $section = Midas
::Section
->new_from_line($_, $ifh,
$app->add_section($section);
$srcfile = $section->{srcfile
};
$srcline = $section->{srclinestop
};
$name = lc $section->{name
};
$sections{$appname}{$name} = $section;
} elsif(/^\s*SECTION\s+(\S+)\s+(\S.*)/) {
fatal
"SECTION '$1' declared more than once has arguments. \n".
"Arguments only permitted for the initial declaration.\n".
"file=$srcfile, line=$srcline.\n", M_SECSYNTAX
;
$section_count{$appname}{$name} = []
unless exists $section_count{$appname}{$name};
push @
{$section_count{$appname}{$name}}, {
if(/^\s*MIDAS_TSB\s+(\S+)/) {
if(not exists $tsbs{$tsbname}) {
# my $tsb = Midas::TSB->new_from_line($_, $ifh,
# $srcfile, $srcline, $mmu);
my $tsb = $mmu->create_tsb_object_from_line($_, $ifh,
$srcfile = $tsb->{srcfilestop
};
$srcline = $tsb->{srclinestop
};
fatal
"Tsb '$tsbname' declared twice!\n".
" First time, file=$tsbs{$tsbname}{srcfile}, ".
"line=$tsbs{$tsbname}{srcline}\n".
" Second time, file=$srcfile, line=$srcline.\n", M_TSBSYNTAX
;
} elsif(/^\s*MIDAS_TSB_LINK\s+(\S+)/) {
if(not exists $tsblinks{$tsblinkname}) {
# my $tsblink = Midas::TSBLink->new_from_line($_, $ifh,
my $tsblink = $mmu->create_tsb_link_object_from_line($_, $ifh,
$srcfile = $tsblink->{srcfilestop
};
$srcline = $tsblink->{srclinestop
};
$tsblinks{$tsblinkname} = $tsblink;
fatal
"Tsb_link '$tsblinkname' declared twice!\n".
" First time, file=$tsblinks{$tsblinkname}{srcfile}, ".
"line=$tsblinks{$tsblinkname}{srcline}\n".
" Second time, file=$srcfile, line=$srcline.\n", M_TSBSYNTAX
;
foreach my $tsbname (keys %tsbs) {
my $linkname = $tsbs{$tsbname}->get_tsblinkname();
$linkname = lc $linkname;
if(exists $tsblinks{$linkname}) {
$tsbs{$tsbname}->set_tsblinkobj($tsblinks{$linkname});
fatal
"TSB '$tsbname' has link area '$linkname', which is".
" at file=$tsbs{$tsbname}{srcfile}, ".
"line=$tsbs{$tsbname}{srcline}", M_TSBSYNTAX
;
$MapAttr_Settable{$tsbname} = 1;
$STATE->{tsblinks
} = \
%tsblinks;
fatal
"Diag contains no SECTION directives!\n", M_NOSEC
;
chat
"Processing directives in $directives\n";
# Pass 2, create attr_blocks
$ifh = IO
::File
->new("<$directives") or die "Can't open $directives: $!\n";
my $current_appname = $first_appname;
if(/^\#\s*(?:line\s*)?(\d+)\s+\"(.*)\"/) {
if(/^\s*APPLICATION\s+(\S+)/) {
$current_appname = $appname;
if(/^\s*SECTION\s+(\S+)/) {
my $section = $sections{$current_appname}{$secname};
$current_section = $section;
my $rec = shift @
{$section_count{$current_appname}{$secname}};
$srcfile = $rec->{srcfile
};
$srcline = $rec->{srcline
};
if(not $opened_sec{$current_appname}{$secname}) {
push @sections, $section;
$opened_sec{$current_appname}{$secname} = 1;
my $nextline = $srcline + 1;
if(/^\s*attr_(\S+)\s*\{/) {
my $attrs = $mmu->parse_section_attrs($_, $ifh,
($srcfile, $srcline) = $attrs->get_end_file_line();
my $secname = $attrs->get_section_name();
$attrs->attr_fatal("attr block does not define a section!\n", M_NOSEC
)
unless defined $secname && $secname =~ /\S/;
fatal
"Attribute spec for section \"$secname\" but no such section.\n".
"File=$srcfile, Line=$srcline\n", M_MISSINGPARAM
unless exists $sections{$current_appname}{$secname};
my $section = $sections{$current_appname}{$secname};
$attrs->secobj($section);
$section->add_attrs($attrs);
if(/^\s*MIDAS_CC\s*(.*?)\s*$/) {
fatal
"MIDAS_CC directive outside any section at line=$srcline, ".
"file=$srcfile\n", M_DIRECTIVESYNTAX
unless defined $current_section;
$current_section->parse_midas_cc_line($1, $srcline, $srcfile);
if(/^\s*MIDAS_OBJ\s*(.*?)\s*$/) {
fatal
"MIDAS_OBJ directive outside any section at line=$srcline, ".
"file=$srcfile\n", M_DIRECTIVESYNTAX
unless defined $current_section;
$current_section->parse_midas_obj_line($1, $srcline, $srcfile);
if(/^\s*MIDAS_LIB\s*(.*?)\s*$/) {
fatal
"MIDAS_LIB directive outside any section at line=$srcline, ".
"file=$srcfile\n", M_DIRECTIVESYNTAX
unless defined $current_section;
$current_section->parse_midas_lib_line($1, $srcline, $srcfile);
chat
"Performing sanity check on arguments.\n";
foreach my $section (@sections) {
push @errors, $section->sanity_check();
my $errorcode = $errors[0]{code
};
my $message = join "\n", map { $_->{message
} } @errors;
fatal
$message, $errorcode;
foreach my $appname (keys %{$STATE->{apps
}}) {
delete $STATE->{apps
}{$appname} if $STATE->{apps
}{$appname}->is_blank();
foreach my $s (@sections) {
##############################################################################
sub write_linker_scripts
{
my $pushd = Midas
::Paths
->pushd($STATE->get_build_dir);
# mmu must exist or we never would have been able to create sections
foreach my $app (keys %{$STATE->{apps
}}) {
next if $STATE->{apps
}{$app}->is_linked();
my @sec_list = $STATE->{apps
}{$app}->get_sec_list();
my $script_name = $STATE->{apps
}{$app}->ldscr_name();
my $script = path_to_build_file
($script_name, $STATE);
chat
"Writing linker script $script.\n";
my $ofh = IO
::File
->new(">$script") or die "Can't open $script: $!\n";
# Add support for N2's PHDR command to minimize diag.exe file size.
my @phdr_arr = (); # ARRAY for PHDRS
my @sect_arr = (); # ARRAY for SECTIONS
my $addphdr = ( $CONFIG{addphdr
} == 1 ) && ($PROJECT eq "N2");
push @phdr_arr, $phdr_str;
#$ofh->print("SECTIONS {\n");
$sect_str = "SECTIONS {\n";
push @sect_arr, $sect_str;
foreach my $sec (@sec_list) {
my $link_attrs = [$sec->get_link_attrs()]->[0];
my @olist = map { basename
$_ } $sec->get_object_list();
my @alist = map { basename
$_ } $sec->get_library_list(); #libs after .o
foreach my $seg (Midas
::Segment
->all_names()) {
if ($link_attrs->has_segment($seg)) {
my $linkname = $sec->get_segment_link_name($seg);
my $elfname = Midas
::Segment
->name2elf_name($seg);
my $filespec = join " ", map { "$_ ($elfname)" } @olist;
my $addrspec = $link_attrs->get_segment_va($seg) . " :";
#$ofh->print("$linkname $addrspec { $filespec }\n");
my $phdr_name = "p" . $linkname;
$phdr_str = "$phdr_name PT_LOAD;\n";
push @phdr_arr, $phdr_str;
$sect_str = "$linkname $addrspec { $filespec } :$phdr_name\n";
push @sect_arr, $sect_str;
} else { # no need to add PHDR coommands
$sect_str = "$linkname $addrspec { $filespec }\n";
push @sect_arr, $sect_str;
foreach my $pstr ( @phdr_arr ) {
foreach my $sects ( @sect_arr ) {
##############################################################################
foreach my $app_name (keys %{$STATE->{apps
}}) {
my $app = $STATE->{apps
}{$app_name};
my @sections = $app->get_sec_list();
build_sections
(\
@sections) if @sections;
##############################################################################
my $pushd = Midas
::Paths
->pushd($STATE->get_build_dir);
my $num_threads = $CONFIG{build_threads
};
$num_threads = 1 if $num_threads < 1;
my $num_sections = @
$seclist;
return unless $num_sections;
$num_threads = $num_sections if $num_sections < $num_threads;
my $sec_pl = ($num_sections > 1) ?
's' : '';
my $thd_pl = ($num_threads > 1) ?
's' : '';
chat
"Building $num_sections section$sec_pl using $num_threads ".
"build thread$thd_pl.\n";
foreach my $section (@
$seclist) {
foreach my $section (@
$seclist) {
my $thread = $num_section % $num_threads;
$thread_sections[$thread] = [] unless defined $thread_sections[$thread];
push @
{$thread_sections[$thread]}, $section;
my $threads_to_spawn = $num_threads - 1;
my $next_thread = $my_thread + 1;
while($threads_to_spawn) {
$my_thread = $next_thread;
fatal
"Cannot fork thread $next_thread: $!\n", M_CODE
;
chat
"Build thread $my_thread is alive!\n", 3;
foreach my $section (@
{$thread_sections[$my_thread]}) {
chat
"Building section $section->{name} on thread $my_thread\n", 3;
foreach my $pid (@child_pids) {
$waitval = waitpid($pid, 0);
my $status = $waitstatus >> 8;
# Child thread has died with nonzero status
my $waitstatus_hex = sprintf "%x", $waitstatus;
fatal
"Build thread with pid=$pid died with status $status ".
"(waitstauts=0x$waitstatus_hex).\n", $status;
##############################################################################
my $pushd = Midas
::Paths
->pushd($STATE->get_build_dir);
foreach my $app (keys %{$STATE->{apps
}}) {
my $appobj = $STATE->{apps
}{$app};
next if $appobj->is_linked();
my $ldscript_name = $appobj->ldscr_name();
my $exe_name = $appobj->exe_name();
my $ldscript = path_to_build_file
($ldscript_name, $STATE);
my $exe = path_to_build_file
($exe_name, $STATE);
my $args = join ' ', @
{$CONFIG{ld_opt
}};
run_command
("$CONFIG{ld_cmd} $args -T $ldscript -o $exe",
chat
"$exe successfully created.\n";
fatal
"$exe could not be generated.\n", M_LINKFAIL
;
##############################################################################