4a4834cea4949ad41beac830c1e1ed80dd5b2f37
[ghc.git] / 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}