Commit | Line | Data |
---|---|---|
86530b38 AT |
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; |