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