ghc/driver/ghc-asm-alpha.lprl

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