| 1 | # -*- perl -*- |
| 2 | |
| 3 | package Midas::Assembly; |
| 4 | use strict; |
| 5 | use warnings; |
| 6 | |
| 7 | use File::Copy; |
| 8 | use File::Spec; |
| 9 | use Getopt::Long; |
| 10 | use Cwd; |
| 11 | use IO::File; |
| 12 | use File::Basename; |
| 13 | use Tie::IxHash; |
| 14 | |
| 15 | use Midas::Setup ':all'; |
| 16 | use Midas::Preprocess ':all'; |
| 17 | |
| 18 | use Midas::State; |
| 19 | use Midas::Globals; |
| 20 | use Midas::Configure; |
| 21 | use Midas::Paths; |
| 22 | use Midas::Command; |
| 23 | use Midas::PostProcessing ':asm'; |
| 24 | use Midas::Error; |
| 25 | use Midas::Segment; |
| 26 | use Midas::Section; |
| 27 | |
| 28 | |
| 29 | use Midas::TSB; |
| 30 | |
| 31 | require Exporter; |
| 32 | |
| 33 | our @ISA = qw(Exporter); |
| 34 | our @EXPORT = qw(assemble_diag); |
| 35 | our @EXPORT_OK = qw(); |
| 36 | |
| 37 | our %EXPORT_TAGS = |
| 38 | ( |
| 39 | 'all' => [ |
| 40 | @{$Midas::Setup::EXPORT_TAGS{all}}, |
| 41 | @{$Midas::Preprocess::EXPORT_TAGS{all}}, |
| 42 | |
| 43 | qw( |
| 44 | create_sections |
| 45 | assemble_sections |
| 46 | |
| 47 | create_sections |
| 48 | write_linker_scripts |
| 49 | ), |
| 50 | ], |
| 51 | internals => [ qw( |
| 52 | setup_files |
| 53 | preprocess |
| 54 | create_sections |
| 55 | assemble_sections |
| 56 | assembly_cleanup |
| 57 | |
| 58 | create_sections |
| 59 | write_linker_scripts |
| 60 | ), |
| 61 | @{$Midas::Setup::EXPORT_TAGS{internals}}, |
| 62 | @{$Midas::Preprocess::EXPORT_TAGS{internals}} |
| 63 | ], |
| 64 | ); |
| 65 | Exporter::export_ok_tags('internals', 'all'); |
| 66 | |
| 67 | our @Options = qw( |
| 68 | start_dir=s |
| 69 | dest_dir=s |
| 70 | diag_root=s |
| 71 | phase=s@ |
| 72 | start_phase=s |
| 73 | state=s |
| 74 | argv=s |
| 75 | ); |
| 76 | |
| 77 | |
| 78 | ############################################################################## |
| 79 | |
| 80 | sub assemble_diag { |
| 81 | my @args = @_; |
| 82 | |
| 83 | my %opt = ( |
| 84 | ); |
| 85 | local (@ARGV) = @args; |
| 86 | |
| 87 | GetOptions(\%opt, @Options) or |
| 88 | fatal "Error in arguments to assemble_diag!\n", M_ARGERR; |
| 89 | |
| 90 | init_section(); |
| 91 | |
| 92 | my %phases; |
| 93 | tie %phases, 'Tie::IxHash'; |
| 94 | %phases = |
| 95 | ( |
| 96 | setup => 1, |
| 97 | preprocess => 1, |
| 98 | sectioning => 1, |
| 99 | assemble => 1, |
| 100 | link => 1, |
| 101 | postprocess => 1, |
| 102 | copydest => 1, |
| 103 | cleanup => 1, |
| 104 | ); |
| 105 | |
| 106 | if(exists $opt{phase} and defined $opt{phase}) { |
| 107 | foreach my $key (keys %phases) { |
| 108 | $phases{$key} = 0; |
| 109 | } |
| 110 | foreach my $phase (@{$opt{phase}}) { |
| 111 | fatal "No such phase $phase!\n", M_ARGERR |
| 112 | unless exists $phases{$phase}; |
| 113 | $phases{$phase} = 1; |
| 114 | } |
| 115 | $CONFIG{force_build} = 1; |
| 116 | } |
| 117 | |
| 118 | if(exists $opt{start_phase} and defined $opt{start_phase}) { |
| 119 | fatal "No such phase $opt{start_phase}!\n", M_ARGERR |
| 120 | unless exists $phases{$opt{start_phase}}; |
| 121 | foreach my $phase (keys %phases) { |
| 122 | last if $phase eq $opt{start_phase}; |
| 123 | $phases{$phase} = 0; |
| 124 | } |
| 125 | $CONFIG{force_build} = 1; |
| 126 | } |
| 127 | |
| 128 | if(exists $opt{state} and defined $opt{state}) { |
| 129 | |
| 130 | my $state = $opt{state}; |
| 131 | |
| 132 | fatal "State argument isn't a Midas::State object!\n", M_ARGERR unless |
| 133 | (ref $state) && $state->isa('Midas::State'); |
| 134 | |
| 135 | if(exists $opt{start_dir} and defined $opt{start_dir}) { |
| 136 | chat "WARNING: -start_dir ignored when -state is also present.\n" |
| 137 | } |
| 138 | if(exists $opt{dest_dir} and defined $opt{dest_dir}) { |
| 139 | chat "WARNING: -dest_dir ignored when -state is also present.\n" |
| 140 | } |
| 141 | if(exists $opt{diag_root} and defined $opt{diag_root}) { |
| 142 | chat "WARNING: -diag_root ignored when -state is also present.\n" |
| 143 | } |
| 144 | |
| 145 | $STATE = $state |
| 146 | |
| 147 | } else { |
| 148 | $opt{start_dir} = getcwd unless defined $opt{start_dir}; |
| 149 | $opt{dest_dir} = getcwd unless defined $opt{dest_dir}; |
| 150 | $opt{diag_root} = $ENV{DV_ROOT} unless defined $opt{diag_root}; |
| 151 | $STATE = |
| 152 | init_state($opt{diag_root}, $opt{start_dir}, $opt{dest_dir}); |
| 153 | } |
| 154 | |
| 155 | my $diag = shift @ARGV; |
| 156 | fatal "No diag specified to assemble_diag!\n", M_ARGERR |
| 157 | unless defined $diag; |
| 158 | |
| 159 | chat "Running from $0\n", 2; |
| 160 | |
| 161 | my $argsfile = path_to_build_file($CONFIG{local_cmdfile}, $STATE); |
| 162 | my $oldargsfile = path_to_build_file($CONFIG{local_oldcmdfile}, $STATE); |
| 163 | my $m4file = path_to_build_file($CONFIG{local_m4}, $STATE); |
| 164 | my $oldm4file = path_to_build_file($CONFIG{local_oldm4}, $STATE); |
| 165 | |
| 166 | |
| 167 | unlink $oldargsfile if -e $oldargsfile; |
| 168 | unlink $oldm4file if -e $oldm4file; |
| 169 | |
| 170 | move $argsfile, $oldargsfile if -e $argsfile; |
| 171 | move $m4file, $oldm4file if -e $m4file; |
| 172 | |
| 173 | my $skip_build = 0; |
| 174 | setup_files($diag) if $phases{setup}; |
| 175 | |
| 176 | |
| 177 | # Recompute these after setup since cwd has probably changed |
| 178 | $argsfile = path_to_build_file($CONFIG{local_cmdfile}, $STATE); |
| 179 | $oldargsfile = path_to_build_file($CONFIG{local_oldcmdfile}, $STATE); |
| 180 | $m4file = path_to_build_file($CONFIG{local_m4}, $STATE); |
| 181 | $oldm4file = path_to_build_file($CONFIG{local_oldm4}, $STATE); |
| 182 | |
| 183 | |
| 184 | if($opt{argv}) { |
| 185 | my $ofh = IO::File->new(">$argsfile") or |
| 186 | fatal "Can't open '$argsfile': $!\n", M_FILE; |
| 187 | |
| 188 | print $ofh "midas $opt{argv}\n"; |
| 189 | undef $ofh; |
| 190 | } |
| 191 | |
| 192 | |
| 193 | preprocess() if $phases{preprocess}; |
| 194 | |
| 195 | if((!$CONFIG{force_build}) and |
| 196 | (-e $oldargsfile) and |
| 197 | (-e $oldm4file) and |
| 198 | (-e $argsfile) and |
| 199 | (are_files_same($oldargsfile, $argsfile)) and |
| 200 | (are_files_same($oldm4file, $m4file))) |
| 201 | { |
| 202 | |
| 203 | my @req_source_files = map { expand_product_file($_) } |
| 204 | @{$CONFIG{product_files}{required}}; |
| 205 | my @opt_source_files = map { expand_product_file($_) } |
| 206 | @{$CONFIG{product_files}{optional}}; |
| 207 | |
| 208 | my $have_sources = 1; |
| 209 | foreach my $req_source (@req_source_files) { |
| 210 | next if $req_source =~ /\*/; |
| 211 | $have_sources &&= (-e $req_source); |
| 212 | } |
| 213 | if($have_sources) { |
| 214 | |
| 215 | |
| 216 | # Want to get the right exe files. Big hack here. Create |
| 217 | # some application objects so that the copy phase will work correctly. |
| 218 | |
| 219 | my @app_lines = |
| 220 | `$CONFIG{perl_cmd} -n -e 'print if /^\\s*APPLICATION/' $m4file`; |
| 221 | |
| 222 | if($@) { |
| 223 | # Can't get app lines. Oh well, just build normally. |
| 224 | } else { |
| 225 | |
| 226 | my @apps; |
| 227 | my $has_default = 0; |
| 228 | foreach my $app_line (@app_lines) { |
| 229 | if($app_line =~ /^\s*APPLICATION\s*(\S+)/) { |
| 230 | my $name = $1; |
| 231 | $has_default = 1 if $name eq 'default'; |
| 232 | push @apps, $name; |
| 233 | } |
| 234 | } |
| 235 | push @apps, 'default' unless $has_default; |
| 236 | |
| 237 | foreach my $app (@apps) { |
| 238 | my $appobj = Midas::Application->new(name => $app); |
| 239 | $STATE->{apps}{$app} = $appobj; |
| 240 | } |
| 241 | |
| 242 | |
| 243 | chat "Same args, same input, old products still exist. ". |
| 244 | "My work here is done.\n", 1; |
| 245 | $skip_build = 1; |
| 246 | |
| 247 | } |
| 248 | } |
| 249 | } |
| 250 | |
| 251 | $STATE->skipping_build($skip_build); |
| 252 | |
| 253 | if(not $skip_build) { |
| 254 | |
| 255 | my @product_files = map { expand_product_file($_) } |
| 256 | @{$CONFIG{product_files}{clean}}; |
| 257 | |
| 258 | if(@product_files) { |
| 259 | my $files_string = join ' ', @product_files; |
| 260 | run_command("rm -f $files_string", -errcode => M_FILE); |
| 261 | } |
| 262 | |
| 263 | |
| 264 | my $gf_version = `$CONFIG{goldfinger_cmd} -version`; |
| 265 | chomp $gf_version; |
| 266 | if($?) { |
| 267 | fatal "Can't find a working version of goldfinger!\n", M_GOLDFINGERMISC; |
| 268 | } |
| 269 | |
| 270 | if($gf_version < $CONFIG{goldfinger_version}) { |
| 271 | my $v = $CONFIG{goldfinger_version}; |
| 272 | fatal "This version of midas requires at least \n". |
| 273 | "version $v of goldfinger.\n". |
| 274 | "Found version $gf_version.\n", M_GOLDFINGERMISC; |
| 275 | |
| 276 | } |
| 277 | |
| 278 | |
| 279 | create_sections() if $phases{sectioning}; |
| 280 | assemble_sections() if $phases{assemble}; |
| 281 | |
| 282 | |
| 283 | link_diag() if $phases{link}; |
| 284 | |
| 285 | postprocess_assembly() if $phases{postprocess}; |
| 286 | |
| 287 | } |
| 288 | |
| 289 | copy_dest_files() if $phases{copydest}; |
| 290 | cd $STATE->get_start_dir; |
| 291 | |
| 292 | assembly_cleanup() if $phases{cleanup}; |
| 293 | |
| 294 | } |
| 295 | |
| 296 | ############################################################################## |
| 297 | |
| 298 | sub are_files_same { |
| 299 | my $file1 = shift; |
| 300 | my $file2 = shift; |
| 301 | |
| 302 | my $cmd = "$CONFIG{diff_cmd} $file1 $file2 > /dev/null 2>&1"; |
| 303 | my $waitstatus = system($cmd); |
| 304 | my $exitstatus = $waitstatus >> 8; |
| 305 | |
| 306 | return 1 if !$exitstatus; |
| 307 | return 0 if ($exitstatus == 1); |
| 308 | fatal "Command '$cmd' failed with status $exitstatus.\n", M_CMDFAIL; |
| 309 | } |
| 310 | |
| 311 | ############################################################################## |
| 312 | |
| 313 | sub expand_product_file { |
| 314 | my $configname = shift; |
| 315 | |
| 316 | return path_to_build_file($CONFIG{$configname}, $STATE); |
| 317 | } |
| 318 | |
| 319 | ############################################################################## |
| 320 | |
| 321 | sub expand_for_apps { |
| 322 | my $filename = shift; |
| 323 | |
| 324 | return ($filename) unless $filename =~ /\*/; |
| 325 | |
| 326 | my @list; |
| 327 | foreach my $app (keys %{$STATE->{apps}}) { |
| 328 | my $file = $STATE->{apps}{$app}->expand_file($filename); |
| 329 | |
| 330 | if($STATE->skipping_build and $app eq 'default' |
| 331 | and not -e $file) |
| 332 | { |
| 333 | next; |
| 334 | } |
| 335 | |
| 336 | push @list, $STATE->{apps}{$app}->expand_file($filename); |
| 337 | } |
| 338 | return @list; |
| 339 | } |
| 340 | |
| 341 | ############################################################################## |
| 342 | |
| 343 | sub copy_dest_files { |
| 344 | local ($_); |
| 345 | |
| 346 | my @req_source_files = map { expand_product_file($_) } |
| 347 | @{$CONFIG{product_files}{required}}; |
| 348 | my @opt_source_files = map { expand_product_file($_) } |
| 349 | @{$CONFIG{product_files}{optional}}; |
| 350 | |
| 351 | |
| 352 | @req_source_files = map { expand_for_apps($_); } @req_source_files; |
| 353 | @opt_source_files = map { expand_for_apps($_); } @opt_source_files; |
| 354 | |
| 355 | my %file_importance; |
| 356 | foreach my $req_src (@req_source_files) { |
| 357 | $file_importance{$req_src} = 'required'; |
| 358 | } |
| 359 | foreach my $opt_src (@opt_source_files) { |
| 360 | $file_importance{$opt_src} = 'optional'; |
| 361 | } |
| 362 | |
| 363 | my @src_files = (@req_source_files, @opt_source_files); |
| 364 | |
| 365 | my $dest_dir = $STATE->get_dest_dir(); |
| 366 | return if $dest_dir eq '.'; |
| 367 | |
| 368 | banner "COPY PHASE"; |
| 369 | |
| 370 | my @dest_files = map { File::Spec->catfile($dest_dir, basename $_) } |
| 371 | @src_files; |
| 372 | |
| 373 | my $dest_files = join ' ', @dest_files; |
| 374 | run_command("rm -f $dest_files") if @dest_files; |
| 375 | |
| 376 | foreach my $src (@src_files) { |
| 377 | if(-e $src) { |
| 378 | if($CONFIG{copy_products}) { |
| 379 | chat "Copying $src to '$dest_dir'.\n", 2; |
| 380 | copy $src, $dest_dir or |
| 381 | fatal "Could not copy $src to '$dest_dir': $!\n", M_FILE; |
| 382 | } else { |
| 383 | chat "Hard linking $src to '$dest_dir'.\n", 2; |
| 384 | my $dest_file = File::Spec->catfile($dest_dir, basename $src); |
| 385 | if(not link($src, $dest_file)) { |
| 386 | chat "Hard linking of $src failed. Copying instead.\n", 2; |
| 387 | copy $src, $dest_dir or |
| 388 | fatal "Could not copy $src to '$dest_dir': $!\n", M_FILE; |
| 389 | } |
| 390 | |
| 391 | } |
| 392 | } else { |
| 393 | if($file_importance{$src} ne 'optional') { |
| 394 | fatal "$src does not exist in build dir!\n"; |
| 395 | } |
| 396 | } |
| 397 | } |
| 398 | } |
| 399 | |
| 400 | ############################################################################## |
| 401 | |
| 402 | sub assembly_cleanup { |
| 403 | return unless $CONFIG{cleanup}; |
| 404 | |
| 405 | banner "CLEANUP PHASE"; |
| 406 | |
| 407 | if($STATE->get_created_build_dir() or $CONFIG{force_cleanup}) { |
| 408 | my $build_dir = $STATE->get_build_dir(); |
| 409 | if($build_dir eq '.') { |
| 410 | chat "Build directory is the same as start directory. Can't remove.\n"; |
| 411 | } else { |
| 412 | run_command("rm -rf " . $STATE->get_build_dir()); |
| 413 | } |
| 414 | } else { |
| 415 | chat "Build directory already existed, so not removing it.\n"; |
| 416 | } |
| 417 | } |
| 418 | |
| 419 | ############################################################################## |
| 420 | |
| 421 | sub create_sections { |
| 422 | my $pushd = Midas::Paths->pushd($STATE->get_build_dir); |
| 423 | |
| 424 | banner "SECTION PARSING PHASE"; |
| 425 | |
| 426 | my $mmu = $STATE->get_mmu(); |
| 427 | |
| 428 | my $m4file = path_to_build_file($CONFIG{local_m4}, $STATE); |
| 429 | |
| 430 | my $directives = path_to_build_file($CONFIG{local_directives}, $STATE); |
| 431 | |
| 432 | |
| 433 | my $verbose = ($CONFIG{verbose} == 0) ? '-silent ' : |
| 434 | ($CONFIG{verbose} == 2) ? '-v ' : ''; |
| 435 | |
| 436 | my $error_opt = $Midas::Error::Print_Errors ? '' : '-noprint_errors '; |
| 437 | |
| 438 | run_command("$CONFIG{goldfinger_cmd} ${verbose}-splitsec $m4file ". |
| 439 | "-midasfile $directives ${error_opt}". |
| 440 | "-prefix '${Midas::Error::Prg}: '", |
| 441 | '-pass_errcode', |
| 442 | ); |
| 443 | |
| 444 | my (%sections, %section_count); |
| 445 | my (%tsbs,%tsblinks ); |
| 446 | tie %tsbs, 'Tie::IxHash'; |
| 447 | tie %tsblinks, 'Tie::IxHash'; |
| 448 | local ($_); |
| 449 | |
| 450 | my ($ifh, $ofh); |
| 451 | my ($smartlines, $srcfile, $srcline); |
| 452 | |
| 453 | my $num_secs = 0; |
| 454 | |
| 455 | my $app = Midas::Application->new(name => 'default'); |
| 456 | $STATE->{apps}{$app->name()} = $app; |
| 457 | |
| 458 | chat "Finding sections in $directives\n"; |
| 459 | # First pass, create sections first so attr_ blocks can reference them |
| 460 | $ifh = IO::File->new("<$directives") or |
| 461 | fatal "Can't open $directives: $!\n", M_FILE; |
| 462 | |
| 463 | $smartlines = 0; |
| 464 | $srcfile = $m4file; |
| 465 | $srcline = 0; |
| 466 | my %apps; |
| 467 | my $appname = lc $app->name(); |
| 468 | my $first_appname = $appname; |
| 469 | while(<$ifh>) { |
| 470 | if(/^\#\s*(?:line\s*)?(\d+)\s+\"(.*)\"/) { |
| 471 | $srcline = $1 - 1; |
| 472 | $srcfile = $2; |
| 473 | $smartlines = 1; |
| 474 | } else { |
| 475 | $srcline++; |
| 476 | } |
| 477 | |
| 478 | while($_ =~ /\\$/) { |
| 479 | $_ =~ s/\\\n$/ /; |
| 480 | $_ .= <$ifh>; |
| 481 | $srcline++; |
| 482 | } |
| 483 | |
| 484 | if(/^\s*APPLICATION\s*(\S+)\s*(.*)?$/) { |
| 485 | my $name = $1; |
| 486 | my $args = $2; |
| 487 | |
| 488 | $app = Midas::Application->new(name => $name, |
| 489 | srcfile => $srcfile, |
| 490 | srcline => $srcline, |
| 491 | args => $args, |
| 492 | ); |
| 493 | $appname = lc $name; |
| 494 | if(exists $apps{$appname}) { |
| 495 | fatal |
| 496 | "App '$appname' already exists at file=$srcfile, line=$srcline!\n", |
| 497 | M_APPSYNTAX; |
| 498 | } |
| 499 | |
| 500 | $apps{$appname} = $app; |
| 501 | |
| 502 | $STATE->{apps}{$name} = $app; |
| 503 | } |
| 504 | |
| 505 | if(/^\s*goldfinger_cmd\s*\{/) { |
| 506 | my $string = $_; |
| 507 | $string =~ s/^\s*goldfinger_cmd\s*\{//; |
| 508 | |
| 509 | if($string =~ /\}/) { |
| 510 | $string =~ s/\}//; |
| 511 | } else { |
| 512 | while(<$ifh>) { |
| 513 | if(/^\#\s*(?:line\s*)?(\d+)\s+\"(.*)\"/) { |
| 514 | $srcline = $1 - 1; |
| 515 | $srcfile = $2; |
| 516 | $smartlines = 1; |
| 517 | } else { |
| 518 | $srcline++; |
| 519 | } |
| 520 | |
| 521 | my $line = $_; |
| 522 | if($line =~ s/\}//) { |
| 523 | $string .= $line; |
| 524 | last; |
| 525 | } else { |
| 526 | $string .= $line; |
| 527 | } |
| 528 | |
| 529 | } |
| 530 | } |
| 531 | |
| 532 | $app->add_goldfinger_cmd($string); |
| 533 | } |
| 534 | |
| 535 | if(/^\s*SECTION\s+(\S+)/) { |
| 536 | my $name = lc $1; |
| 537 | |
| 538 | if(not exists $sections{$appname}{$name}) { |
| 539 | |
| 540 | my $section = Midas::Section->new_from_line($_, $ifh, |
| 541 | $srcfile, $srcline, |
| 542 | $app); |
| 543 | |
| 544 | $app->add_section($section); |
| 545 | |
| 546 | $srcfile = $section->{srcfile}; |
| 547 | $srcline = $section->{srclinestop}; |
| 548 | |
| 549 | $name = lc $section->{name}; |
| 550 | |
| 551 | $sections{$appname}{$name} = $section; |
| 552 | $num_secs++; |
| 553 | } elsif(/^\s*SECTION\s+(\S+)\s+(\S.*)/) { |
| 554 | fatal "SECTION '$1' declared more than once has arguments. \n". |
| 555 | "Arguments only permitted for the initial declaration.\n". |
| 556 | "file=$srcfile, line=$srcline.\n", M_SECSYNTAX; |
| 557 | } |
| 558 | |
| 559 | $section_count{$appname}{$name} = [] |
| 560 | unless exists $section_count{$appname}{$name}; |
| 561 | push @{$section_count{$appname}{$name}}, { |
| 562 | srcfile => $srcfile, |
| 563 | srcline => $srcline, |
| 564 | }; |
| 565 | } |
| 566 | if(/^\s*MIDAS_TSB\s+(\S+)/) { |
| 567 | my $tsbname = lc $1; |
| 568 | |
| 569 | if(not exists $tsbs{$tsbname}) { |
| 570 | # my $tsb = Midas::TSB->new_from_line($_, $ifh, |
| 571 | # $srcfile, $srcline, $mmu); |
| 572 | my $tsb = $mmu->create_tsb_object_from_line($_, $ifh, |
| 573 | $srcfile, $srcline); |
| 574 | |
| 575 | $srcfile = $tsb->{srcfilestop}; |
| 576 | $srcline = $tsb->{srclinestop}; |
| 577 | $tsbs{$tsbname} = $tsb; |
| 578 | } else { |
| 579 | fatal "Tsb '$tsbname' declared twice!\n". |
| 580 | " First time, file=$tsbs{$tsbname}{srcfile}, ". |
| 581 | "line=$tsbs{$tsbname}{srcline}\n". |
| 582 | " Second time, file=$srcfile, line=$srcline.\n", M_TSBSYNTAX; |
| 583 | } |
| 584 | } elsif(/^\s*MIDAS_TSB_LINK\s+(\S+)/) { |
| 585 | my $tsblinkname = lc $1; |
| 586 | |
| 587 | if(not exists $tsblinks{$tsblinkname}) { |
| 588 | # my $tsblink = Midas::TSBLink->new_from_line($_, $ifh, |
| 589 | # $srcfile, $srcline, |
| 590 | # $mmu); |
| 591 | |
| 592 | my $tsblink = $mmu->create_tsb_link_object_from_line($_, $ifh, |
| 593 | $srcfile, |
| 594 | $srcline); |
| 595 | |
| 596 | |
| 597 | $srcfile = $tsblink->{srcfilestop}; |
| 598 | $srcline = $tsblink->{srclinestop}; |
| 599 | $tsblinks{$tsblinkname} = $tsblink; |
| 600 | } else { |
| 601 | fatal "Tsb_link '$tsblinkname' declared twice!\n". |
| 602 | " First time, file=$tsblinks{$tsblinkname}{srcfile}, ". |
| 603 | "line=$tsblinks{$tsblinkname}{srcline}\n". |
| 604 | " Second time, file=$srcfile, line=$srcline.\n", M_TSBSYNTAX; |
| 605 | } |
| 606 | } |
| 607 | } |
| 608 | undef $ifh; |
| 609 | |
| 610 | foreach my $tsbname (keys %tsbs) { |
| 611 | my $linkname = $tsbs{$tsbname}->get_tsblinkname(); |
| 612 | |
| 613 | if(defined $linkname) { |
| 614 | $linkname = lc $linkname; |
| 615 | if(exists $tsblinks{$linkname}) { |
| 616 | $tsbs{$tsbname}->set_tsblinkobj($tsblinks{$linkname}); |
| 617 | } else { |
| 618 | fatal "TSB '$tsbname' has link area '$linkname', which is". |
| 619 | " undefined!\n". |
| 620 | " at file=$tsbs{$tsbname}{srcfile}, ". |
| 621 | "line=$tsbs{$tsbname}{srcline}", M_TSBSYNTAX; |
| 622 | } |
| 623 | } |
| 624 | |
| 625 | $MapAttr_Settable{$tsbname} = 1; |
| 626 | } |
| 627 | |
| 628 | $STATE->{tsbs} = \%tsbs; |
| 629 | $STATE->{tsblinks} = \%tsblinks; |
| 630 | |
| 631 | if(!$num_secs) { |
| 632 | fatal "Diag contains no SECTION directives!\n", M_NOSEC; |
| 633 | } |
| 634 | |
| 635 | |
| 636 | chat "Processing directives in $directives\n"; |
| 637 | |
| 638 | # Pass 2, create attr_blocks |
| 639 | |
| 640 | $srcfile = $m4file; |
| 641 | $srcline = 0; |
| 642 | $ifh = IO::File->new("<$directives") or die "Can't open $directives: $!\n"; |
| 643 | |
| 644 | my %opened_sec; |
| 645 | my @linebuf; |
| 646 | my @sections; |
| 647 | |
| 648 | my $current_section; |
| 649 | my $current_appname = $first_appname; |
| 650 | |
| 651 | while(<$ifh>) { |
| 652 | if(/^\#\s*(?:line\s*)?(\d+)\s+\"(.*)\"/) { |
| 653 | $srcline = $1 - 1; |
| 654 | $srcfile = $2; |
| 655 | $smartlines = 1; |
| 656 | } else { |
| 657 | $srcline++; |
| 658 | } |
| 659 | |
| 660 | while($_ =~ /\\$/) { |
| 661 | $_ =~ s/\\\n$/ /; |
| 662 | $_ .= <$ifh>; |
| 663 | $srcline++; |
| 664 | } |
| 665 | |
| 666 | if(/^\s*APPLICATION\s+(\S+)/) { |
| 667 | my $appname = lc $1; |
| 668 | $current_appname = $appname; |
| 669 | } |
| 670 | |
| 671 | |
| 672 | if(/^\s*SECTION\s+(\S+)/) { |
| 673 | my $secname = lc $1; |
| 674 | |
| 675 | my $section = $sections{$current_appname}{$secname}; |
| 676 | $current_section = $section; |
| 677 | |
| 678 | my $rec = shift @{$section_count{$current_appname}{$secname}}; |
| 679 | |
| 680 | $srcfile = $rec->{srcfile}; |
| 681 | $srcline = $rec->{srcline}; |
| 682 | |
| 683 | if(not $opened_sec{$current_appname}{$secname}) { |
| 684 | push @sections, $section; |
| 685 | } |
| 686 | $opened_sec{$current_appname}{$secname} = 1; |
| 687 | my $nextline = $srcline + 1; |
| 688 | next; |
| 689 | } # end if /^SECTION/ |
| 690 | |
| 691 | if(/^\s*attr_(\S+)\s*\{/) { |
| 692 | |
| 693 | my $attrs = $mmu->parse_section_attrs($_, $ifh, |
| 694 | $srcline, $srcfile); |
| 695 | $_ = "\n"; |
| 696 | |
| 697 | |
| 698 | ($srcfile, $srcline) = $attrs->get_end_file_line(); |
| 699 | |
| 700 | my $secname = $attrs->get_section_name(); |
| 701 | |
| 702 | $attrs->attr_fatal("attr block does not define a section!\n", M_NOSEC) |
| 703 | unless defined $secname && $secname =~ /\S/; |
| 704 | |
| 705 | fatal "Attribute spec for section \"$secname\" but no such section.\n". |
| 706 | "File=$srcfile, Line=$srcline\n", M_MISSINGPARAM |
| 707 | unless exists $sections{$current_appname}{$secname}; |
| 708 | |
| 709 | my $section = $sections{$current_appname}{$secname}; |
| 710 | $attrs->secobj($section); |
| 711 | $section->add_attrs($attrs); |
| 712 | |
| 713 | } |
| 714 | |
| 715 | |
| 716 | if(/^\s*MIDAS_CC\s*(.*?)\s*$/) { |
| 717 | fatal "MIDAS_CC directive outside any section at line=$srcline, ". |
| 718 | "file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $current_section; |
| 719 | $current_section->parse_midas_cc_line($1, $srcline, $srcfile); |
| 720 | $_= "\n"; |
| 721 | } |
| 722 | if(/^\s*MIDAS_OBJ\s*(.*?)\s*$/) { |
| 723 | fatal "MIDAS_OBJ directive outside any section at line=$srcline, ". |
| 724 | "file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $current_section; |
| 725 | $current_section->parse_midas_obj_line($1, $srcline, $srcfile); |
| 726 | $_= "\n"; |
| 727 | } |
| 728 | if(/^\s*MIDAS_LIB\s*(.*?)\s*$/) { |
| 729 | fatal "MIDAS_LIB directive outside any section at line=$srcline, ". |
| 730 | "file=$srcfile\n", M_DIRECTIVESYNTAX unless defined $current_section; |
| 731 | $current_section->parse_midas_lib_line($1, $srcline, $srcfile); |
| 732 | $_= "\n"; |
| 733 | } |
| 734 | |
| 735 | } |
| 736 | |
| 737 | chat "Performing sanity check on arguments.\n"; |
| 738 | |
| 739 | my @errors; |
| 740 | foreach my $section (@sections) { |
| 741 | # Do error checking |
| 742 | push @errors, $section->sanity_check(); |
| 743 | } |
| 744 | |
| 745 | if(@errors) { |
| 746 | my $errorcode = $errors[0]{code}; |
| 747 | my $message = join "\n", map { $_->{message} } @errors; |
| 748 | fatal $message, $errorcode; |
| 749 | } |
| 750 | |
| 751 | foreach my $appname (keys %{$STATE->{apps}}) { |
| 752 | delete $STATE->{apps}{$appname} if $STATE->{apps}{$appname}->is_blank(); |
| 753 | } |
| 754 | |
| 755 | foreach my $s (@sections) { |
| 756 | $s->print_debug(); |
| 757 | } |
| 758 | |
| 759 | |
| 760 | |
| 761 | } |
| 762 | |
| 763 | ############################################################################## |
| 764 | |
| 765 | sub write_linker_scripts { |
| 766 | my $pushd = Midas::Paths->pushd($STATE->get_build_dir); |
| 767 | |
| 768 | # mmu must exist or we never would have been able to create sections |
| 769 | foreach my $app (keys %{$STATE->{apps}}) { |
| 770 | |
| 771 | next if $STATE->{apps}{$app}->is_linked(); |
| 772 | my @sec_list = $STATE->{apps}{$app}->get_sec_list(); |
| 773 | |
| 774 | my $script_name = $STATE->{apps}{$app}->ldscr_name(); |
| 775 | my $script = path_to_build_file($script_name, $STATE); |
| 776 | |
| 777 | chat "Writing linker script $script.\n"; |
| 778 | |
| 779 | my $ofh = IO::File->new(">$script") or die "Can't open $script: $!\n"; |
| 780 | |
| 781 | $ofh->print("SECTIONS {\n"); |
| 782 | |
| 783 | foreach my $sec (@sec_list) { |
| 784 | |
| 785 | my $link_attrs = [$sec->get_link_attrs()]->[0]; |
| 786 | |
| 787 | my @olist = map { basename $_ } $sec->get_object_list(); |
| 788 | my @alist = map { basename $_ } $sec->get_library_list(); #libs after .o |
| 789 | |
| 790 | push @olist, @alist; |
| 791 | |
| 792 | foreach my $seg (Midas::Segment->all_names()) { |
| 793 | if ($link_attrs->has_segment($seg)) { |
| 794 | my $linkname = $sec->get_segment_link_name($seg); |
| 795 | my $elfname = Midas::Segment->name2elf_name($seg); |
| 796 | |
| 797 | my $filespec = join " ", map { "$_ ($elfname)" } @olist; |
| 798 | |
| 799 | my $addrspec = $link_attrs->get_segment_va($seg) . " :"; |
| 800 | $ofh->print("$linkname $addrspec { $filespec }\n"); |
| 801 | } |
| 802 | } |
| 803 | |
| 804 | } |
| 805 | $ofh->print("}\n"); |
| 806 | |
| 807 | undef $ofh; |
| 808 | } |
| 809 | } |
| 810 | |
| 811 | ############################################################################## |
| 812 | |
| 813 | sub assemble_sections { |
| 814 | banner "ASSEMBLY PHASE"; |
| 815 | |
| 816 | foreach my $app_name (keys %{$STATE->{apps}}) { |
| 817 | my $app = $STATE->{apps}{$app_name}; |
| 818 | |
| 819 | my @sections = $app->get_sec_list(); |
| 820 | build_sections(\@sections) if @sections; |
| 821 | } |
| 822 | |
| 823 | } |
| 824 | |
| 825 | ############################################################################## |
| 826 | |
| 827 | sub build_sections { |
| 828 | my $seclist = shift; |
| 829 | |
| 830 | my $pushd = Midas::Paths->pushd($STATE->get_build_dir); |
| 831 | |
| 832 | my $num_threads = $CONFIG{build_threads}; |
| 833 | $num_threads = 1 if $num_threads < 1; |
| 834 | my $num_sections = @$seclist; |
| 835 | return unless $num_sections; |
| 836 | $num_threads = $num_sections if $num_sections < $num_threads; |
| 837 | |
| 838 | my $sec_pl = ($num_sections > 1) ? 's' : ''; |
| 839 | my $thd_pl = ($num_threads > 1) ? 's' : ''; |
| 840 | chat "Building $num_sections section$sec_pl using $num_threads ". |
| 841 | "build thread$thd_pl.\n"; |
| 842 | |
| 843 | if($num_threads == 1) { |
| 844 | foreach my $section (@$seclist) { |
| 845 | $section->build(); |
| 846 | } |
| 847 | } else { |
| 848 | my @thread_sections; |
| 849 | my $num_section = -1; |
| 850 | foreach my $section (@$seclist) { |
| 851 | $num_section++; |
| 852 | my $thread = $num_section % $num_threads; |
| 853 | $thread_sections[$thread] = [] unless defined $thread_sections[$thread]; |
| 854 | push @{$thread_sections[$thread]}, $section; |
| 855 | } |
| 856 | |
| 857 | my $parent_thread = 0; |
| 858 | my $my_thread = 0; |
| 859 | |
| 860 | my @child_pids; |
| 861 | my $threads_to_spawn = $num_threads - 1; |
| 862 | my $next_thread = $my_thread + 1; |
| 863 | |
| 864 | while($threads_to_spawn) { |
| 865 | my $pid; |
| 866 | if($pid = fork()) { |
| 867 | $next_thread++; |
| 868 | $threads_to_spawn--; |
| 869 | push @child_pids, $pid; |
| 870 | # parent |
| 871 | } elsif(defined $pid) { |
| 872 | $my_thread = $next_thread; |
| 873 | last; |
| 874 | } else { |
| 875 | fatal "Cannot fork thread $next_thread: $!\n", M_CODE; |
| 876 | } |
| 877 | } |
| 878 | |
| 879 | chat "Build thread $my_thread is alive!\n", 3; |
| 880 | |
| 881 | foreach my $section (@{$thread_sections[$my_thread]}) { |
| 882 | chat "Building section $section->{name} on thread $my_thread\n", 3; |
| 883 | $section->build(); |
| 884 | } |
| 885 | |
| 886 | if($my_thread != 0) { |
| 887 | exit(0); |
| 888 | } |
| 889 | if(@child_pids) { |
| 890 | |
| 891 | foreach my $pid (@child_pids) { |
| 892 | my $waitval; |
| 893 | my $waitstatus; |
| 894 | while() { |
| 895 | $waitval = waitpid($pid, 0); |
| 896 | if($waitval == -1) { |
| 897 | $waitstatus = 0; |
| 898 | last; |
| 899 | } elsif($waitval == 0) { |
| 900 | $waitstatus = 0; |
| 901 | last; |
| 902 | } else { |
| 903 | $waitval = $pid; |
| 904 | $waitstatus = $?; |
| 905 | last; |
| 906 | } |
| 907 | }; |
| 908 | my $status = $waitstatus >> 8; |
| 909 | # Child thread has died with nonzero status |
| 910 | if($status != 0) { |
| 911 | my $waitstatus_hex = sprintf "%x", $waitstatus; |
| 912 | fatal "Build thread with pid=$pid died with status $status ". |
| 913 | "(waitstauts=0x$waitstatus_hex).\n", $status; |
| 914 | } |
| 915 | } |
| 916 | } |
| 917 | |
| 918 | } |
| 919 | } |
| 920 | |
| 921 | ############################################################################## |
| 922 | |
| 923 | sub link_diag { |
| 924 | my $pushd = Midas::Paths->pushd($STATE->get_build_dir); |
| 925 | |
| 926 | banner "LINK PHASE"; |
| 927 | |
| 928 | write_linker_scripts(); |
| 929 | |
| 930 | foreach my $app (keys %{$STATE->{apps}}) { |
| 931 | my $appobj = $STATE->{apps}{$app}; |
| 932 | |
| 933 | next if $appobj->is_linked(); |
| 934 | |
| 935 | my $ldscript_name = $appobj->ldscr_name(); |
| 936 | my $exe_name = $appobj->exe_name(); |
| 937 | |
| 938 | my $ldscript = path_to_build_file($ldscript_name, $STATE); |
| 939 | my $exe = path_to_build_file($exe_name, $STATE); |
| 940 | |
| 941 | my $args = join ' ', @{$CONFIG{ld_opt}}; |
| 942 | run_command("$CONFIG{ld_cmd} $args -T $ldscript -o $exe", |
| 943 | -errcode => M_LINKFAIL |
| 944 | ); |
| 945 | |
| 946 | if(-e $exe) { |
| 947 | chat "$exe successfully created.\n"; |
| 948 | } else { |
| 949 | fatal "$exe could not be generated.\n", M_LINKFAIL; |
| 950 | } |
| 951 | } |
| 952 | |
| 953 | } |
| 954 | |
| 955 | ############################################################################## |
| 956 | |
| 957 | 1; |