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