ghc/driver/ghc-asm.lprl

   1 %************************************************************************
   2 %*                                                                      *
   3 \section[Driver-asm-fiddling]{Fiddling with assembler files}
   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 %************************************************************************
  17 %*                                                                      *
  18 \subsection{Constants for various architectures}
  19 %*                                                                      *
  20 %************************************************************************
  21
  22 \begin{code}
  23 sub init_TARGET_STUFF {
  24
  25     if ( $TargetPlatform =~ /^i386-.*-linuxaout/ ) {
  26
  27     $T_STABBY       = 1; # 1 iff .stab things (usually if a.out format)
  28     $T_US           = '_'; # _ if symbols have an underscore on the front
  29     $T_DO_GC        = '_PerformGC_wrapper';
  30     $T_PRE_APP      = '^#'; # regexp that says what comes before APP/NO_APP
  31     $T_CONST_LBL    = '^LC(\d+):$';
  32     $T_POST_LBL     = ':';
  33     $T_PRE_LLBL_PAT = 'L';
  34     $T_PRE_LLBL     = 'L';
  35     $T_X86_BADJMP   = '^\tjmp [^L\*]';
  36
  37     $T_MOVE_DIRVS   = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.stab[^n].*\n)';
  38     $T_COPY_DIRVS   = '\.(globl|stab)';
  39     $T_hsc_cc_PAT   = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
  40     $T_DOT_WORD     = '\.long';
  41     $T_HDR_string   = "\.text\n\t\.align 4\n"; # .align 4 is 486-cache friendly
  42     $T_HDR_misc     = "\.text\n\t\.align 4\n";
  43     $T_HDR_data     = "\.data\n\t\.align 2\n"; # ToDo: change align??
  44     $T_HDR_consist  = "\.text\n";
  45     $T_HDR_closure  = "\.data\n\t\.align 2\n"; # ToDo: change align?
  46     $T_HDR_info     = "\.text\n\t\.align 4\n"; # NB: requires padding
  47     $T_HDR_entry    = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
  48     $T_HDR_fast     = "\.text\n\t\.align 4\n";
  49     $T_HDR_vector   = "\.text\n\t\.align 4\n"; # NB: requires padding
  50     $T_HDR_direct   = "\.text\n\t\.align 4\n";
  51
  52     } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/ ) {
  53
  54     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
  55     $T_US           = ''; # _ if symbols have an underscore on the front
  56     $T_DO_GC        = 'PerformGC_wrapper';
  57     $T_PRE_APP      = '/'; # regexp that says what comes before APP/NO_APP
  58     $T_CONST_LBL    = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
  59     $T_POST_LBL     = ':';
  60     $T_PRE_LLBL_PAT = '\.L';
  61     $T_PRE_LLBL     = '.L';
  62     $T_X86_BADJMP   = '^\tjmp [^\.\*]';
  63
  64     $T_MOVE_DIRVS   = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.section\s+.*\n|\.type\s+.*\n|\.Lfe.*\n\t\.size\s+.*\n|\.size\s+.*\n|\.ident.*\n)';
  65     $T_COPY_DIRVS   = '\.(globl)';
  66
  67     $T_hsc_cc_PAT   = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
  68     $T_DOT_WORD     = '\.long';
  69     $T_HDR_string   = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11)
  70     $T_HDR_misc     = "\.text\n\t\.align 16\n";
  71     $T_HDR_data     = "\.data\n\t\.align 4\n"; # ToDo: change align??
  72     $T_HDR_consist  = "\.text\n";
  73     $T_HDR_closure  = "\.data\n\t\.align 4\n"; # ToDo: change align?
  74     $T_HDR_info     = "\.text\n\t\.align 16\n"; # NB: requires padding
  75     $T_HDR_entry    = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
  76     $T_HDR_fast     = "\.text\n\t\.align 16\n";
  77     $T_HDR_vector   = "\.text\n\t\.align 16\n"; # NB: requires padding
  78     $T_HDR_direct   = "\.text\n\t\.align 16\n";
  79
  80     } elsif ( $TargetPlatform =~ /^powerpc-.*/ ) {
  81
  82     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
  83     $T_US           = '\.'; # _ if symbols have an underscore on the front
  84     $T_DO_GC        = 'PerformGC_wrapper';
  85     $T_PRE_APP      = 'NOT APPLICABLE'; # regexp that says what comes before APP/NO_APP
  86     $T_CONST_LBL    = '^LC\.\.(\d+):$'; # regexp for what such a lbl looks like
  87     $T_POST_LBL     = ':';
  88     $T_PRE_LLBL_PAT = '\.L';
  89     $T_PRE_LLBL     = '.L';
  90     $T_X86_BADJMP   = 'NOT APPLICABLE';
  91
  92     $T_MOVE_DIRVS   = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.section\s+.*\n|\.type\s+.*\n|\.Lfe.*\n\t\.size\s+.*\n|\.size\s+.*\n|\.ident.*\n)';
  93     $T_COPY_DIRVS   = '\.(globl)';
  94
  95     $T_hsc_cc_PAT   = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
  96     $T_DOT_WORD     = '\.long';
  97     $T_HDR_string   = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11)
  98     $T_HDR_misc     = "\.text\n\t\.align 16\n";
  99     $T_HDR_data     = "\.data\n\t\.align 4\n"; # ToDo: change align??
 100     $T_HDR_consist  = "\.text\n";
 101     $T_HDR_closure  = "\.data\n\t\.align 4\n"; # ToDo: change align?
 102     $T_HDR_info     = "\.text\n\t\.align 16\n"; # NB: requires padding
 103     $T_HDR_entry    = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
 104     $T_HDR_fast     = "\.text\n\t\.align 16\n";
 105     $T_HDR_vector   = "\.text\n\t\.align 16\n"; # NB: requires padding
 106     $T_HDR_direct   = "\.text\n\t\.align 16\n";
 107     }
 108
 109 if ( 0 ) {
 110 print STDERR "T_STABBY: $T_STABBY\n";
 111 print STDERR "T_US: $T_US\n";
 112 print STDERR "T_DO_GC: $T_DO_GC\n";
 113 print STDERR "T_PRE_APP: $T_PRE_APP\n";
 114 print STDERR "T_CONST_LBL: $T_CONST_LBL\n";
 115 print STDERR "T_POST_LBL: $T_POST_LBL\n";
 116 print STDERR "T_PRE_LLBL_PAT: $T_PRE_LLBL_PAT\n";
 117 print STDERR "T_PRE_LLBL: $T_PRE_LLBL\n";
 118 print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n";
 119
 120 print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n";
 121 print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n";
 122 print STDERR "T_hsc_cc_PAT: $T_hsc_cc_PAT\n";
 123 print STDERR "T_DOT_WORD: $T_DOT_WORD\n";
 124 print STDERR "T_HDR_string: $T_HDR_string\n";
 125 print STDERR "T_HDR_misc: $T_HDR_misc\n";
 126 print STDERR "T_HDR_data: $T_HDR_data\n";
 127 print STDERR "T_HDR_consist: $T_HDR_consist\n";
 128 print STDERR "T_HDR_closure: $T_HDR_closure\n";
 129 print STDERR "T_HDR_info: $T_HDR_info\n";
 130 print STDERR "T_HDR_entry: $T_HDR_entry\n";
 131 print STDERR "T_HDR_fast: $T_HDR_fast\n";
 132 print STDERR "T_HDR_vector: $T_HDR_vector\n";
 133 print STDERR "T_HDR_direct: $T_HDR_direct\n";
 134 }
 135
 136 }
 137 \end{code}
 138
 139 %************************************************************************
 140 %*                                                                      *
 141 \subsection{Mangle away}
 142 %*                                                                      *
 143 %************************************************************************
 144
 145 \begin{code}
 146 sub mangle_asm {
 147     local($in_asmf, $out_asmf) = @_;
 148
 149     # multi-line regexp matching:
 150     local($*) = 1;
 151     local($i, $c);
 152     &init_TARGET_STUFF();
 153     &init_FUNNY_THINGS();
 154
 155     open(INASM, "< $in_asmf")
 156         || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
 157     open(OUTASM,"> $out_asmf")
 158         || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
 159
 160     # read whole file, divide into "chunks":
 161     #   record some info about what we've found...
 162
 163     @chk = ();          # contents of the chunk
 164     $numchks = 0;       # number of them
 165     @chkcat = ();       # what category of thing in each chunk
 166     @chksymb = ();      # what symbol(base) is defined in this chunk
 167     %slowchk = ();      # ditto, its regular "slow" entry code
 168     %fastchk = ();      # ditto, fast entry code
 169     %closurechk = ();   # ditto, the (static) closure
 170     %infochk = ();      # given a symbol base, say what chunk its info tbl is in
 171     %vectorchk = ();    # ditto, return vector table
 172     %directchk = ();    # ditto, direct return code
 173
 174     $i = 0;
 175     $chkcat[0] = 'misc';
 176
 177     while (<INASM>) {
 178         next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o;
 179         next if $T_STABBY && /^\.stab.*ghc.*c_ID/;
 180         next if /${T_PRE_APP}(NO_)?APP/o;
 181
 182         if ( /^\s+/ ) { # most common case first -- a simple line!
 183             # duplicated from the bottom
 184
 185             $chk[$i] .= $_;
 186
 187         } elsif ( /$T_CONST_LBL/o ) {
 188             $chk[++$i] .= $_;
 189             $chkcat[$i] = 'string';
 190             $chksymb[$i] = $1;
 191
 192         } elsif ( /^${T_US}__stg_split_marker(\d+)${T_POST_LBL}$/o ) {
 193             $chk[++$i] .= $_;
 194             $chkcat[$i] = 'splitmarker';
 195             $chksymb[$i] = $1;
 196
 197         } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/o ) {
 198             $symb = $1;
 199             $chk[++$i] .= $_;
 200             $chkcat[$i] = 'infotbl';
 201             $chksymb[$i] = $symb;
 202
 203             die "Info table already? $symb; $i\n" if defined($infochk{$symb});
 204
 205             $infochk{$symb} = $i;
 206
 207         } elsif ( /^${T_US}([A-Za-z0-9_]+)_entry${T_POST_LBL}$/o ) {
 208             $chk[++$i] .= $_;
 209             $chkcat[$i] = 'slow';
 210             $chksymb[$i] = $1;
 211
 212             $slowchk{$1} = $i;
 213
 214         } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d+${T_POST_LBL}$/o ) {
 215             $chk[++$i] .= $_;
 216             $chkcat[$i] = 'fast';
 217             $chksymb[$i] = $1;
 218
 219             $fastchk{$1} = $i;
 220
 221         } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) {
 222             $chk[++$i] .= $_;
 223             $chkcat[$i] = 'closure';
 224             $chksymb[$i] = $1;
 225
 226             $closurechk{$1} = $i;
 227
 228         } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) {
 229             $chk[++$i] .= $_;
 230             $chkcat[$i] = 'consist';
 231
 232         } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
 233             ; # toss it
 234
 235         } elsif ( /^${T_US}ErrorIO_call_count${T_POST_LBL}$/o   # HACK!!!!
 236                || /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/o
 237                || /^${T_US}.*_CAT${T_POST_LBL}$/o               # PROF: _entryname_CAT
 238                || /^${T_US}CC_.*_struct${T_POST_LBL}$/o         # PROF: _CC_ccident_struct
 239                || /^${T_US}.*_done${T_POST_LBL}$/o              # PROF: _module_done
 240                || /^${T_US}_module_registered${T_POST_LBL}$/o   # PROF: _module_registered
 241                ) {
 242             $chk[++$i] .= $_;
 243             $chkcat[$i] = 'data';
 244             $chksymb[$i] = '';
 245
 246         } elsif ( /^${T_US}(ret_|djn_)/o ) {
 247             $chk[++$i] .= $_;
 248             $chkcat[$i] = 'misc';
 249             $chksymb[$i] = '';
 250
 251         } elsif ( /^${T_US}vtbl_([A-Za-z0-9_]+)${T_POST_LBL}$/o ) {
 252             $chk[++$i] .= $_;
 253             $chkcat[$i] = 'vector';
 254             $chksymb[$i] = $1;
 255
 256             $vectorchk{$1} = $i;
 257
 258         } elsif ( /^${T_US}([A-Za-z0-9_]+)DirectReturn${T_POST_LBL}$/o ) {
 259             $chk[++$i] .= $_;
 260             $chkcat[$i] = 'direct';
 261             $chksymb[$i] = $1;
 262
 263             $directchk{$1} = $i;
 264
 265         } elsif ( /^${T_US}[A-Za-z0-9_]+_upd${T_POST_LBL}$/o ) {
 266             $chk[++$i] .= $_;
 267             $chkcat[$i] = 'misc';
 268             $chksymb[$i] = '';
 269
 270         } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/
 271              &&   /^(_uname|uname|stat|fstat):/ ) {
 272             # for some utterly bizarre reason, this platform
 273             # likes to drop little local C routines with these names
 274             # into each and every .o file that #includes the
 275             # relevant system .h file.  Yuck.  We just don't
 276             # tolerate them in .hc files (which we are processing
 277             # here).  If you need to call one of these things from
 278             # Haskell, make a call to your own C wrapper, then
 279             # put that C wrapper (which calls one of these) in a
 280             # plain .c file.  WDP 95/12
 281             $chk[++$i] .= $_;
 282             $chkcat[$i] = 'toss';
 283             $chksymb[$i] = $1;
 284
 285         } elsif ( /^${T_US}[A-Za-z0-9_]/o ) {
 286             local($thing);
 287             chop($thing = $_);
 288             print STDERR "Funny global thing?: $_"
 289                 unless $KNOWN_FUNNY_THING{$thing}
 290                     || /^${T_US}_(PRIn|PRStart).*${T_POST_LBL}$/o # pointer reversal GC routines
 291                     || /^${T_US}CC_.*${T_POST_LBL}$/            # PROF: _CC_ccident
 292                     || /^${T_US}_reg.*${T_POST_LBL}$/;          # PROF: __reg<module>
 293             $chk[++$i] .= $_;
 294             $chkcat[$i] = 'misc';
 295             $chksymb[$i] = '';
 296
 297         } else { # simple line (duplicated at the top)
 298
 299             $chk[$i] .= $_;
 300         }
 301     }
 302     $numchks = $#chk + 1;
 303
 304     # the division into chunks is imperfect;
 305     # we throw some things over the fence into the next
 306     # chunk.
 307     #
 308     # also, there are things we would like to know
 309     # about the whole module before we start spitting
 310     # output.
 311
 312     for ($i = 0; $i < $numchks; $i++) {
 313         $c = $chk[$i]; # convenience copy
 314
 315 #       print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c;
 316
 317         # toss all prologue stuff;
 318         # be slightly paranoid to make sure there's
 319         # nothing surprising in there
 320         if ( $c =~ /--- BEGIN ---/ ) {
 321             if (($p, $r) = split(/--- BEGIN ---/, $c)) {
 322                 $p =~ s/^\tpushl \%edi\n//;
 323                 $p =~ s/^\tpushl \%esi\n//;
 324                 $p =~ s/^\tsubl \$\d+,\%esp\n//;
 325                 die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
 326
 327                 # glue together what's left
 328                 $c = $p . $r;
 329             }
 330         }
 331
 332         # toss all epilogue stuff; again, paranoidly
 333         if ( $c =~ /--- END ---/ ) {
 334             if (($r, $e) = split(/--- END ---/, $c)) {
 335                 $e =~ s/^\tret\n//;
 336                 $e =~ s/^\tpopl \%edi\n//;
 337                 $e =~ s/^\tpopl \%esi\n//;
 338                 $e =~ s/^\taddl \$\d+,\%esp\n//;
 339                 die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/;
 340
 341                 # glue together what's left
 342                 $c = $r . $e;
 343             }
 344         }
 345
 346         # toss all calls to __DISCARD__
 347         $c =~ s/^\tcall ${T_US}__DISCARD__\n//go;
 348
 349         # pin a funny end-thing on (for easier matching):
 350         $c .= 'FUNNY#END#THING';
 351
 352         # pick some end-things and move them to the next chunk
 353
 354         while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/o ) {
 355             $to_move = $1;
 356
 357             if ( $to_move =~ /${T_COPY_DIRVS}/ && $i < ($numchks - 1) ) {
 358                 $chk[$i + 1] = $to_move . $chk[$i + 1];
 359                 # otherwise they're tossed
 360             }
 361
 362             $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/o;
 363         }
 364
 365         $c =~ s/FUNNY#END#THING//;
 366
 367 #       print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c;
 368
 369         $chk[$i] = $c; # update w/ convenience copy
 370     }
 371
 372     # print out all the literal strings first
 373     for ($i = 0; $i < $numchks; $i++) {
 374         if ( $chkcat[$i] eq 'string' ) {
 375             print OUTASM $T_HDR_string, $chk[$i];
 376
 377             $chkcat[$i] = 'DONE ALREADY';
 378         }
 379     }
 380
 381     for ($i = 0; $i < $numchks; $i++) {
 382 #       print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
 383
 384         next if $chkcat[$i] eq 'DONE ALREADY';
 385
 386         if ( $chkcat[$i] eq 'misc' ) {
 387             print OUTASM $T_HDR_misc;
 388             &print_doctored($chk[$i], 0);
 389
 390         } elsif ( $chkcat[$i] eq 'toss' ) {
 391             print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n";
 392
 393         } elsif ( $chkcat[$i] eq 'data' ) {
 394             print OUTASM $T_HDR_data;
 395             print OUTASM $chk[$i];
 396
 397         } elsif ( $chkcat[$i] eq 'consist' ) {
 398             if ( $chk[$i] =~ /$T_hsc_cc_PAT/o ) {
 399                 local($consist) = "$1.$2.$3";
 400                 $consist =~ s/,/./g;
 401                 $consist =~ s/\//./g;
 402                 $consist =~ s/-/_/g;
 403                 $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
 404                 print OUTASM $T_HDR_consist, "${consist}${T_POST_LBL}\n";
 405             } else {
 406                 print STDERR "Couldn't grok consistency: ", $chk[$i];
 407             }
 408
 409         } elsif ( $chkcat[$i] eq 'splitmarker' ) {
 410             # we can just re-constitute this one...
 411             print OUTASM "${T_US}__stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n";
 412
 413         } elsif ( $chkcat[$i] eq 'closure'
 414                || $chkcat[$i] eq 'infotbl'
 415                || $chkcat[$i] eq 'slow'
 416                || $chkcat[$i] eq 'fast' ) { # do them in that order
 417             $symb = $chksymb[$i];
 418
 419             # CLOSURE
 420             if ( defined($closurechk{$symb}) ) {
 421                 print OUTASM $T_HDR_closure;
 422                 print OUTASM $chk[$closurechk{$symb}];
 423                 $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
 424             }
 425
 426             # INFO TABLE
 427             if ( defined($infochk{$symb}) ) {
 428
 429                 print OUTASM $T_HDR_info;
 430                 print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
 431                 # entry code will be put here!
 432
 433                 # paranoia
 434                 if ( $chk[$infochk{$symb}] =~ /${T_DOT_WORD}\s+([A-Za-z0-9_]+_entry)$/o
 435                   && $1 ne "${T_US}${symb}_entry" ) {
 436                     print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
 437                 }
 438
 439                 $chkcat[$infochk{$symb}] = 'DONE ALREADY';
 440             }
 441
 442             # STD ENTRY POINT
 443             if ( defined($slowchk{$symb}) ) {
 444
 445                 # teach it to drop through to the fast entry point:
 446                 $c = $chk[$slowchk{$symb}];
 447
 448                 if ( defined($fastchk{$symb}) ) {
 449                     $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%edx\n\tjmp \*\%edx\n//;
 450                     $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%eax\n\tjmp \*\%eax\n//;
 451                 }
 452
 453                 print STDERR "still has jump to fast entry point:\n$c"
 454                     if $c =~ /${T_US}${symb}_fast/; # NB: paranoia
 455
 456                 print OUTASM $T_HDR_entry;
 457
 458                 &print_doctored($c, 1); # NB: the 1!!!
 459
 460                 $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
 461             }
 462
 463             # FAST ENTRY POINT
 464             if ( defined($fastchk{$symb}) ) {
 465                 print OUTASM $T_HDR_fast;
 466                 &print_doctored($chk[$fastchk{$symb}], 0);
 467                 $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
 468             }
 469
 470         } elsif ( $chkcat[$i] eq 'vector'
 471                || $chkcat[$i] eq 'direct' ) { # do them in that order
 472             $symb = $chksymb[$i];
 473
 474             # VECTOR TABLE
 475             if ( defined($vectorchk{$symb}) ) {
 476                 print OUTASM $T_HDR_vector;
 477                 print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
 478                 # direct return code will be put here!
 479                 $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
 480             }
 481
 482             # DIRECT RETURN
 483             if ( defined($directchk{$symb}) ) {
 484                 print OUTASM $T_HDR_direct;
 485                 &print_doctored($chk[$directchk{$symb}], 0);
 486                 $chkcat[$directchk{$symb}] = 'DONE ALREADY';
 487             }
 488
 489         } else {
 490             &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm: $TargetPlatform)\n$chkcat[$i]\n$chk[$i]\n");
 491         }
 492     }
 493     # finished
 494     close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
 495     close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
 496 }
 497 \end{code}
 498
 499 \begin{code}
 500 sub print_doctored {
 501     local($_, $need_fallthru_patch) = @_;
 502
 503     if ( $TargetPlatform !~ /^i386-/
 504       || ! /^\t[a-z]/ ) { # no instructions in here, apparently
 505         print OUTASM $_;
 506         return;
 507     }
 508     # OK, must do some x86 **HACKING**
 509
 510     local($entry_patch) = '';
 511     local($exit_patch)  = '';
 512     local($call_entry_patch)= '';
 513     local($call_exit_patch)     = '';
 514
 515 #OLD:   # first, convert calls to *very magic form*: (ToDo: document
 516     # for real!)  from
 517     #
 518     #   pushl $768
 519     #   call _?PerformGC_wrapper
 520     #   addl $4,%esp
 521     # to
 522     #   movl $768, %eax
 523     #   call _?PerformGC_wrapper
 524     #
 525     # The reason we do this now is to remove the apparent use of
 526     # %esp, which would throw off the "what patch code do we need"
 527     # decision.
 528     #
 529     # Special macros in ghc/includes/COptWraps.lh, used in
 530     # ghc/runtime/CallWrap_C.lc, are required for this to work!
 531     #
 532
 533     s/^\tpushl \$(\d+)\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \$$1,\%eax\n\tcall ${T_DO_GC}\n/go;
 534     s/^\tpushl \%eax\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tcall ${T_DO_GC}\n/go;
 535     s/^\tpushl \%edx\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \%edx,\%eax\n\tcall ${T_DO_GC}\n/go;
 536
 537 #=  if ( $StolenX86Regs <= 4 ) { # %ecx is ordinary reg
 538 #=      s/^\tpushl \%ecx\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \%ecx,\%eax\n\tcall ${T_DO_GC}\n/go;
 539 #=  }
 540
 541     # gotta watch out for weird instructions that
 542     # invisibly smash various regs:
 543     #   rep*    %ecx used for counting
 544     #   scas*   %edi used for destination index
 545     #   cmps*   %e[sd]i used for indices
 546     #   loop*   %ecx used for counting
 547     #
 548     # SIGH.
 549
 550     # We cater for:
 551     #  * use of STG reg [ nn(%ebx) ] where no machine reg avail
 552     #
 553     #  * GCC used an "STG reg" for its own purposes
 554     #
 555     #  * some secret uses of machine reg, requiring STG reg
 556     #    to be saved/restored
 557
 558     # The most dangerous "GCC uses" of an "STG reg" are when
 559     # the reg holds the target of a jmp -- it's tricky to
 560     # insert the patch-up code before we get to the target!
 561     # So here we change the jmps:
 562
 563     # --------------------------------------------------------
 564     # it can happen that we have jumps of the form...
 565     #   jmp *<something involving %esp>
 566     # or
 567     #   jmp <something involving another naughty register...>
 568     #
 569     # a reasonably-common case is:
 570     #
 571     #   movl $_blah,<bad-reg>
 572     #   jmp  *<bad-reg>
 573     #
 574     # which is easily fixed as:
 575     #
 576     # sigh! try to hack around it...
 577     #
 578
 579     if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi?
 580         s/^\tmovl (.*),\%esi\n\tjmp \*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
 581         s/^\tjmp \*(-?\d*)\((.*\%esi.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
 582         s/^\tjmp \*\%esi\n/\tmovl \%esi,\%eax\n\tjmp \*\%eax\n/g;
 583         die "$Pgm: (mangler) still have jump involving \%esi!\n$_"
 584             if /(jmp|call) .*\%esi/;
 585     }
 586     if ($StolenX86Regs <= 3 ) { # spurious uses of edi?
 587         s/^\tmovl (.*),\%edi\n\tjmp \*%edi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
 588         s/^\tjmp \*(-?\d*)\((.*\%edi.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
 589         s/^\tjmp \*\%edi\n/\tmovl \%edi,\%eax\n\tjmp \*\%eax\n/g;
 590         die "$Pgm: (mangler) still have jump involving \%edi!\n$_"
 591             if /(jmp|call) .*\%edi/;
 592     }
 593 #=  if ($StolenX86Regs <= 4 ) { # spurious uses of ecx?
 594 #=      s/^\tmovl (.*),\%ecx\n\tjmp \*%ecx\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
 595 #=      s/^\tjmp \*(-?\d*)\((.*\%ecx.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
 596 #=      s/^\tjmp \*\%ecx\n/\tmovl \%ecx,\%eax\n\tjmp \*\%eax\n/g;
 597 #=      die "$Pgm: (mangler) still have jump involving \%ecx!\n$_"
 598 #=          if /(jmp|call) .*\%ecx/;
 599 #=  }
 600
 601     # OK, now we can decide what our patch-up code is going to
 602     # be:
 603     if ( $StolenX86Regs <= 2
 604          && ( /32\(\%ebx\)/ || /\%esi/ || /^\tcmps/ ) ) { # R1 (esi)
 605         $entry_patch .= "\tmovl \%esi,32(\%ebx)\n";
 606         $exit_patch  .= "\tmovl 32(\%ebx),\%esi\n";
 607         # nothing for call_{entry,exit} because %esi is callee-save
 608     }
 609     if ( $StolenX86Regs <= 3
 610          && ( /64\(\%ebx\)/ || /\%edi/ || /^\t(scas|cmps)/ ) ) { # SpA (edi)
 611         $entry_patch .= "\tmovl \%edi,64(\%ebx)\n";
 612         $exit_patch  .= "\tmovl 64(\%ebx),\%edi\n";
 613         # nothing for call_{entry,exit} because %edi is callee-save
 614     }
 615 #=  if ( $StolenX86Regs <= 4
 616 #=       && ( /80\(\%ebx\)/ || /\%ecx/ || /^\t(rep|loop)/ ) ) { # Hp (ecx)
 617 #=      $entry_patch .= "\tmovl \%ecx,80(\%ebx)\n";
 618 #=      $exit_patch  .= "\tmovl 80(\%ebx),\%ecx\n";
 619 #=
 620 #=      $call_exit_patch  .= "\tmovl \%ecx,108(\%ebx)\n";
 621 #=      $call_entry_patch .= "\tmovl 108(\%ebx),\%ecx\n";
 622 #=      # I have a really bad feeling about this if we ever
 623 #=      # have a nested call...
 624 #=      # NB: should just hide it somewhere in the C stack.
 625 #=  }
 626     # --------------------------------------------------------
 627     # next, here we go with non-%esp patching!
 628     #
 629     s/^(\t[a-z])/$entry_patch$1/; # before first instruction
 630     s/^(\tcall .*\n(\taddl \$\d+,\%esp\n)?)/$call_exit_patch$1$call_entry_patch/g; # _all_ calls
 631
 632     # fix _all_ non-local jumps:
 633
 634     s/^\tjmp \*${T_PRE_LLBL_PAT}/\tJMP___SL/go;
 635     s/^\tjmp ${T_PRE_LLBL_PAT}/\tJMP___L/go;
 636
 637     s/^(\tjmp .*\n)/$exit_patch$1/g; # here's the fix...
 638
 639     s/^\tJMP___SL/\tjmp \*${T_PRE_LLBL}/go;
 640     s/^\tJMP___L/\tjmp ${T_PRE_LLBL}/go;
 641
 642     # fix post-PerformGC wrapper (re-)entries ???
 643
 644     if ($StolenX86Regs == 2 ) {
 645         die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_"
 646             if /^\t(jmp|call) .*\%e(si|di)/;
 647 #=      die "ARGH! Jump uses \%esi, \%edi, or \%ecx with -monly-2-regs:\n$_"
 648 #=          if /^\t(jmp|call) .*\%e(si|di|cx)/;
 649     } elsif ($StolenX86Regs == 3 ) {
 650         die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_"
 651             if /^\t(jmp|call) .*\%edi/;
 652 #=      die "ARGH! Jump uses \%edi or \%ecx with -monly-3-regs:\n$_"
 653 #=          if /^\t(jmp|call) .*\%e(di|cx)/;
 654 #=  } elsif ($StolenX86Regs == 4 ) {
 655 #=      die "ARGH! Jump uses \%ecx with -monly-4-regs:\n$_"
 656 #=          if /^\t(jmp|call) .*\%ecx/;
 657     }
 658
 659     # final peephole fix
 660
 661     s/^\tmovl \%eax,36\(\%ebx\)\n\tjmp \*36\(\%ebx\)\n/\tmovl \%eax,36\(\%ebx\)\n\tjmp \*\%eax\n/;
 662
 663     # --------------------------------------------------------
 664     # that's it -- print it
 665     #
 666     die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia
 667
 668     print OUTASM $_;
 669
 670     if ( $need_fallthru_patch ) { # exit patch for end of slow entry code
 671         print OUTASM $exit_patch;
 672         # ToDo: make it not print if there is a "jmp" at the end
 673     }
 674 }
 675 \end{code}
 676
 677 \begin{code}
 678 sub init_FUNNY_THINGS {
 679     %KNOWN_FUNNY_THING = (
 680         "${T_US}CheckHeapCode${T_POST_LBL}", 1,
 681         "${T_US}CommonUnderflow${T_POST_LBL}", 1,
 682         "${T_US}Continue${T_POST_LBL}", 1,
 683         "${T_US}EnterNodeCode${T_POST_LBL}", 1,
 684         "${T_US}ErrorIO_call_count${T_POST_LBL}", 1,
 685         "${T_US}ErrorIO_innards${T_POST_LBL}", 1,
 686         "${T_US}IndUpdRetDir${T_POST_LBL}", 1,
 687         "${T_US}IndUpdRetV0${T_POST_LBL}", 1,
 688         "${T_US}IndUpdRetV1${T_POST_LBL}", 1,
 689         "${T_US}IndUpdRetV2${T_POST_LBL}", 1,
 690         "${T_US}IndUpdRetV3${T_POST_LBL}", 1,
 691         "${T_US}IndUpdRetV4${T_POST_LBL}", 1,
 692         "${T_US}IndUpdRetV5${T_POST_LBL}", 1,
 693         "${T_US}IndUpdRetV6${T_POST_LBL}", 1,
 694         "${T_US}IndUpdRetV7${T_POST_LBL}", 1,
 695         "${T_US}PrimUnderflow${T_POST_LBL}", 1,
 696         "${T_US}StackUnderflowEnterNode${T_POST_LBL}", 1,
 697         "${T_US}StdErrorCode${T_POST_LBL}", 1,
 698         "${T_US}UnderflowVect0${T_POST_LBL}", 1,
 699         "${T_US}UnderflowVect1${T_POST_LBL}", 1,
 700         "${T_US}UnderflowVect2${T_POST_LBL}", 1,
 701         "${T_US}UnderflowVect3${T_POST_LBL}", 1,
 702         "${T_US}UnderflowVect4${T_POST_LBL}", 1,
 703         "${T_US}UnderflowVect5${T_POST_LBL}", 1,
 704         "${T_US}UnderflowVect6${T_POST_LBL}", 1,
 705         "${T_US}UnderflowVect7${T_POST_LBL}", 1,
 706         "${T_US}UpdErr${T_POST_LBL}", 1,
 707         "${T_US}UpdatePAP${T_POST_LBL}", 1,
 708         "${T_US}WorldStateToken${T_POST_LBL}", 1,
 709         "${T_US}_Enter_Internal${T_POST_LBL}", 1,
 710         "${T_US}_PRMarking_MarkNextAStack${T_POST_LBL}", 1,
 711         "${T_US}_PRMarking_MarkNextBStack${T_POST_LBL}", 1,
 712         "${T_US}_PRMarking_MarkNextCAF${T_POST_LBL}", 1,
 713         "${T_US}_PRMarking_MarkNextGA${T_POST_LBL}", 1,
 714         "${T_US}_PRMarking_MarkNextRoot${T_POST_LBL}", 1,
 715         "${T_US}_PRMarking_MarkNextSpark${T_POST_LBL}", 1,
 716         "${T_US}_Scavenge_Forward_Ref${T_POST_LBL}", 1,
 717         "${T_US}__std_entry_error__${T_POST_LBL}", 1,
 718         "${T_US}_startMarkWorld${T_POST_LBL}", 1,
 719         "${T_US}resumeThread${T_POST_LBL}", 1,
 720         "${T_US}startCcRegisteringWorld${T_POST_LBL}", 1,
 721         "${T_US}startEnterFloat${T_POST_LBL}", 1,
 722         "${T_US}startEnterInt${T_POST_LBL}", 1,
 723         "${T_US}startPerformIO${T_POST_LBL}", 1,
 724         "${T_US}startStgWorld${T_POST_LBL}", 1,
 725         "${T_US}stopPerformIO${T_POST_LBL}", 1
 726     );
 727 }
 728 \end{code}
 729
 730 The following table reversal is used for both info tables and return
 731 vectors.  In both cases, we remove the first entry from the table,
 732 reverse the table, put the label at the end, and paste some code
 733 (that which is normally referred to by the first entry in the table)
 734 right after the table itself.  (The code pasting is done elsewhere.)
 735
 736 \begin{code}
 737 sub rev_tbl {
 738     local($symb, $tbl, $discard1) = @_;
 739
 740     local($before) = '';
 741     local($label) = '';
 742     local(@words) = ();
 743     local($after) = '';
 744     local(@lines) = split(/\n/, $tbl);
 745     local($i, $extra, $words_to_pad, $j);
 746
 747     for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.long\s+/; $i++) {
 748         $label .= $lines[$i] . "\n",
 749             next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/
 750                  || $lines[$i] =~ /^\.globl/
 751                  || $lines[$i] =~ /^${T_US}vtbl_\S+:$/;
 752
 753         $before .= $lines[$i] . "\n"; # otherwise...
 754     }
 755
 756     for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\s+/; $i++) {
 757         push(@words, $lines[$i]);
 758     }
 759     # now throw away the first word (entry code):
 760     shift(@words) if $discard1;
 761
 762     # for 486-cache-friendliness, we want our tables aligned
 763     # on 16-byte boundaries (.align 4).  Let's pad:
 764     $extra = ($#words + 1) % 4;
 765     $words_to_pad = ($extra == 0) ? 0 : 4 - $extra;
 766     for ($j = 0; $j < $words_to_pad; $j++) { push(@words, "\t\.long 0"); }
 767
 768     for (; $i <= $#lines; $i++) {
 769         $after .= $lines[$i] . "\n";
 770     }
 771
 772     $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after;
 773
 774 #   print STDERR "before=$before\n";
 775 #   print STDERR "label=$label\n";
 776 #   print STDERR "words=",(reverse @words),"\n";
 777 #   print STDERR "after=$after\n";
 778
 779     $tbl;
 780 }
 781 \end{code}
 782
 783 \begin{code}
 784 sub mini_mangle_asm {
 785     local($in_asmf, $out_asmf) = @_;
 786
 787     &init_TARGET_STUFF();
 788
 789     open(INASM, "< $in_asmf")
 790         || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
 791     open(OUTASM,"> $out_asmf")
 792         || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
 793
 794     while (<INASM>) {
 795         print OUTASM;
 796
 797         next unless
 798             /^${T_US}(PerformGC|StackOverflow|Yield|PerformReschedule)_wrapper${T_POST_LBL}\n/o;
 799         print OUTASM "\tmovl \%esp, ${T_US}__temp_esp\n";
 800         print OUTASM "\tmovl \%eax, ${T_US}__temp_eax\n";
 801     }
 802
 803     # finished:
 804     close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
 805     close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
 806 }
 807
 808 # make "require"r happy...
 809 1;
 810 \end{code}