ghc/driver/ghc-asm-mips.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-asm-fiddling]{Fiddling with assembler files (SGI MIPS box)}
   4 %*                                                                      *
   5 %************************************************************************
   6
   7 \begin{code}
   8 sub mangle_asm {
   9     local($in_asmf, $out_asmf) = @_;
  10
  11     # multi-line regexp matching:
  12     local($*) = 1;
  13     local($i, $c);
  14     &init_FUNNY_THINGS();
  15
  16     open(INASM, "< $in_asmf")
  17         || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
  18     open(OUTASM,"> $out_asmf")
  19         || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
  20
  21     # read whole file, divide into "chunks":
  22     #   record some info about what we've found...
  23
  24     @chk = ();          # contents of the chunk
  25     $numchks = 0;       # number of them
  26     @chkcat = ();       # what category of thing in each chunk
  27     @chksymb = ();      # what symbol(base) is defined in this chunk
  28     %slowchk = ();      # ditto, its regular "slow" entry code
  29     %fastchk = ();      # ditto, fast entry code
  30     %closurechk = ();   # ditto, the (static) closure
  31     %infochk = ();      # given a symbol base, say what chunk its info tbl is in
  32     %vectorchk = ();    # ditto, return vector table
  33     %directchk = ();    # ditto, direct return code
  34     $EXTERN_DECLS = ''; # .globl <foo> .text
  35
  36     $i = 0;
  37     $chkcat[0] = 'misc';
  38
  39     while (<INASM>) {
  40
  41         next if /^$/; # blank line
  42         next if /^\s*#(NO_)?APP/;
  43         next if /^\t\.file\t/;
  44         next if /^ # /;
  45
  46         if ( /^\t\.(globl \S+ \.text|comm\t)/ ) {
  47             $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/;
  48
  49         } elsif ( /^\s+/ ) { # most common case first -- a simple line!
  50             # duplicated from the bottom
  51             $chk[$i] .= $_;
  52
  53         # NB: all the rest start with a non-space
  54
  55         } elsif ( /^\d+:/ ) { # a funny-looking very-local label
  56             $chk[$i] .= $_;
  57
  58         } elsif ( /^(ret_|djn_)/ ) {
  59             $chk[++$i] .= $_;
  60             $chkcat[$i] = 'misc';
  61             $chksymb[$i] = '';
  62
  63         } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
  64             $chk[++$i] .= $_;
  65             $chkcat[$i] = 'vector';
  66             $chksymb[$i] = $1;
  67
  68             $vectorchk{$1} = $i;
  69
  70         } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
  71             $chk[++$i] .= $_;
  72             $chkcat[$i] = 'direct';
  73             $chksymb[$i] = $1;
  74
  75             $directchk{$1} = $i;
  76
  77         } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
  78             $chk[++$i] .= $_;
  79             $chkcat[$i] = 'misc';
  80             $chksymb[$i] = '';
  81
  82         } elsif ( /^\$LC(\d+):$/ ) {
  83             $chk[++$i] .= $_;
  84             $chkcat[$i] = 'string';
  85             $chksymb[$i] = $1;
  86
  87         } elsif ( /^__stg_split_marker(\d+):$/ ) {
  88             $chk[++$i] .= $_;
  89             $chkcat[$i] = 'splitmarker';
  90             $chksymb[$i] = $1;
  91
  92         } elsif ( /^([A-Za-z0-9_]+)_info:$/ ) {
  93             $symb = $1;
  94             $chk[++$i] .= $_;
  95             $chkcat[$i] = 'infotbl';
  96             $chksymb[$i] = $symb;
  97
  98             $infochk{$symb} = $i;
  99
 100         } elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) {
 101             $chk[++$i] .= $_;
 102             $chkcat[$i] = 'slow';
 103             $chksymb[$i] = $1;
 104
 105             $slowchk{$1} = $i;
 106
 107         } elsif ( /^([A-Za-z0-9_]+)_fast\d+:$/ ) {
 108             $chk[++$i] .= $_;
 109             $chkcat[$i] = 'fast';
 110             $chksymb[$i] = $1;
 111
 112             $fastchk{$1} = $i;
 113
 114         } elsif ( /^([A-Za-z0-9_]+)_closure:$/ ) {
 115             $chk[++$i] .= $_;
 116             $chkcat[$i] = 'closure';
 117             $chksymb[$i] = $1;
 118
 119             $closurechk{$1} = $i;
 120
 121         } elsif ( /^ghc.*c_ID:/ ) {
 122             $chk[++$i] .= $_;
 123             $chkcat[$i] = 'consist';
 124
 125         } elsif ( /^(__gnu_compiled_c|gcc2_compiled\.):/ ) {
 126             ; # toss it
 127
 128         } elsif ( /^ErrorIO_call_count:/         # HACK!!!!
 129                || /^[A-Za-z0-9_]+\.\d+:$/
 130                || /^.*_CAT:/                    # PROF: _entryname_CAT
 131                || /^CC_.*_struct:/              # PROF: _CC_ccident_struct
 132                || /^.*_done:/                   # PROF: _module_done
 133                || /^_module_registered:/        # PROF: _module_registered
 134                ) {
 135             $chk[++$i] .= $_;
 136             $chkcat[$i] = 'data';
 137             $chksymb[$i] = '';
 138
 139         } elsif ( /^[A-Za-z0-9_]/ ) {
 140             local($thing);
 141             chop($thing = $_);
 142             print STDERR "Funny global thing? ($.): $_"
 143                 unless $KNOWN_FUNNY_THING{$thing}
 144                     || /^_(PRIn|PRStart).*:/    # pointer reversal GC routines
 145                     || /^CC_.*:/                # PROF: _CC_ccident
 146                     || /^_reg.*:/;              # PROF: _reg<module>
 147             $chk[++$i] .= $_;
 148             $chkcat[$i] = 'misc';
 149             $chksymb[$i] = '';
 150
 151         } else { # simple line (duplicated at the top)
 152             $chk[$i] .= $_;
 153         }
 154     }
 155     $numchks = $#chk + 1;
 156
 157 #    print STDERR "\nCLOSURES:\n";
 158 #    foreach $s (sort (keys %closurechk)) {
 159 #       print STDERR "$s:\t\t",$closurechk{$s},"\n";
 160 #    }
 161 #    print STDERR "\nINFOS:\n";
 162 #    foreach $s (sort (keys %infochk)) {
 163 #       print STDERR "$s:\t\t",$infochk{$s},"\n";
 164 #    }
 165 #    print STDERR "SLOWS:\n";
 166 #    foreach $s (sort (keys %slowchk)) {
 167 #       print STDERR "$s:\t\t",$slowchk{$s},"\n";
 168 #    }
 169 #    print STDERR "\nFASTS:\n";
 170 #    foreach $s (sort (keys %fastchk)) {
 171 #       print STDERR "$s:\t\t",$fastchk{$s},"\n";
 172 #    }
 173
 174     # the division into chunks is imperfect;
 175     # we throw some things over the fence into the next
 176     # chunk.
 177     #
 178     # also, there are things we would like to know
 179     # about the whole module before we start spitting
 180     # output.
 181
 182     # NB: we start meddling at chunk 1, not chunk 0
 183
 184     for ($i = 1; $i < $numchks; $i++) {
 185         $c = $chk[$i]; # convenience copy
 186
 187 #       print STDERR "\nCHK $i (BEFORE):\n", $c;
 188
 189         # pin a funny end-thing on (for easier matching):
 190         $c .= 'FUNNY#END#THING';
 191
 192         # pick some end-things and move them to the next chunk
 193
 194         while ( $c =~ /^(\s*\.align\s+\d+\n)FUNNY#END#THING/
 195              || $c =~ /^(\s*\.(globl|ent)\s+\S+\n)FUNNY#END#THING/
 196              || $c =~ /^(\s*\.text\n|\s*\.r?data\n)FUNNY#END#THING/ ) {
 197             $to_move = $1;
 198
 199             if ( $to_move =~ /\.(globl|ent)/ && $i < ($numchks - 1) ) {
 200                 $chk[$i + 1] = $to_move . $chk[$i + 1];
 201                 # otherwise they're tossed
 202             }
 203
 204             $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/;
 205         }
 206
 207         # toss all prologue stuff;
 208         # be slightly paranoid to make sure there's
 209         # nothing surprising in there
 210         if ( $c =~ /--- BEGIN ---/ ) {
 211             if (($p, $r) = split(/--- BEGIN ---/, $c)) {
 212                 # the .frame/.mask/.fmask that we use is the same
 213                 # as that produced by GCC for miniInterpret; this
 214                 # gives GDB some chance of figuring out what happened
 215                 $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n";
 216                 $p =~ s/^\t\.(frame).*\n/__FRAME__/g;
 217                 $p =~ s/^\t\.(mask|fmask).*\n//g;
 218                 $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/; # 16 + 100 4-byte args
 219                 $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//;
 220                 $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//;
 221                 $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//;
 222                 $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//;
 223                 $p =~ s/__FRAME__/$FRAME/;
 224                 die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
 225
 226                 # glue together what's left
 227                 $c = $p . $r;
 228                 $c =~ s/\n\t\n/\n/; # junk blank line
 229             }
 230         }
 231
 232         # toss all epilogue stuff; again, paranoidly;
 233         # first, this basic sequence may occur "--- END ---" or not
 234         $c =~ s/^\tlw\t\$31,\d+\(\$sp\)\n\taddu\t\$sp,\$sp,\d+\n\tj\t\$31\n\t\.end/\t\.end/;
 235
 236         if ( $c =~ /--- END ---/ ) {
 237             if (($r, $e) = split(/--- END ---/, $c)) {
 238                 $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//;
 239                 $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//;
 240                 $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//;
 241                 $e =~ s/^\tj\t\$31\n//;
 242                 die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/;
 243
 244                 # glue together what's left
 245                 $c = $r . $e;
 246                 $c =~ s/\n\t\n/\n/; # junk blank line
 247             }
 248         }
 249
 250         # toss all calls to __DISCARD__
 251         $c =~ s/^\tjal\t__DISCARD__\n//g;
 252         # that may leave some gratuitous asm macros around
 253         # (no harm done; but we get rid of them to be tidier)
 254         $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/;
 255
 256         $c =~ s/FUNNY#END#THING//;
 257         $chk[$i] = $c; # update w/ convenience copy
 258
 259         print STDERR "NB: Contains magic stuff!\n$c\n" if $c =~ /^\t[^\.].*(\$28)\b/;
 260
 261 #       print STDERR "\nCHK $i (AFTER):\n", $c;
 262
 263     }
 264
 265     # print out the header stuff first
 266     $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0];
 267
 268     # get rid of horrible "$Revision: 1.1 $" strings
 269     local(@lines0) = split(/\n/, $chk[0]);
 270     local($z) = 0;
 271     while ( $z <= $#lines0 ) {
 272         if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/ ) {
 273             undef($lines0[$z]);
 274             $z++;
 275             while ( $z <= $#lines0 ) {
 276                 undef($lines0[$z]);
 277                 last if $lines0[$z] =~ /[,\t]0x0$/;
 278                 $z++;
 279             }
 280         }
 281         $z++;
 282     }
 283     $chk[0] = join("\n", @lines0);
 284     $chk[0] =~ s/\n\n+/\n/;
 285     print OUTASM $chk[0];
 286
 287     # print out all the literal strings second
 288     for ($i = 1; $i < $numchks; $i++) {
 289         if ( $chkcat[$i] eq 'string' ) {
 290             print OUTASM "\t\.rdata\n\t\.align 2\n";
 291             print OUTASM $chk[$i];
 292
 293             $chkcat[$i] = 'DONE ALREADY';
 294         }
 295     }
 296
 297     for ($i = 1; $i < $numchks; $i++) {
 298 #       print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
 299
 300         next if $chkcat[$i] eq 'DONE ALREADY';
 301
 302         if ( $chkcat[$i] eq 'misc' ) {
 303             print OUTASM "\t\.text\n\t\.align 2\n";
 304             print OUTASM $chk[$i];
 305
 306         } elsif ( $chkcat[$i] eq 'data' ) {
 307             print OUTASM "\t\.data\n\t\.align 2\n";
 308             print OUTASM $chk[$i];
 309
 310         } elsif ( $chkcat[$i] eq 'consist' ) {
 311 #? consistency string is just a v
 312 #? horrible bunch of .bytes,
 313 #? which I am too lazy to sort out (WDP 95/05)
 314 #?          if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) {
 315 #?              local($consist) = "$1.$2.$3";
 316 #?              $consist =~ s/,/./g;
 317 #?              $consist =~ s/\//./g;
 318 #?              $consist =~ s/-/_/g;
 319 #?              $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
 320 #?              print OUTASM "\t\.text\n$consist:\n";
 321 #?          } else {
 322 #?              print STDERR "Couldn't grok consistency: ", $chk[$i];
 323 #?          }
 324
 325         } elsif ( $chkcat[$i] eq 'splitmarker' ) {
 326             # we can just re-constitute this one...
 327             # ignore the final split marker, to save an empty object module
 328             # Use _three_ underscores so that ghc-split doesn't get overly complicated
 329             print OUTASM "___stg_split_marker",$chksymb[$i],":\n";
 330
 331         } elsif ( $chkcat[$i] eq 'closure'
 332                || $chkcat[$i] eq 'infotbl'
 333                || $chkcat[$i] eq 'slow'
 334                || $chkcat[$i] eq 'fast' ) { # do them in that order
 335             $symb = $chksymb[$i];
 336
 337             # CLOSURE
 338             if ( defined($closurechk{$symb}) ) {
 339                 print OUTASM "\t\.data\n\t\.align 2\n";
 340                 print OUTASM $chk[$closurechk{$symb}];
 341                 $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
 342             }
 343
 344             # INFO TABLE
 345             if ( defined($infochk{$symb}) ) {
 346
 347                 print OUTASM "\t\.text\n\t\.align 2\n";
 348                 print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
 349                 # entry code will be put here!
 350
 351                 $chkcat[$infochk{$symb}] = 'DONE ALREADY';
 352             }
 353
 354             # STD ENTRY POINT
 355             if ( defined($slowchk{$symb}) ) {
 356
 357                 # teach it to drop through to the fast entry point:
 358                 $c = $chk[$slowchk{$symb}];
 359                 if ( defined($fastchk{$symb}) ) {
 360                     $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
 361                 }
 362
 363                 print OUTASM "\t\.text\n\t\.align 2\n";
 364                 print OUTASM $c;
 365                 $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
 366             }
 367
 368             # FAST ENTRY POINT
 369             if ( defined($fastchk{$symb}) ) {
 370                 $c = $chk[$fastchk{$symb}];
 371                 if ( ! defined($slowchk{$symb}) ) {
 372                     print OUTASM "\t\.text\n\t\.align 2\n";
 373                 }
 374                 print OUTASM $c;
 375                 $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
 376             }
 377
 378         } elsif ( $chkcat[$i] eq 'vector'
 379                || $chkcat[$i] eq 'direct' ) { # do them in that order
 380             $symb = $chksymb[$i];
 381
 382             # VECTOR TABLE
 383             if ( defined($vectorchk{$symb}) ) {
 384                 print OUTASM "\t\.text\n\t\.align 2\n";
 385                 print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
 386                 # direct return code will be put here!
 387                 $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
 388             }
 389
 390             # DIRECT RETURN
 391             if ( defined($directchk{$symb}) ) {
 392                 print OUTASM "\t\.text\n\t\.align 2\n";
 393                 print OUTASM $chk[$directchk{$symb}];
 394                 $chkcat[$directchk{$symb}] = 'DONE ALREADY';
 395             } else {
 396                 # The commented nop is for the splitter, to ensure
 397                 # that no module ends with a label as the very last
 398                 # thing.  (The linker will adjust the label to point
 399                 # to the first code word of the next module linked in,
 400                 # even if alignment constraints cause the label to move!)
 401
 402                 print OUTASM "\t# nop\n";
 403             }
 404         } else {
 405             &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm alpha)\n$chkcat[$i]\n$chk[$i]\n");
 406         }
 407     }
 408
 409     print OUTASM $EXTERN_DECLS;
 410
 411     # finished:
 412     close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
 413     close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
 414 }
 415 \end{code}
 416
 417 \begin{code}
 418 sub init_FUNNY_THINGS {
 419     %KNOWN_FUNNY_THING = (
 420         'CheckHeapCode:', 1,
 421         'CommonUnderflow:', 1,
 422         'Continue:', 1,
 423         'EnterNodeCode:', 1,
 424         'ErrorIO_call_count:', 1,
 425         'ErrorIO_innards:', 1,
 426         'IndUpdRetDir:', 1,
 427         'IndUpdRetV0:', 1,
 428         'IndUpdRetV1:', 1,
 429         'IndUpdRetV2:', 1,
 430         'IndUpdRetV3:', 1,
 431         'IndUpdRetV4:', 1,
 432         'IndUpdRetV5:', 1,
 433         'IndUpdRetV6:', 1,
 434         'IndUpdRetV7:', 1,
 435         'PrimUnderflow:', 1,
 436         'StackUnderflowEnterNode:', 1,
 437         'StdErrorCode:', 1,
 438         'UnderflowVect0:', 1,
 439         'UnderflowVect1:', 1,
 440         'UnderflowVect2:', 1,
 441         'UnderflowVect3:', 1,
 442         'UnderflowVect4:', 1,
 443         'UnderflowVect5:', 1,
 444         'UnderflowVect6:', 1,
 445         'UnderflowVect7:', 1,
 446         'UpdErr:', 1,
 447         'UpdatePAP:', 1,
 448         'WorldStateToken:', 1,
 449         '_Enter_Internal:', 1,
 450         '_PRMarking_MarkNextAStack:', 1,
 451         '_PRMarking_MarkNextBStack:', 1,
 452         '_PRMarking_MarkNextCAF:', 1,
 453         '_PRMarking_MarkNextGA:', 1,
 454         '_PRMarking_MarkNextRoot:', 1,
 455         '_PRMarking_MarkNextSpark:', 1,
 456         '_Scavenge_Forward_Ref:', 1,
 457         '__std_entry_error__:', 1,
 458         '_startMarkWorld:', 1,
 459         'resumeThread:', 1,
 460         'startCcRegisteringWorld:', 1,
 461         'startEnterFloat:', 1,
 462         'startEnterInt:', 1,
 463         'startPerformIO:', 1,
 464         'startStgWorld:', 1,
 465         'stopPerformIO:', 1
 466   );
 467 }
 468 \end{code}
 469
 470 The following table reversal is used for both info tables and return
 471 vectors.  In both cases, we remove the first entry from the table,
 472 reverse the table, put the label at the end, and paste some code
 473 (that which is normally referred to by the first entry in the table)
 474 right after the table itself.  (The code pasting is done elsewhere.)
 475
 476 \begin{code}
 477 sub rev_tbl {
 478     local($symb, $tbl, $discard1) = @_;
 479
 480     local($before) = '';
 481     local($label) = '';
 482     local(@words) = ();
 483     local($after) = '';
 484     local(@lines) = split(/\n/, $tbl);
 485     local($i);
 486
 487     for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.word\s+/; $i++) {
 488         $label .= $lines[$i] . "\n",
 489             next if $lines[$i] =~ /^[A-Za-z0-9_]+:$/
 490                  || $lines[$i] =~ /^\t\.globl/;
 491
 492         $before .= $lines[$i] . "\n"; # otherwise...
 493     }
 494
 495     for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.word\s+/; $i++) {
 496         push(@words, $lines[$i]);
 497     }
 498     # now throw away the first word (entry code):
 499     shift(@words) if $discard1;
 500
 501     for (; $i <= $#lines; $i++) {
 502         $after .= $lines[$i] . "\n";
 503     }
 504
 505     $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after;
 506
 507 #    print STDERR "before=$before\n";
 508 #    print STDERR "label=$label\n";
 509 #    print STDERR "words=",(reverse @words),"\n";
 510 #    print STDERR "after=$after\n";
 511
 512     $tbl;
 513 }
 514
 515 # make "require"r happy...
 516 1;
 517 \end{code}