ghc/driver/split/ghc-split.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-obj-splitting]{Splitting into many \tr{.o} files (for libraries)}
   4 %*                                                                      *
   5 %************************************************************************
   6
   7 \begin{code}
   8 $TargetPlatform = $TARGETPLATFORM;
   9
  10 ($Pgm = $0) =~ s|.*/||;
  11 $ifile      = $ARGV[0];
  12 $Tmp_prefix = $ARGV[1];
  13 $Output     = $ARGV[2];
  14
  15 &split_asm_file($ifile);
  16
  17 open(OUTPUT, "> $Output") ||  &tidy_up_and_die(1,"$Pgm: failed to open `$Output' (to write)\n");
  18 print OUTPUT "$NoOfSplitFiles\n";
  19 close(OUTPUT);
  20
  21 exit(0);
  22 \end{code}
  23
  24
  25 \begin{code}
  26 sub split_asm_file {
  27     local($asm_file) = @_;
  28
  29     open(TMPI, "< $asm_file") || &tidy_up_and_die(1,"$Pgm: failed to open `$asm_file' (to read)\n");
  30
  31     &collectExports_hppa() if $TargetPlatform =~ /^hppa/;
  32     &collectExports_mips() if $TargetPlatform =~ /^mips/;
  33
  34     $octr = 0;  # output file counter
  35     $* = 1;     # multi-line matches are OK
  36
  37     %LocalConstant = (); # we have to subvert C compiler's commoning-up of constants...
  38
  39     $s_stuff = &ReadTMPIUpToAMarker( '', $octr );
  40     # that first stuff is a prologue for all .s outputs
  41     $prologue_stuff = &process_asm_block ( $s_stuff );
  42     # $_ already has some of the next stuff in it...
  43
  44 #   &tidy_up_and_die(1,"$Pgm: no split markers in .s file!\n")
  45 #       if $prologue_stuff eq $s_stuff;
  46
  47     # lie about where this stuff came from
  48     $prologue_stuff =~ s|"${Tmp_prefix}\.c"|"$ifile_root\.hc"|g;
  49
  50     while ( $_ ne '' ) { # not EOF
  51         $octr++;
  52
  53         # grab and de-mangle a section of the .s file...
  54         $s_stuff = &ReadTMPIUpToAMarker ( $_, $octr );
  55         $this_piece = &process_asm_block ( $s_stuff );
  56
  57         # output to a file of its own
  58         # open a new output file...
  59         $ofname = "${Tmp_prefix}__${octr}.s";
  60         open(OUTF, "> $ofname") || die "$Pgm: can't open output file: $ofname\n";
  61
  62         print OUTF $prologue_stuff;
  63         print OUTF $this_piece;
  64
  65         close(OUTF)
  66           || &tidy_up_and_die(1,"$Pgm:Failed writing ${Tmp_prefix}__${octr}.s\n");
  67     }
  68
  69     $NoOfSplitFiles = $octr;
  70
  71     close(TMPI) || &tidy_up_and_die(1,"Failed reading $asm_file\n");
  72 }
  73
  74 sub collectExports_hppa { # Note: HP-PA only
  75
  76     %LocalExport = (); # NB: global table
  77
  78     while(<TMPI>) {
  79         if (/^\s+\.EXPORT\s+([^,]+),.*\n/) {
  80             local($label) = $1;
  81             local($body)  = "\t.IMPORT $label";
  82             if (/,DATA/) {
  83                 $body .= ",DATA\n";
  84             } else {
  85                 $body .= ",CODE\n";
  86             }
  87             $label =~ s/\$/\\\$/g;
  88             $LocalExport{$label} = $body;
  89         }
  90     }
  91
  92     seek(TMPI, 0, 0);
  93 }
  94
  95 sub collectExports_mips { # Note: MIPS only
  96     # (not really sure this is necessary [WDP 95/05])
  97
  98     $UNDEFINED_FUNS = ''; # NB: global table
  99
 100     while(<TMPI>) {
 101         $UNDEFINED_FUNS .= $_ if /^\t\.globl\s+\S+ \.\S+\n/;
 102         # just save 'em all
 103     }
 104
 105     seek(TMPI, 0, 0);
 106 }
 107
 108 sub ReadTMPIUpToAMarker {
 109     local($str, $count) = @_; # already read bits
 110
 111
 112     for ( $_ = <TMPI>; $_ ne '' && ! /_?__stg_split_marker/; $_ = <TMPI> ) {
 113         $str .= $_;
 114     }
 115     # if not EOF, then creep forward until next "real" line
 116     # (throwing everything away).
 117     # that first "real" line will stay in $_.
 118
 119     # This loop is intended to pick up the body of the split_marker function
 120     # Note that the assembler mangler will already have eliminated this code
 121     # if it's been invoked (which it probably has).
 122
 123     while ($_ ne '' && (/_?__stg_split_marker/
 124                      || /^L[^C].*:$/
 125                      || /^\.stab/
 126                      || /\t\.proc/
 127                      || /\t\.stabd/
 128                      || /\t\.even/
 129                      || /\tunlk a6/
 130                      || /^\t!#PROLOGUE/
 131                      || /\t\.prologue/
 132                      || /\t\.frame/
 133                      # || /\t\.end/ NOT!  Let the split_marker regexp catch it
 134                      # || /\t\.ent/ NOT!  Let the split_marker regexp catch it
 135                      || /^\s+(save|retl?|restore|nop)/)) {
 136         $_ = <TMPI>;
 137     }
 138
 139     print STDERR "### BLOCK:$count:\n$str" if $Dump_asm_splitting_info;
 140
 141     # return str
 142     $str =~ tr/\r//d if $TargetPlatform =~ /-mingw32$/; # in case Perl doesn't convert line endings
 143     $str;
 144 }
 145 \end{code}
 146
 147 We must (a)~strip the marker off the block, (b)~record any literal C
 148 constants that are defined here, and (c)~inject copies of any C constants
 149 that are used-but-not-defined here.
 150
 151 \begin{code}
 152 sub process_asm_block {
 153     local($str) = @_;
 154
 155     return(&process_asm_block_m68k($str))  if $TargetPlatform =~ /^m68k-/;
 156     return(&process_asm_block_sparc($str)) if $TargetPlatform =~ /^sparc-/;
 157     return(&process_asm_block_iX86($str))  if $TargetPlatform =~ /^i[34]86-/;
 158     return(&process_asm_block_alpha($str)) if $TargetPlatform =~ /^alpha-/;
 159     return(&process_asm_block_hppa($str))  if $TargetPlatform =~ /^hppa/;
 160     return(&process_asm_block_mips($str))   if $TargetPlatform =~ /^mips-/;
 161     return(&process_asm_block_powerpc($str))   if $TargetPlatform =~ /^powerpc-|^rs6000-/;
 162
 163     # otherwise...
 164     &tidy_up_and_die(1,"$Pgm: no process_asm_block for $TargetPlatform\n");
 165 }
 166
 167 sub process_asm_block_sparc {
 168     local($str) = @_;
 169
 170     # strip the marker
 171     if ( $OptimiseC ) {
 172         $str =~ s/_?__stg_split_marker.*:\n//;
 173     } else {
 174         $str =~ s/(\.text\n\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/$1/;
 175         $str =~ s/(\t\.align .\n)\t\.global\s+.*_?__stg_split_marker.*\n\t\.proc.*\n/$1/;
 176     }
 177
 178     # make sure the *.hc filename gets saved; not just ghc*.c (temp name)
 179     $str =~ s/^\.stabs "(ghc\d+\.c)"/.stabs "$ifile_root.hc"/g; # HACK HACK
 180
 181     # remove/record any literal constants defined here
 182     while ( $str =~ /(\t\.align .\n\.?(L?LC\d+):\n(\t\.asci[iz].*\n)+)/ ) {
 183         local($label) = $2;
 184         local($body)  = $1;
 185
 186         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 187             if $LocalConstant{$label};
 188
 189         $LocalConstant{$label} = $body;
 190
 191         $str =~ s/\t\.align .\n\.?LL?C\d+:\n(\t\.asci[iz].*\n)+//;
 192     }
 193
 194     # inject definitions for any local constants now used herein
 195     foreach $k (keys %LocalConstant) {
 196         if ( $str =~ /\b$k\b/ ) {
 197             $str = $LocalConstant{$k} . $str;
 198         }
 199     }
 200
 201    print STDERR "### STRIPPED BLOCK (sparc):\n$str" if $Dump_asm_splitting_info;
 202
 203    $str;
 204 }
 205
 206 sub process_asm_block_m68k {
 207     local($str) = @_;
 208
 209     # strip the marker
 210
 211     $str =~ s/(\.text\n\t\.even\n)\t\.globl\s+.*_?__stg_split_marker.*\n/$1/;
 212     $str =~ s/(\t\.even\n)\t\.globl\s+.*_?__stg_split_marker.*\n/$1/;
 213
 214     # it seems prudent to stick on one of these:
 215     $str = "\.text\n\t.even\n" . $str;
 216
 217     # remove/record any literal constants defined here
 218     while ( $str =~ /((LC\d+):\n\t\.ascii.*\n)/ ) {
 219         local($label) = $2;
 220         local($body)  = $1;
 221
 222         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 223             if $LocalConstant{$label};
 224
 225         $LocalConstant{$label} = $body;
 226
 227         $str =~ s/LC\d+:\n\t\.ascii.*\n//;
 228     }
 229
 230     # inject definitions for any local constants now used herein
 231     foreach $k (keys %LocalConstant) {
 232         if ( $str =~ /\b$k\b/ ) {
 233             $str = $LocalConstant{$k} . $str;
 234         }
 235     }
 236
 237    print STDERR "### STRIPPED BLOCK (m68k):\n$str" if $Dump_asm_splitting_info;
 238
 239    $str;
 240 }
 241
 242 sub process_asm_block_alpha {
 243     local($str) = @_;
 244
 245     # strip the marker
 246     if ( $OptimiseC ) {
 247         $str =~ s/_?__stg_split_marker.*:\n//;
 248     } else {
 249         $str =~ s/(\t\.align .\n)\t\.globl\s+.*_?__stg_split_marker.*\n\t\.ent.*\n/$1/;
 250     }
 251
 252     # remove/record any literal constants defined here
 253     while ( $str =~ /(\.rdata\n\t\.align \d\n)?(\$(C\d+):\n\t\..*\n)/ ) {
 254         local($label) = $3;
 255         local($body)  = $2;
 256
 257         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 258             if $LocalConstant{$label};
 259
 260         $LocalConstant{$label} = ".rdata\n\t.align 3\n" . $body . "\t.text\n";
 261
 262         $str =~ s/(\.rdata\n\t\.align \d\n)?\$C\d+:\n\t\..*\n//;
 263     }
 264
 265     # inject definitions for any local constants now used herein
 266     foreach $k (keys %LocalConstant) {
 267         if ( $str =~ /\$\b$k\b/ ) {
 268             $str = $LocalConstant{$k} . $str;
 269         }
 270     }
 271
 272     # Slide the dummy direct return code into the vtbl .ent/.end block,
 273     # to keep the label fixed if it's the last thing in a module, and
 274     # to avoid having any anonymous text that the linker will complain about
 275     $str =~ s/(\t\.end [A-Za-z0-9_]+)\n\t# nop/\tnop\n$1/g;
 276
 277     print STDERR "### STRIPPED BLOCK (alpha):\n$str" if $Dump_asm_splitting_info;
 278
 279     $str;
 280 }
 281
 282 sub process_asm_block_iX86 {
 283     local($str) = @_;
 284
 285     # strip the marker
 286
 287     $str =~ s/(\.text\n\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/$1/;
 288     $str =~ s/(\t\.align .(,0x90)?\n)\.globl\s+.*_?__stg_split_marker.*\n/$1/;
 289
 290     # it seems prudent to stick on one of these:
 291     $str = "\.text\n\t.align 4\n" . $str;
 292
 293     # remove/record any literal constants defined here
 294     # [perl made uglier to work around the perl 5.7/5.8 bug documented at
 295     # http://bugs6.perl.org/rt2/Ticket/Display.html?id=1760 and illustrated
 296     # by the seg fault of perl -e '("x\n" x 5000) =~ /(.*\n)+/'
 297     # -- ccshan 2002-09-05]
 298     while ( ($str =~ /(\.?(LC\d+):\n(\t\.(ascii|string).*\n|\s*\.byte.*\n){1,100})/ )) {
 299         local($label) = $2;
 300         local($body)  = $1;
 301         local($prefix, $suffix, $*) = ($`, $', 0);
 302
 303         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 304             if $LocalConstant{$label};
 305
 306         while ( $suffix =~ /^((\t\.(ascii|string).*\n|\s*\.byte.*\n){1,100})/ ) {
 307             $body .= $1;
 308             $suffix = $';
 309         }
 310         $LocalConstant{$label} = $body;
 311         $str = $prefix . $suffix;
 312     }
 313
 314     # inject definitions for any local constants now used herein
 315     foreach $k (keys %LocalConstant) {
 316         if ( $str =~ /\b$k\b/ ) {
 317             $str = $LocalConstant{$k} . $str;
 318         }
 319     }
 320
 321    print STDERR "### STRIPPED BLOCK (iX86):\n$str" if $Dump_asm_splitting_info;
 322
 323    $str;
 324 }
 325 \end{code}
 326
 327 \begin{code}
 328 sub process_asm_block_hppa {
 329     local($str) = @_;
 330
 331     # strip the marker
 332     $str =~ s/___stg_split_marker.*\n//;
 333
 334     # remove/record any imports defined here
 335     while ( $str =~ /^(\s+\.IMPORT\s.*\n)/ ) {
 336         $Imports .= $1;
 337
 338         $str =~ s/^\s+\.IMPORT.*\n//;
 339     }
 340
 341     # remove/record any literal constants defined here
 342     while ( $str =~ /^(\s+\.align.*\n(L\$C\d+)\n(\s.*\n)+); end literal\n/ ) {
 343         local($label) = $2;
 344         local($body)  = $1;
 345         local($prefix) = $`;
 346         local($suffix) = $';
 347         $label =~ s/\$/\\\$/g;
 348
 349         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 350             if $LocalConstant{$label};
 351
 352         $LocalConstant{$label} = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n\n" . $body;
 353
 354         $str = $prefix . $suffix;
 355     }
 356
 357     # inject definitions for any local constants now used herein
 358     foreach $k (keys %LocalConstant) {
 359         if ( $str =~ /\b$k\b/ ) {
 360             $str = $LocalConstant{$k} . $str;
 361         }
 362     }
 363
 364     # inject required imports for local exports in other chunks
 365     foreach $k (keys %LocalExport) {
 366         if ( $str =~ /\b$k\b/ && ! /EXPORT\s+$k\b/ ) {
 367             $str = $LocalExport{$k} . $str;
 368         }
 369     }
 370
 371     # inject collected imports
 372
 373     $str = $Imports . $str;
 374
 375     print STDERR "### STRIPPED BLOCK (hppa):\n$str" if $Dump_asm_splitting_info;
 376
 377     $str;
 378 }
 379 \end{code}
 380
 381 \begin{code}
 382 sub process_asm_block_mips {
 383     local($str) = @_;
 384
 385     # strip the marker
 386     if ( $OptimiseC ) {
 387         $str =~ s/_?__stg_split_marker.*:\n//;
 388     } else {
 389         $str =~ s/(\t\.align .\n)\t\.globl\s+.*_?__stg_split_marker.*\n\t\.ent.*\n/$1/;
 390     }
 391
 392     # remove/record any literal constants defined here
 393     while ( $str =~ /(\t\.rdata\n\t\.align \d\n)?(\$(LC\d+):\n(\t\.byte\t.*\n)+)/ ) {
 394         local($label) = $3;
 395         local($body)  = $2;
 396
 397         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 398             if $LocalConstant{$label};
 399
 400         $LocalConstant{$label} = "\t.rdata\n\t.align 2\n" . $body . "\t.text\n";
 401
 402         $str =~ s/(\t\.rdata\n\t\.align \d\n)?\$LC\d+:\n(\t\.byte\t.*\n)+//;
 403     }
 404
 405     # inject definitions for any local constants now used herein
 406     foreach $k (keys %LocalConstant) {
 407         if ( $str =~ /\$\b$k\b/ ) {
 408             $str = $LocalConstant{$k} . $str;
 409         }
 410     }
 411
 412     # Slide the dummy direct return code into the vtbl .ent/.end block,
 413     # to keep the label fixed if it's the last thing in a module, and
 414     # to avoid having any anonymous text that the linker will complain about
 415     $str =~ s/(\t\.end [A-Za-z0-9_]+)\n\t# nop/\tnop\n$1/g;
 416
 417     $str .= $UNDEFINED_FUNS; # pin on gratuitiously-large amount of info
 418
 419     print STDERR "### STRIPPED BLOCK (mips):\n$str" if $Dump_asm_splitting_info;
 420
 421     $str;
 422 }
 423 \end{code}
 424
 425 \begin{code}
 426 sub process_asm_block_powerpc {
 427     local($str) = @_;
 428
 429     # strip the marker
 430     $str =~ s/___stg_split_marker.*\n//;
 431     $str =~ s/___stg_split_marker.*\n//; # yes, twice.
 432
 433     # remove/record any literal constants defined here
 434     while ( $str =~ /^(.csect .data[RW]\n\s+\.align.*\n(LC\.\.\d+):\n(\s\.byte .*\n)+)/ ) {
 435         local($label) = $2;
 436         local($body)  = $1;
 437
 438         &tidy_up_and_die(1,"Local constant label $label already defined!\n")
 439             if $LocalConstant{$label};
 440
 441         $LocalConstant{$label} = $body;
 442
 443         $str =~ s/^.csect .data[RW]\n\s+\.align.*\nLC\.\.\d+:\n(\s\.byte .*\n)+//;
 444     }
 445
 446     # inject definitions for any local constants now used herein
 447     foreach $k (keys %LocalConstant) {
 448         if ( $str =~ /\b$k(\b|\[)/ ) {
 449             $str = $LocalConstant{$k} . $str;
 450         }
 451     }
 452
 453     print STDERR "### STRIPPED BLOCK (powerpc/rs6000):\n$str" if $Dump_asm_splitting_info;
 454
 455     $str = ".toc\n" . $str;
 456
 457     $str;
 458 }
 459 \end{code}
 460
 461 \begin{code}
 462 sub tidy_up_and_die {
 463     local($return_val, $msg) = @_;
 464     print STDERR $msg;
 465     exit (($return_val == 0) ? 0 : 1);
 466 }
 467 \end{code}