ghc/driver/ghc-asm-m68k.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-asm-fiddling]{Fiddling with assembler files (m68k)}
   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         next if /^#(NO_)?APP/;
  51
  52         if ( /^\s+/ ) { # most common case first -- a simple line!
  53             # duplicated from the bottom
  54
  55             $chk[$i] .= $_;
  56
  57         } elsif ( /^_(ret_|djn_)/ ) {
  58             $chk[++$i] .= $_;
  59             $chkcat[$i] = 'misc';
  60             $chksymb[$i] = '';
  61
  62         } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) {
  63             $chk[++$i] .= $_;
  64             $chkcat[$i] = 'vector';
  65             $chksymb[$i] = $1;
  66
  67             $vectorchk{$1} = $i;
  68
  69         } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) {
  70             $chk[++$i] .= $_;
  71             $chkcat[$i] = 'direct';
  72             $chksymb[$i] = $1;
  73
  74             $directchk{$1} = $i;
  75
  76         } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) {
  77             $chk[++$i] .= $_;
  78             $chkcat[$i] = 'misc';
  79             $chksymb[$i] = '';
  80
  81         } elsif ( /^LC(\d+):$/ ) {
  82             $chk[++$i] .= $_;
  83             $chkcat[$i] = 'string';
  84             $chksymb[$i] = $1;
  85
  86         } elsif ( /^___stg_split_marker(\d+):$/ ) {
  87             $chk[++$i] .= $_;
  88             $chkcat[$i] = 'splitmarker';
  89             $chksymb[$i] = $1;
  90
  91         } elsif ( /^_([A-Za-z0-9_]+)_info:$/ ) {
  92             $symb = $1;
  93             $chk[++$i] .= $_;
  94             $chkcat[$i] = 'infotbl';
  95             $chksymb[$i] = $symb;
  96
  97             $infochk{$symb} = $i;
  98
  99         } elsif ( /^_([A-Za-z0-9_]+)_entry:$/ ) {
 100             $chk[++$i] .= $_;
 101             $chkcat[$i] = 'slow';
 102             $chksymb[$i] = $1;
 103
 104             $slowchk{$1} = $i;
 105
 106         } elsif ( /^_([A-Za-z0-9_]+)_fast\d+:$/ ) {
 107             $chk[++$i] .= $_;
 108             $chkcat[$i] = 'fast';
 109             $chksymb[$i] = $1;
 110
 111             $fastchk{$1} = $i;
 112
 113         } elsif ( /^_([A-Za-z0-9_]+)_closure:$/ ) {
 114             $chk[++$i] .= $_;
 115             $chkcat[$i] = 'closure';
 116             $chksymb[$i] = $1;
 117
 118             $closurechk{$1} = $i;
 119
 120         } elsif ( /^_ghc.*c_ID:/ ) {
 121             $chk[++$i] .= $_;
 122             $chkcat[$i] = 'consist';
 123
 124         } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.):/ ) {
 125             ; # toss it
 126
 127         } elsif ( /^_ErrorIO_call_count:/        # HACK!!!!
 128                || /^_[A-Za-z0-9_]+\.\d+:$/
 129                || /^_.*_CAT:/                   # PROF: _entryname_CAT
 130                || /^_CC_.*_struct:/             # PROF: _CC_ccident_struct
 131                || /^_.*_done:/                  # PROF: _module_done
 132                || /^__module_registered:/       # PROF: _module_registered
 133                ) {
 134             $chk[++$i] .= $_;
 135             $chkcat[$i] = 'data';
 136             $chksymb[$i] = '';
 137
 138         } elsif ( /^_[A-Za-z0-9_]/ ) {
 139             local($thing);
 140             chop($thing = $_);
 141             print STDERR "Funny global thing?: $_"
 142                 unless $KNOWN_FUNNY_THING{$thing}
 143                     || /^__(PRIn|PRStart).*:/   # pointer reversal GC routines
 144                     || /^_CC_.*:/               # PROF: _CC_ccident
 145                     || /^__reg.*:/;             # PROF: __reg<module>
 146             $chk[++$i] .= $_;
 147             $chkcat[$i] = 'misc';
 148             $chksymb[$i] = '';
 149
 150         } else { # simple line (duplicated at the top)
 151
 152             $chk[$i] .= $_;
 153         }
 154     }
 155     $numchks = $#chk + 1;
 156
 157     # the division into chunks is imperfect;
 158     # we throw some things over the fence into the next
 159     # chunk.
 160     #
 161     # also, there are things we would like to know
 162     # about the whole module before we start spitting
 163     # output.
 164
 165     # NB: we start meddling at chunk 1, not chunk 0
 166
 167     for ($i = 1; $i < $numchks; $i++) {
 168         $c = $chk[$i]; # convenience copy
 169
 170 #       print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c;
 171
 172         # toss all prologue stuff;
 173         # be slightly paranoid to make sure there's
 174         # nothing surprising in there
 175         if ( $c =~ /--- BEGIN ---/ ) {
 176             if (($p, $r) = split(/--- BEGIN ---/, $c)) {
 177                 $p =~ s/^\tlink a6,#-?\d.*\n//;
 178                 $p =~ s/^\tmovel d2,sp\@-\n//;
 179                 $p =~ s/^\tmovel d5,sp\@-\n//; # SMmark.* only?
 180                 $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//; # SMmark.* only?
 181                 die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
 182
 183                 # glue together what's left
 184                 $c = $p . $r;
 185             }
 186         }
 187
 188         # toss all epilogue stuff; again, paranoidly
 189         if ( $c =~ /--- END ---/ ) {
 190             if (($r, $e) = split(/--- END ---/, $c)) {
 191                 $e =~ s/^\tunlk a6\n//;
 192                 $e =~ s/^\trts\n//;
 193                 die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/;
 194
 195                 # glue together what's left
 196                 $c = $r . $e;
 197             }
 198         }
 199
 200         # toss all calls to __DISCARD__
 201         $c =~ s/^\tjbsr ___DISCARD__\n//g;
 202
 203         # toss stack adjustment after DoSparks
 204         $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/g;
 205
 206         # pin a funny end-thing on (for easier matching):
 207         $c .= 'FUNNY#END#THING';
 208
 209         # pick some end-things and move them to the next chunk
 210
 211         while ( $c =~ /^\s*(\.align\s+\d+\n|\.proc\s+\d+\n|\.const\n|\.cstring\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.even\n|\.stab[^n].*\n)FUNNY#END#THING/ ) {
 212             $to_move = $1;
 213
 214             if ( $to_move =~ /\.(globl|proc|stab)/ && $i < ($numchks - 1) ) {
 215                 $chk[$i + 1] = $to_move . $chk[$i + 1];
 216                 # otherwise they're tossed
 217             }
 218
 219             $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/;
 220         }
 221
 222         $c =~ s/FUNNY#END#THING//;
 223         $chk[$i] = $c; # update w/ convenience copy
 224     }
 225
 226     # print out all the literal strings first
 227     for ($i = 0; $i < $numchks; $i++) {
 228         if ( $chkcat[$i] eq 'string' ) {
 229             print OUTASM "\.text\n\t\.even\n";
 230             print OUTASM $chk[$i];
 231
 232             $chkcat[$i] = 'DONE ALREADY';
 233         }
 234     }
 235
 236     for ($i = 0; $i < $numchks; $i++) {
 237 #       print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
 238
 239         next if $chkcat[$i] eq 'DONE ALREADY';
 240
 241         if ( $chkcat[$i] eq 'misc' ) {
 242             print OUTASM "\.text\n\t\.even\n";
 243             print OUTASM $chk[$i];
 244
 245         } elsif ( $chkcat[$i] eq 'data' ) {
 246             print OUTASM "\.data\n\t\.even\n";
 247             print OUTASM $chk[$i];
 248
 249         } elsif ( $chkcat[$i] eq 'consist' ) {
 250             if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) {
 251                 local($consist) = "$1.$2.$3";
 252                 $consist =~ s/,/./g;
 253                 $consist =~ s/\//./g;
 254                 $consist =~ s/-/_/g;
 255                 $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
 256                 print OUTASM "\.text\n$consist:\n";
 257             } else {
 258                 print STDERR "Couldn't grok consistency: ", $chk[$i];
 259             }
 260
 261         } elsif ( $chkcat[$i] eq 'splitmarker' ) {
 262             # we can just re-constitute this one...
 263             print OUTASM "___stg_split_marker",$chksymb[$i],":\n";
 264
 265         } elsif ( $chkcat[$i] eq 'closure'
 266                || $chkcat[$i] eq 'infotbl'
 267                || $chkcat[$i] eq 'slow'
 268                || $chkcat[$i] eq 'fast' ) { # do them in that order
 269             $symb = $chksymb[$i];
 270
 271             # CLOSURE
 272             if ( defined($closurechk{$symb}) ) {
 273                 print OUTASM "\.data\n\t\.even\n";
 274                 print OUTASM $chk[$closurechk{$symb}];
 275                 $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
 276             }
 277
 278             # INFO TABLE
 279             if ( defined($infochk{$symb}) ) {
 280
 281                 print OUTASM "\.text\n\t\.even\n";
 282                 print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
 283                 # entry code will be put here!
 284
 285                 $chkcat[$infochk{$symb}] = 'DONE ALREADY';
 286             }
 287
 288             # STD ENTRY POINT
 289             if ( defined($slowchk{$symb}) ) {
 290
 291                 # teach it to drop through to the fast entry point:
 292                 $c = $chk[$slowchk{$symb}];
 293                 $c =~ s/^\tjmp _${symb}_fast\d+.*\n\tnop\n//;
 294                 $c =~ s/^\tjmp _${symb}_fast\d+.*\n//;
 295
 296                 print STDERR "still has jump to fast entry point:\n$c"
 297                     if $c =~ /_${symb}_fast/;
 298
 299                 print OUTASM "\.text\n\t\.even\n";
 300                 print OUTASM $c;
 301                 $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
 302             }
 303
 304             # FAST ENTRY POINT
 305             if ( defined($fastchk{$symb}) ) {
 306                 print OUTASM "\.text\n\t\.even\n";
 307                 print OUTASM $chk[$fastchk{$symb}];
 308                 $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
 309             }
 310
 311         } elsif ( $chkcat[$i] eq 'vector'
 312                || $chkcat[$i] eq 'direct' ) { # do them in that order
 313             $symb = $chksymb[$i];
 314
 315             # VECTOR TABLE
 316             if ( defined($vectorchk{$symb}) ) {
 317                 print OUTASM "\.text\n\t\.even\n";
 318                 print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
 319                 # direct return code will be put here!
 320                 $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
 321             }
 322
 323             # DIRECT RETURN
 324             if ( defined($directchk{$symb}) ) {
 325                 print OUTASM "\.text\n\t\.even\n";
 326                 print OUTASM $chk[$directchk{$symb}];
 327                 $chkcat[$directchk{$symb}] = 'DONE ALREADY';
 328             }
 329
 330         } else {
 331             &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm m68k)\n$chkcat[$i]\n$chk[$i]\n");
 332         }
 333     }
 334
 335     # finished:
 336     close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
 337     close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
 338 }
 339 \end{code}
 340
 341 \begin{code}
 342 sub init_FUNNY_THINGS {
 343     %KNOWN_FUNNY_THING = (
 344         '_CheckHeapCode:', 1,
 345         '_CommonUnderflow:', 1,
 346         '_Continue:', 1,
 347         '_EnterNodeCode:', 1,
 348         '_ErrorIO_call_count:', 1,
 349         '_ErrorIO_innards:', 1,
 350         '_IndUpdRetDir:', 1,
 351         '_IndUpdRetV0:', 1,
 352         '_IndUpdRetV1:', 1,
 353         '_IndUpdRetV2:', 1,
 354         '_IndUpdRetV3:', 1,
 355         '_IndUpdRetV4:', 1,
 356         '_IndUpdRetV5:', 1,
 357         '_IndUpdRetV6:', 1,
 358         '_IndUpdRetV7:', 1,
 359         '_PrimUnderflow:', 1,
 360         '_StackUnderflowEnterNode:', 1,
 361         '_StdErrorCode:', 1,
 362         '_UnderflowVect0:', 1,
 363         '_UnderflowVect1:', 1,
 364         '_UnderflowVect2:', 1,
 365         '_UnderflowVect3:', 1,
 366         '_UnderflowVect4:', 1,
 367         '_UnderflowVect5:', 1,
 368         '_UnderflowVect6:', 1,
 369         '_UnderflowVect7:', 1,
 370         '_UpdErr:', 1,
 371         '_UpdatePAP:', 1,
 372         '_WorldStateToken:', 1,
 373         '__Enter_Internal:', 1,
 374         '__PRMarking_MarkNextAStack:', 1,
 375         '__PRMarking_MarkNextBStack:', 1,
 376         '__PRMarking_MarkNextCAF:', 1,
 377         '__PRMarking_MarkNextGA:', 1,
 378         '__PRMarking_MarkNextRoot:', 1,
 379         '__PRMarking_MarkNextSpark:', 1,
 380         '__Scavenge_Forward_Ref:', 1,
 381         '___std_entry_error__:', 1,
 382         '__startMarkWorld:', 1,
 383         '_resumeThread:', 1,
 384         '_startCcRegisteringWorld:', 1,
 385         '_startEnterFloat:', 1,
 386         '_startEnterInt:', 1,
 387         '_startPerformIO:', 1,
 388         '_startStgWorld:', 1,
 389         '_stopPerformIO:', 1
 390     );
 391 }
 392 \end{code}
 393
 394 The following table reversal is used for both info tables and return
 395 vectors.  In both cases, we remove the first entry from the table,
 396 reverse the table, put the label at the end, and paste some code
 397 (that which is normally referred to by the first entry in the table)
 398 right after the table itself.  (The code pasting is done elsewhere.)
 399
 400 \begin{code}
 401 sub rev_tbl {
 402     local($symb, $tbl, $discard1) = @_;
 403
 404     local($before) = '';
 405     local($label) = '';
 406     local(@words) = ();
 407     local($after) = '';
 408     local(@lines) = split(/\n/, $tbl);
 409     local($i);
 410
 411     for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.long\s+/; $i++) {
 412         $label .= $lines[$i] . "\n",
 413             next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/
 414                  || $lines[$i] =~ /^\.globl/
 415                  || $lines[$i] =~ /^_vtbl_\S+:$/;
 416
 417         $before .= $lines[$i] . "\n"; # otherwise...
 418     }
 419
 420     for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\s+/; $i++) {
 421         push(@words, $lines[$i]);
 422     }
 423     # now throw away the first word (entry code):
 424     shift(@words) if $discard1;
 425
 426     for (; $i <= $#lines; $i++) {
 427         $after .= $lines[$i] . "\n";
 428     }
 429
 430     $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after;
 431
 432 #   print STDERR "before=$before\n";
 433 #   print STDERR "label=$label\n";
 434 #   print STDERR "words=",(reverse @words),"\n";
 435 #   print STDERR "after=$after\n";
 436
 437     $tbl;
 438 }
 439 \end{code}
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsection[Driver-asm-info]{Collect interesting (static) info from an assembler file}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 How many times is each asm instruction used?
 448
 449 \begin{code}
 450 %AsmInsn = (); # init
 451
 452 sub dump_asm_insn_counts {
 453     local($asmf) = @_;
 454
 455     open(INASM, "< $asmf")  || &tidy_up_and_die(1,"$Pgm: failed to open `$asmf' (to read)\n");
 456     while (<INASM>) {
 457         if ( /^\t([a-z][a-z0-9]+)\b/ ) {
 458             $AsmInsn{$1} ++;
 459         }
 460     }
 461     close(INASM) || &tidy_up_and_die(1,"Failed reading from $asmf\n");
 462
 463     # OK, now print what we collected (to stderr)
 464     foreach $i (sort (keys %AsmInsn)) {
 465         print STDERR "INSN:: $i\t",$AsmInsn{$i},"\n";
 466     }
 467 }
 468
 469 sub dump_asm_globals_info {
 470 }
 471
 472 # make "require"r happy...
 473 1;
 474
 475 \end{code}