ghc/driver/mangler/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 General note [chak]: Many regexps are very fragile because they rely on white
  17 space being in the right place.  This caused trouble with gcc 2.95 (at least
  18 on Linux), where the use of white space in .s files generated by gcc suddenly
  19 changed.  To guarantee compatibility across different versions of gcc, make
  20 sure (at least on i386-.*-linux) that regexps tolerate varying amounts of white
  21 space between an assembler statement and its arguments as well as after a the
  22 comma separating multiple arguments.
  23
  24 \emph{For the time being, I have corrected the regexps for i386-.*-linux.  I
  25 didn't touch all the regexps for other i386 platforms, as I don't have
  26 a box to test these changes.}
  27
  28 HPPA specific notes:
  29 \begin{itemize}
  30 \item
  31 The HP linker is very picky about symbols being in the appropriate
  32 space (code vs. data).  When we mangle the threaded code to put the
  33 info tables just prior to the code, they wind up in code space
  34 rather than data space.  This means that references to *_info from
  35 un-mangled parts of the RTS (e.g. unthreaded GC code) get
  36 unresolved symbols.  Solution:  mini-mangler for .c files on HP.  I
  37 think this should really be triggered in the driver by a new -rts
  38 option, so that user code doesn't get mangled inappropriately.
  39 \item
  40 With reversed tables, jumps are to the _info label rather than to
  41 the _entry label.  The _info label is just an address in code
  42 space, rather than an entry point with the descriptive blob we
  43 talked about yesterday.  As a result, you can't use the call-style
  44 JMP_ macro.  However, some JMP_ macros take _info labels as targets
  45 and some take code entry points within the RTS.  The latter won't
  46 work with the goto-style JMP_ macro.  Sigh.  Solution: Use the goto
  47 style JMP_ macro, and mangle some more assembly, changing all
  48 "RP'literal" and "LP'literal" references to "R'literal" and
  49 "L'literal," so that you get the real address of the code, rather
  50 than the descriptive blob.  Also change all ".word P%literal"
  51 entries in info tables and vector tables to just ".word literal,"
  52 for the same reason.  Advantage: No more ridiculous call sequences.
  53 \end{itemize}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection{Top-level code}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 $TargetPlatform = $TARGETPLATFORM;
  63
  64 ($Pgm = $0) =~ s|.*/||;
  65 $ifile = $ARGV[0];
  66 $ofile = $ARGV[1];
  67
  68 if ( $TargetPlatform =~ /^i386-/ ) {
  69     if ($ARGV[2] eq '') {
  70         $StolenX86Regs = 4;
  71     } else {
  72         $StolenX86Regs = $ARGV[2];
  73     }
  74 }
  75
  76 &mangle_asm($ifile,$ofile);
  77
  78 exit(0);
  79 \end{code}
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{Constants for various architectures}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 sub init_TARGET_STUFF {
  89
  90     #--------------------------------------------------------#
  91     if ( $TargetPlatform =~ /^alpha-.*-.*/ ) {
  92
  93     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
  94     $T_US           = ''; # _ if symbols have an underscore on the front
  95     $T_PRE_APP      = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP
  96     $T_CONST_LBL    = '^\$L?C(\d+):$'; # regexp for what such a lbl looks like
  97     $T_POST_LBL     = ':';
  98
  99     $T_MOVE_DIRVS   = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)';
 100     $T_COPY_DIRVS   = '^\s*(\#|\.(file|globl|ent|loc))';
 101
 102     $T_hsc_cc_PAT   = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
 103     $T_DOT_WORD     = '\.(long|quad|byte|word)';
 104     $T_DOT_GLOBAL   = '^\t\.globl';
 105     $T_HDR_literal  = "\.rdata\n\t\.align 3\n";
 106     $T_HDR_misc     = "\.text\n\t\.align 3\n";
 107     $T_HDR_data     = "\.data\n\t\.align 3\n";
 108     $T_HDR_consist  = "\.text\n";
 109     $T_HDR_closure  = "\.data\n\t\.align 3\n";
 110     $T_HDR_srt      = "\.text\n\t\.align 3\n";
 111     $T_HDR_info     = "\.text\n\t\.align 3\n";
 112     $T_HDR_entry    = "\.text\n\t\.align 3\n";
 113     $T_HDR_fast     = "\.text\n\t\.align 3\n";
 114     $T_HDR_vector   = "\.text\n\t\.align 3\n";
 115     $T_HDR_direct   = "\.text\n\t\.align 3\n";
 116     $T_create_word  = "\t.quad";
 117
 118     #--------------------------------------------------------#
 119     } elsif ( $TargetPlatform =~ /^hppa/ ) {
 120
 121     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
 122     $T_US           = ''; # _ if symbols have an underscore on the front
 123     $T_PRE_APP      = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP
 124     $T_CONST_LBL    = '^L\$C(\d+)$'; # regexp for what such a lbl looks like
 125     $T_POST_LBL     = '';
 126
 127     $T_MOVE_DIRVS   = '^((\s+\.(IMPORT|EXPORT|PARAM).*|\s+\.align\s+\d+|\s+\.(SPACE|SUBSPA)\s+\S+|\s*)\n)';
 128     $T_COPY_DIRVS   = '^\s+\.(IMPORT|EXPORT)';
 129
 130     $T_hsc_cc_PAT   = '\.STRING.*\)(hsc|cc) (.*)\\\\x09(.*)\\\\x00"';
 131     $T_DOT_WORD     = '\.(blockz|word|half|byte)';
 132     $T_DOT_GLOBAL   = '^\s+\.EXPORT';
 133     $T_HDR_literal  = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n";
 134     $T_HDR_misc     = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
 135     $T_HDR_data     = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
 136     $T_HDR_consist  = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n";
 137     $T_HDR_closure  = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
 138     $T_HDR_srt      = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
 139     $T_HDR_info     = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
 140     $T_HDR_entry    = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
 141     $T_HDR_fast     = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
 142     $T_HDR_vector   = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
 143     $T_HDR_direct   = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
 144     $T_create_word  = "\t.word";
 145
 146     #--------------------------------------------------------#
 147     } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|openbsd|nextstep3|cygwin32|mingw32)$/ ) {
 148                                 # NeXT added but not tested. CaS
 149
 150     $T_STABBY       = 1; # 1 iff .stab things (usually if a.out format)
 151     $T_US           = '_'; # _ if symbols have an underscore on the front
 152     $T_PRE_APP      = '^#'; # regexp that says what comes before APP/NO_APP
 153     $T_CONST_LBL    = '^LC(\d+):$';
 154     $T_POST_LBL     = ':';
 155     $T_X86_PRE_LLBL_PAT = 'L';
 156     $T_X86_PRE_LLBL         = 'L';
 157     $T_X86_BADJMP   = '^\tjmp [^L\*]';
 158
 159     $T_MOVE_DIRVS   = '^(\s*(\.(p2)?align\s+\d+(,0x90)?|\.globl\s+\S+|\.text|\.data|\.stab[^n].*|\.type\s+.*|\.size\s+.*)\n)';
 160     $T_COPY_DIRVS   = '\.(globl|stab)';
 161     $T_hsc_cc_PAT   = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
 162     $T_DOT_WORD     = '\.(long|word|value|byte|space)';
 163     $T_DOT_GLOBAL   = '\.globl';
 164     $T_HDR_literal  = "\.text\n\t\.align 2\n";
 165     $T_HDR_misc     = "\.text\n\t\.align 2,0x90\n";
 166     $T_HDR_data     = "\.data\n\t\.align 2\n";
 167     $T_HDR_consist  = "\.text\n";
 168     $T_HDR_closure  = "\.data\n\t\.align 2\n";
 169     $T_HDR_closure  = "\.data\n\t\.align 2\n\t.long 0\n" if ( $TargetPlatform =~ /.*-mingw32$/ );
 170     $T_HDR_srt      = "\.text\n\t\.align 2\n";
 171     $T_HDR_info     = "\.text\n\t\.align 2\n"; # NB: requires padding
 172     $T_HDR_entry    = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
 173     $T_HDR_fast     = "\.text\n\t\.align 2,0x90\n";
 174     $T_HDR_vector   = "\.text\n\t\.align 2\n"; # NB: requires padding
 175     $T_HDR_direct   = "\.text\n\t\.align 2,0x90\n";
 176     $T_create_word  = "\t.word";
 177
 178     #--------------------------------------------------------#
 179     } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|freebsd|netbsd)$/ ) {
 180
 181     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
 182     $T_US           = ''; # _ if symbols have an underscore on the front
 183     $T_PRE_APP      = # regexp that says what comes before APP/NO_APP
 184                       ($TargetPlatform =~ /-(linux|freebsd|netbsd)$/) ? '#' : '/' ;
 185     $T_CONST_LBL    = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
 186     $T_POST_LBL     = ':';
 187     $T_X86_PRE_LLBL_PAT = '\.L';
 188     $T_X86_PRE_LLBL         = '.L';
 189     $T_X86_BADJMP   = '^\tjmp\s+[^\.\*]';
 190
 191     $T_MOVE_DIRVS   = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.Lfe.*\n\s*\.size\s+.*|\.size\s+.*|\.ident.*)\n)';
 192     $T_COPY_DIRVS   = '\.(globl)';
 193
 194     if ( $TargetPlatform =~ /freebsd|netbsd/ ) {
 195         $T_hsc_cc_PAT   = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
 196     } else {
 197         $T_hsc_cc_PAT   = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
 198     }
 199
 200     $T_DOT_WORD     = '\.(long|value|byte|zero)';
 201     $T_DOT_GLOBAL   = '\.globl';
 202     $T_HDR_literal  = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11)
 203     $T_HDR_misc     = "\.text\n\t\.align 4\n";
 204     $T_HDR_data     = "\.data\n\t\.align 4\n"; # ToDo: change align??
 205     $T_HDR_consist  = "\.text\n";
 206     $T_HDR_closure  = "\.data\n\t\.align 4\n"; # ToDo: change align?
 207     $T_HDR_srt      = "\.text\n\t\.align 4\n"; # ToDo: change align?
 208     $T_HDR_info     = "\.text\n\t\.align 4\n"; # NB: requires padding
 209     $T_HDR_entry    = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
 210     $T_HDR_fast     = "\.text\n\t\.align 4\n";
 211     $T_HDR_vector   = "\.text\n\t\.align 4\n"; # NB: requires padding
 212     $T_HDR_direct   = "\.text\n\t\.align 4\n";
 213     $T_create_word  = "\t.word";
 214
 215     #--------------------------------------------------------#
 216     } elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/ ) {
 217
 218     $T_STABBY       = 1; # 1 iff .stab things (usually if a.out format)
 219     $T_US           = '_'; # _ if symbols have an underscore on the front
 220     $T_PRE_APP      = '^# MAY NOT APPLY'; # regexp that says what comes before APP/NO_APP
 221     $T_CONST_LBL    = '^LC(\d+):$';
 222     $T_POST_LBL     = ':';
 223
 224     $T_MOVE_DIRVS   = '^(\s*(\.align\s+\d+|\.proc\s+\d+|\.const|\.cstring|\.globl\s+\S+|\.text|\.data|\.even|\.stab[^n].*)\n)';
 225     $T_COPY_DIRVS   = '\.(globl|proc|stab)';
 226     $T_hsc_cc_PAT   = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
 227
 228     $T_DOT_WORD     = '\.long';
 229     $T_DOT_GLOBAL   = '\.globl';
 230     $T_HDR_literal  = "\.text\n\t\.even\n";
 231     $T_HDR_misc     = "\.text\n\t\.even\n";
 232     $T_HDR_data     = "\.data\n\t\.even\n";
 233     $T_HDR_consist  = "\.text\n";
 234     $T_HDR_closure  = "\.data\n\t\.even\n";
 235     $T_HDR_srt      = "\.text\n\t\.even\n";
 236     $T_HDR_info     = "\.text\n\t\.even\n";
 237     $T_HDR_entry    = "\.text\n\t\.even\n";
 238     $T_HDR_fast     = "\.text\n\t\.even\n";
 239     $T_HDR_vector   = "\.text\n\t\.even\n";
 240     $T_HDR_direct   = "\.text\n\t\.even\n";
 241     $T_create_word  = "\t.long";
 242
 243     #--------------------------------------------------------#
 244     } elsif ( $TargetPlatform =~ /^mips-.*/ ) {
 245
 246     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
 247     $T_US           = ''; # _ if symbols have an underscore on the front
 248     $T_PRE_APP      = '^\s*#'; # regexp that says what comes before APP/NO_APP
 249     $T_CONST_LBL    = '^\$LC(\d+):$'; # regexp for what such a lbl looks like
 250     $T_POST_LBL     = ':';
 251
 252     $T_MOVE_DIRVS   = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\.text|\.r?data)\n)';
 253     $T_COPY_DIRVS   = '\.(globl|ent)';
 254
 255     $T_hsc_cc_PAT   = 'I WAS TOO LAZY TO DO THIS BIT (WDP 95/05)';
 256     $T_DOT_WORD     = '\.word';
 257     $T_DOT_GLOBAL   = '^\t\.globl';
 258     $T_HDR_literal  = "\t\.rdata\n\t\.align 2\n";
 259     $T_HDR_misc     = "\t\.text\n\t\.align 2\n";
 260     $T_HDR_data     = "\t\.data\n\t\.align 2\n";
 261     $T_HDR_consist  = 'TOO LAZY TO DO THIS TOO';
 262     $T_HDR_closure  = "\t\.data\n\t\.align 2\n";
 263     $T_HDR_srt      = "\t\.text\n\t\.align 2\n";
 264     $T_HDR_info     = "\t\.text\n\t\.align 2\n";
 265     $T_HDR_entry    = "\t\.text\n\t\.align 2\n";
 266     $T_HDR_fast     = "\t\.text\n\t\.align 2\n";
 267     $T_HDR_vector   = "\t\.text\n\t\.align 2\n";
 268     $T_HDR_direct   = "\t\.text\n\t\.align 2\n";
 269     $T_create_word  = "\t.word";
 270
 271     #--------------------------------------------------------#
 272     } elsif ( $TargetPlatform =~ /^powerpc-apple-.*/ ) {
 273                                 # Apple PowerPC Darwin/MacOS X.
 274     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
 275     $T_US           = '_'; # _ if symbols have an underscore on the front
 276     $T_PRE_APP      = 'WHAT IS THIS'; # regexp that says what comes before APP/NO_APP
 277     $T_CONST_LBL    = '^\LC\d+:'; # regexp for what such a lbl looks like
 278     $T_POST_LBL     = ':';
 279
 280     $T_MOVE_DIRVS   = '^(\s*(\.align \d+|\.text|\.data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+)\n)';
 281     $T_COPY_DIRVS   = '\.(globl)';
 282
 283     $T_hsc_cc_PAT   = '\.byte.*\)(hsc|cc) (.*)"\n\t\.byte \d+\n\t\.byte "(.*)"\n\t\.byte \d+';
 284     $T_DOT_WORD     = '\.(long|short|byte)';
 285     $T_DOT_GLOBAL   = '\.globl';
 286     $T_HDR_toc      = "\.toc\n";
 287     $T_HDR_literal  = "\t\.const_data\n\t\.align 2\n";
 288     $T_HDR_misc     = "\t\.text\n\t\.align 2\n";
 289     $T_HDR_data     = "\t\.data\n\t\.align 2\n";
 290     $T_HDR_consist  = "\t\.text\n\t\.align 2\n";
 291     $T_HDR_closure  = "\t\.const_data\n\t\.align 2\n";
 292     $T_HDR_srt      = "\t\.text\n\t\.align 2\n";
 293     $T_HDR_info     = "\t\.text\n\t\.align 2\n";
 294     $T_HDR_entry    = "\t\.text\n\t\.align 2\n";
 295     $T_HDR_fast     = "\t\.text\n\t\.align 2\n";
 296     $T_HDR_vector   = "\t\.text\n\t\.align 2\n";
 297     $T_HDR_direct   = "\t\.text\n\t\.align 2\n";
 298     $T_create_word  = "\t.long";
 299
 300     #--------------------------------------------------------#
 301     } elsif ( $TargetPlatform =~ /^sparc-.*-solaris2/ ) {
 302
 303     $T_STABBY       = 0; # 1 iff .stab things (usually if a.out format)
 304     $T_US           = ''; # _ if symbols have an underscore on the front
 305     $T_PRE_APP      = 'DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP
 306     $T_CONST_LBL    = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like
 307     $T_POST_LBL     = ':';
 308
 309     $T_MOVE_DIRVS   = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*|\.section.*|\s+\.type.*|\s+\.size.*)\n)';
 310     $T_COPY_DIRVS   = '\.(global|proc|stab)';
 311
 312     $T_hsc_cc_PAT   = '\.asciz.*\)(hsc|cc) (.*)\\\\t(.*)"';
 313     $T_DOT_WORD     = '\.(word|byte|half|skip|uahalf|uaword)';
 314     $T_DOT_GLOBAL   = '^\t\.global';
 315     $T_HDR_literal  = "\.text\n\t\.align 8\n";
 316     $T_HDR_misc     = "\.text\n\t\.align 4\n";
 317     $T_HDR_data     = "\.data\n\t\.align 8\n";
 318     $T_HDR_consist  = "\.text\n";
 319     $T_HDR_closure  = "\.data\n\t\.align 4\n";
 320     $T_HDR_srt      = "\.data\n\t\.align 4\n";
 321     $T_HDR_info     = "\.text\n\t\.align 4\n";
 322     $T_HDR_entry    = "\.text\n\t\.align 4\n";
 323     $T_HDR_fast     = "\.text\n\t\.align 4\n";
 324     $T_HDR_vector   = "\.text\n\t\.align 4\n";
 325     $T_HDR_direct   = "\.text\n\t\.align 4\n";
 326     $T_create_word  = "\t.word";
 327
 328     #--------------------------------------------------------#
 329     } elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/ ) {
 330
 331     $T_STABBY       = 1; # 1 iff .stab things (usually if a.out format)
 332     $T_US           = '_'; # _ if symbols have an underscore on the front
 333     $T_PRE_APP      = '^# DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP
 334     $T_CONST_LBL    = '^LC(\d+):$';
 335     $T_POST_LBL     = ':';
 336
 337     $T_MOVE_DIRVS   = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*)\n)';
 338     $T_COPY_DIRVS   = '\.(global|proc|stab)';
 339     $T_hsc_cc_PAT   = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
 340
 341     $T_DOT_WORD     = '\.word';
 342     $T_DOT_GLOBAL   = '^\t\.global';
 343     $T_HDR_literal  = "\.text\n\t\.align 8\n";
 344     $T_HDR_misc     = "\.text\n\t\.align 4\n";
 345     $T_HDR_data     = "\.data\n\t\.align 8\n";
 346     $T_HDR_consist  = "\.text\n";
 347     $T_HDR_closure  = "\.data\n\t\.align 4\n";
 348     $T_HDR_srt      = "\.data\n\t\.align 4\n";
 349     $T_HDR_info     = "\.text\n\t\.align 4\n";
 350     $T_HDR_entry    = "\.text\n\t\.align 4\n";
 351     $T_HDR_fast     = "\.text\n\t\.align 4\n";
 352     $T_HDR_vector   = "\.text\n\t\.align 4\n";
 353     $T_HDR_direct   = "\.text\n\t\.align 4\n";
 354     $T_create_word  = "\t.word";
 355
 356     #--------------------------------------------------------#
 357     } else {
 358         print STDERR "$Pgm: don't know how to mangle assembly language for: $TargetPlatform\n";
 359         exit 1;
 360     }
 361
 362 if ( 0 ) {
 363 print STDERR "T_STABBY: $T_STABBY\n";
 364 print STDERR "T_US: $T_US\n";
 365 print STDERR "T_PRE_APP: $T_PRE_APP\n";
 366 print STDERR "T_CONST_LBL: $T_CONST_LBL\n";
 367 print STDERR "T_POST_LBL: $T_POST_LBL\n";
 368 if ( $TargetPlatform =~ /^i386-/ ) {
 369     print STDERR "T_X86_PRE_LLBL_PAT: $T_X86_PRE_LLBL_PAT\n";
 370     print STDERR "T_X86_PRE_LLBL: $T_X86_PRE_LLBL\n";
 371     print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n";
 372 }
 373 print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n";
 374 print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n";
 375 print STDERR "T_hsc_cc_PAT: $T_hsc_cc_PAT\n";
 376 print STDERR "T_DOT_WORD: $T_DOT_WORD\n";
 377 print STDERR "T_HDR_literal: $T_HDR_literal\n";
 378 print STDERR "T_HDR_misc: $T_HDR_misc\n";
 379 print STDERR "T_HDR_data: $T_HDR_data\n";
 380 print STDERR "T_HDR_consist: $T_HDR_consist\n";
 381 print STDERR "T_HDR_closure: $T_HDR_closure\n";
 382 print STDERR "T_HDR_info: $T_HDR_info\n";
 383 print STDERR "T_HDR_entry: $T_HDR_entry\n";
 384 print STDERR "T_HDR_fast: $T_HDR_fast\n";
 385 print STDERR "T_HDR_vector: $T_HDR_vector\n";
 386 print STDERR "T_HDR_direct: $T_HDR_direct\n";
 387 }
 388
 389 }
 390 \end{code}
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection{Mangle away}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 \begin{code}
 399 sub mangle_asm {
 400     local($in_asmf, $out_asmf) = @_;
 401
 402     # multi-line regexp matching:
 403     local($*) = 1;
 404     local($i, $c);
 405
 406
 407     &init_TARGET_STUFF();
 408     &init_FUNNY_THINGS();
 409
 410     open(INASM, "< $in_asmf")
 411         || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
 412     open(OUTASM,"> $out_asmf")
 413         || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
 414
 415     # read whole file, divide into "chunks":
 416     #   record some info about what we've found...
 417
 418     @chk = ();          # contents of the chunk
 419     $numchks = 0;       # number of them
 420     @chkcat = ();       # what category of thing in each chunk
 421     @chksymb = ();      # what symbol(base) is defined in this chunk
 422     %slowchk = ();      # ditto, its regular "slow" entry code
 423     %fastchk = ();      # ditto, fast entry code
 424     %closurechk = ();   # ditto, the (static) closure
 425     %srtchk = ();       # ditto, its SRT (for top-level things)
 426     %infochk = ();      # given a symbol base, say what chunk its info tbl is in
 427     %vectorchk = ();    # ditto, return vector table
 428     $EXTERN_DECLS = ''; # .globl <foo> .text (MIPS only)
 429
 430     $i = 0; $chkcat[0] = 'misc'; $chk[0] = '';
 431
 432     while (<INASM>) {
 433         tr/\r//d if $TargetPlatform =~ /-mingw32$/; # In case Perl doesn't convert line endings
 434         next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o;
 435         next if $T_STABBY && /^\.stab.*ghc.*c_ID/;
 436         next if /^\t\.def.*endef$/;
 437         next if /${T_PRE_APP}(NO_)?APP/o;
 438         next if /^;/ && $TargetPlatform =~ /^hppa/;
 439
 440         next if /(^$|^\t\.file\t|^ # )/ && $TargetPlatform =~ /^(mips)-/;
 441
 442         if ( $TargetPlatform =~ /^mips-/
 443           && /^\t\.(globl\S+\.text|comm\t)/ ) {
 444             $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/;
 445
 446         # As a temporary solution for compiling "foreign export" declarations,
 447         # we use global variables to pass arguments from C to STG land.
 448         # These declarations live in the .hc file and not in the generated C
 449         # stub file, so we let them pass through here.
 450         } elsif ( /^\t\.comm\t__fexp_.*$/ ) {
 451             $chk[++$i]   = $_;
 452             $chkcat[$i]  = 'data';
 453             $chksymb[$i] = '';
 454
 455         } elsif ( /^\s+/ ) { # most common case first -- a simple line!
 456             # duplicated from the bottom
 457
 458             $chk[$i] .= $_;
 459
 460         } elsif ( /\.\.ng:$/ && $TargetPlatform =~ /^alpha-/ ) {
 461             # Alphas: Local labels not to be confused with new chunks
 462             $chk[$i] .= $_;
 463
 464         # NB: all the rest start with a non-space
 465
 466         } elsif ( $TargetPlatform =~ /^mips-/
 467                && /^\d+:/ ) { # a funny-looking very-local label
 468             $chk[$i] .= $_;
 469
 470         } elsif ( /$T_CONST_LBL/o ) {
 471             $chk[++$i]   = $_;
 472             $chkcat[$i]  = 'literal';
 473             $chksymb[$i] = $1;
 474
 475         } elsif ( /^${T_US}__stg_split_marker(\d*)${T_POST_LBL}$/o ) {
 476             $chk[++$i]   = $_;
 477             $chkcat[$i]  = 'splitmarker';
 478             $chksymb[$i] = $1;
 479
 480         } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/o ) {
 481             $symb = $1;
 482             $chk[++$i]   = $_;
 483             $chkcat[$i]  = 'infotbl';
 484             $chksymb[$i] = $symb;
 485
 486             die "Info table already? $symb; $i\n" if defined($infochk{$symb});
 487
 488             $infochk{$symb} = $i;
 489
 490         } elsif ( /^${T_US}([A-Za-z0-9_]+)_(entry|ret)${T_POST_LBL}$/o ) {
 491             $chk[++$i]   = $_;
 492             $chkcat[$i]  = 'slow';
 493             $chksymb[$i] = $1;
 494
 495             $slowchk{$1} = $i;
 496
 497         } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d*${T_POST_LBL}$/o ) {
 498             $chk[++$i]   = $_;
 499             $chkcat[$i]  = 'fast';
 500             $chksymb[$i] = $1;
 501
 502             $fastchk{$1} = $i;
 503
 504         } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) {
 505             $chk[++$i]   = $_;
 506             $chkcat[$i]  = 'closure';
 507             $chksymb[$i] = $1;
 508
 509             $closurechk{$1} = $i;
 510
 511         } elsif ( /^${T_US}([A-Za-z0-9_]+)_srt${T_POST_LBL}$/o ) {
 512             $chk[++$i]   = $_;
 513             $chkcat[$i]  = 'srt';
 514             $chksymb[$i] = $1;
 515
 516             $srtchk{$1} = $i;
 517
 518         } elsif ( /^${T_US}([A-Za-z0-9_]+)_ct${T_POST_LBL}$/o ) {
 519             $chk[++$i]   = $_;
 520             $chkcat[$i]  = 'data';
 521             $chksymb[$i] = '';
 522
 523         } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) {
 524             $chk[++$i]  = $_;
 525             $chkcat[$i] = 'consist';
 526
 527         } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
 528             ; # toss it
 529
 530         } elsif ( /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/o
 531                || /^${T_US}.*_CAT${T_POST_LBL}$/o               # PROF: _entryname_CAT
 532                || /^${T_US}.*_done${T_POST_LBL}$/o              # PROF: _module_done
 533                || /^${T_US}_module_registered${T_POST_LBL}$/o   # PROF: _module_registered
 534                ) {
 535             $chk[++$i]   = $_;
 536             $chkcat[$i]  = 'data';
 537             $chksymb[$i] = '';
 538
 539         } elsif ( /^([A-Za-z0-9_]+)\s+\.comm/ && $TargetPlatform =~ /^hppa/ ) {
 540             $chk[++$i]   = $_;
 541             $chkcat[$i]  = 'bss';
 542             $chksymb[$i] = '';
 543
 544         } elsif ( /^${T_US}([A-Za-z0-9_]+)_cc(s)?${T_POST_LBL}$/o ) {
 545             # all CC_ symbols go in the data section...
 546             $chk[++$i]   = $_;
 547             $chkcat[$i]  = 'data';
 548             $chksymb[$i] = '';
 549
 550         } elsif ( /^${T_US}([A-Za-z0-9_]+)_(alt|dflt)${T_POST_LBL}$/o ) {
 551             $chk[++$i]   = $_;
 552             $chkcat[$i]  = 'misc';
 553             $chksymb[$i] = '';
 554         } elsif ( /^${T_US}([A-Za-z0-9_]+)_vtbl${T_POST_LBL}$/o ) {
 555             $chk[++$i]   = $_;
 556             $chkcat[$i]  = 'vector';
 557             $chksymb[$i] = $1;
 558
 559             $vectorchk{$1} = $i;
 560
 561         # As a temporary solution for compiling "foreign export" declarations,
 562         # we use global variables to pass arguments from C to STG land.
 563         # These declarations live in the .hc file and not in the generated C
 564         # stub file, so we let them pass through here.
 565         } elsif ( /^[\t ]+\.comm[\t ]+__fexp_.*$/ ) {
 566             $chk[++$i]   = $_;
 567             $chkcat[$i]  = 'data';
 568             $chksymb[$i] = '';
 569
 570         } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/
 571              &&   /^[A-Za-z0-9][A-Za-z0-9_]*:/ ) {
 572             # Some Solaris system headers contain function definitions (as
 573             # opposed to mere prototypes), which end up in the .hc file when
 574             # a Haskell module foreign imports the corresponding system
 575             # functions (most notably stat()).  We put them into the text
 576             # segment.  Note that this currently does not extend to function
 577             # names starting with an underscore.
 578             # - chak 7/2001
 579             $chk[++$i]   = $_;
 580             $chkcat[$i]  = 'misc';
 581             $chksymb[$i] = $1;
 582
 583         } elsif ( /^${T_US}[A-Za-z0-9_]/o
 584                 && ( $TargetPlatform !~ /^hppa/ # need to avoid local labels in this case
 585                    || ! /^L\$\d+$/ ) ) {
 586             local($thing);
 587             chop($thing = $_);
 588             print STDERR "Funny global thing?: $_"
 589                 unless # $KNOWN_FUNNY_THING{$thing}
 590                        /^${T_US}stg_.*${T_POST_LBL}$/o          # RTS internals
 591                     || /^${T_US}__stg_.*${T_POST_LBL}$/o        # more RTS internals
 592                     || /^${T_US}__fexp_.*${T_POST_LBL}$/o       # foreign export
 593                     || /^${T_US}__stginit.*${T_POST_LBL}$/o     # __stginit<module>
 594                     || /^${T_US}.*_btm${T_POST_LBL}$/o          # large bitmaps
 595                     || /^${T_US}.*_closure_tbl${T_POST_LBL}$/o  # closure tables
 596                     || /^_uname:/o;                             # x86/Solaris2
 597             $chk[++$i]   = $_;
 598             $chkcat[$i]  = 'misc';
 599             $chksymb[$i] = '';
 600
 601         } else { # simple line (duplicated at the top)
 602
 603             $chk[$i] .= $_;
 604         }
 605     }
 606     $numchks = $#chk + 1;
 607
 608     open CHUNKS, ">/tmp/chunks1" or die "Cannot open /tmp/chunks1: $!\n";
 609     for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] }
 610     close CHUNKS;
 611
 612         # ########
 613
 614     # the division into chunks is imperfect;
 615     # we throw some things over the fence into the next
 616     # chunk.
 617     #
 618     # also, there are things we would like to know
 619     # about the whole module before we start spitting
 620     # output.
 621
 622     local($FIRST_MANGLABLE) = ($TargetPlatform =~ /^(alpha-|hppa|mips-)/) ? 1 : 0;
 623     local($FIRST_TOSSABLE ) = ($TargetPlatform =~ /^(hppa|mips-)/) ? 1 : 0;
 624
 625 #   print STDERR "first chunk to mangle: $FIRST_MANGLABLE\n";
 626
 627     # Alphas: NB: we start meddling at chunk 1, not chunk 0
 628     # The first ".rdata" is quite magical; as of GCC 2.7.x, it
 629     # spits a ".quad 0" in after the very first ".rdata"; we
 630     # detect this special case (tossing the ".quad 0")!
 631     local($magic_rdata_seen) = 0;
 632
 633     # HPPAs, MIPSen: also start medding at chunk 1
 634
 635     for ($i = $FIRST_TOSSABLE; $i < $numchks; $i++) {
 636         $c = $chk[$i]; # convenience copy
 637
 638 #       print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c;
 639
 640         # toss all prologue stuff; HPPA is pretty weird
 641         # (see elsewhere)
 642         $c = &mash_hppa_prologue($c) if $TargetPlatform =~ /^hppa/;
 643
 644         # be slightly paranoid to make sure there's
 645         # nothing surprising in there
 646         if ( $c =~ /--- BEGIN ---/ ) {
 647             if (($p, $r) = split(/--- BEGIN ---/, $c)) {
 648
 649                 if ($TargetPlatform =~ /^i386-/) {
 650                     $p =~ s/^\tpushl\s+\%edi\n//;
 651                     $p =~ s/^\tpushl\s+\%esi\n//;
 652                     $p =~ s/^\tpushl\s+\%ebx\n//;
 653                     $p =~ s/^\tsubl\s+\$\d+,\s*\%esp\n//;
 654                     $p =~ s/^\tmovl\s+\$\d+,\s*\%eax\n\tcall\s+__alloca\n// if ($TargetPlatform =~ /^.*-cygwin32/);
 655                 } elsif ($TargetPlatform =~ /^m68k-/) {
 656                     $p =~ s/^\tlink a6,#-?\d.*\n//;
 657                     $p =~ s/^\tpea a6@\n\tmovel sp,a6\n//;
 658                                 # The above showed up in the asm code,
 659                                 # so I added it here.
 660                                 # I hope it's correct.
 661                                 # CaS
 662                     $p =~ s/^\tmovel d2,sp\@-\n//;
 663                     $p =~ s/^\tmovel d5,sp\@-\n//; # SMmark.* only?
 664                     $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//; # SMmark.* only?
 665                 } elsif ($TargetPlatform =~ /^mips-/) {
 666                     # the .frame/.mask/.fmask that we use is the same
 667                     # as that produced by GCC for miniInterpret; this
 668                     # gives GDB some chance of figuring out what happened
 669                     $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n";
 670                     $p =~ s/^\t\.(frame).*\n/__FRAME__/g;
 671                     $p =~ s/^\t\.(mask|fmask).*\n//g;
 672                     $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/; # 16 + 100 4-byte args
 673                     $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//;
 674                     $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//;
 675                     $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//;
 676                     $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//;
 677                     $p =~ s/__FRAME__/$FRAME/;
 678                 } elsif ($TargetPlatform =~ /^powerpc-apple-.*/) {
 679                     $p =~ s/^\tmflr r0\n//;
 680                     $p =~ s/^\tbl saveFP # f\d+\n//;
 681                     $p =~ s/^\tstmw r\d+,-\d+\(r1\)\n//;
 682                     $p =~ s/^\tstfd f\d+,-\d+\(r1\)\n//g;
 683                     $p =~ s/^\tstw r0,\d+\(r1\)\n//g;
 684                     $p =~ s/^\tstwu r1,-\d+\(r1\)\n//;
 685                     $p =~ s/^\tstw r\d+,-\d+\(r1\)\n//g;
 686                 } else {
 687                     print STDERR "$Pgm: unknown prologue mangling? $TargetPlatform\n";
 688                 }
 689
 690                 if ($TargetPlatform =~ /^powerpc-apple-.*/) {
 691                         # on PowerPC, we have to keep a part of the prologue
 692                         # (which loads the current instruction pointer into register r31)
 693                     $u_p = $p;  # $u_p is for unexpected prologue
 694                     $u_p =~ s/^\tbcl 20,31,L\d+\$pb\n//;
 695                     $u_p =~ s/^L\d+\$pb:\n//;
 696                     $u_p =~ s/^\tmflr r31\n//;
 697                     die "Prologue junk?: $u_p\n" if $u_p =~ /^\t[^\.]/
 698                 } else {
 699                     # HWL HACK: dont die, just print a warning
 700                     #print stderr  "HWL: this should die! Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
 701                     die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
 702                 }
 703                 # glue together what's left
 704                 $c = $p . $r;
 705                 $c =~ s/\n\t\n/\n/; # junk blank line
 706             }
 707         }
 708
 709         if ( $TargetPlatform =~ /^mips-/ ) {
 710             # MIPS: first, this basic sequence may occur "--- END ---" or not
 711             $c =~ s/^\tlw\t\$31,\d+\(\$sp\)\n\taddu\t\$sp,\$sp,\d+\n\tj\t\$31\n\t\.end/\t\.end/;
 712         }
 713
 714         # toss all epilogue stuff; again, paranoidly
 715         if ( $c =~ /--- END ---/ ) {
 716             if (($r, $e) = split(/--- END ---/, $c)) {
 717                 if ($TargetPlatform =~ /^i386-/) {
 718                     $e =~ s/^\tret\n//;
 719                     $e =~ s/^\tpopl\s+\%edi\n//;
 720                     $e =~ s/^\tpopl\s+\%esi\n//;
 721                     $e =~ s/^\tpopl\s+\%edx\n//;
 722                     $e =~ s/^\tpopl\s+\%ecx\n//;
 723                     $e =~ s/^\taddl\s+\$\d+,\s*\%esp\n//;
 724                     $e =~ s/^\tsubl\s+\$-\d+,\s*\%esp\n//;
 725                 } elsif ($TargetPlatform =~ /^m68k-/) {
 726                     $e =~ s/^\tunlk a6\n//;
 727                     $e =~ s/^\trts\n//;
 728                 } elsif ($TargetPlatform =~ /^mips-/) {
 729                     $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//;
 730                     $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//;
 731                     $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//;
 732                     $e =~ s/^\tj\t\$31\n//;
 733                 } elsif ($TargetPlatform =~ /^powerpc-apple-.*/) {
 734                     $e =~ s/^\taddi r1,r1,\d+\n//;
 735                     $e =~ s/^\tcal r1,\d+\(r1\)\n//;
 736                     $e =~ s/^\tlw?z? r\d+,\d+\(r1\)\n//;
 737                     $e =~ s/^\tmtlr r0\n//;
 738                     $e =~ s/^\tblr\n//;
 739                 } else {
 740                     print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n";
 741                 }
 742
 743                 print STDERR "WARNING: Epilogue junk?: $e\n" if $e =~ /^\t\s*[^\.\s\n]/;
 744
 745                 # glue together what's left
 746                 $c = $r . $e;
 747                 $c =~ s/\n\t\n/\n/; # junk blank line
 748             }
 749         }
 750
 751         # On SPARCs, we don't do --- BEGIN/END ---, we just
 752         # toss the register-windowing save/restore/ret* instructions
 753         # directly:
 754         if ( $TargetPlatform =~ /^sparc-/ ) {
 755             $c =~ s/^\t(save.*|restore|ret|retl)\n//g;
 756             # throw away PROLOGUE comments
 757             $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//;
 758         }
 759
 760         # On Alphas, the prologue mangling is done a little later (below)
 761
 762         # toss all calls to __DISCARD__
 763         $c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//go;
 764 # ###WTT###     $c =~ s/^\tbl\s+L___DISCARD__\$stub\n//go if $TargetPlatform =~ /^powerpc-apple-.*/;
 765
 766         # MIPS: that may leave some gratuitous asm macros around
 767         # (no harm done; but we get rid of them to be tidier)
 768         $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/
 769             if $TargetPlatform =~ /^mips-/;
 770
 771         # toss stack adjustment after DoSparks
 772         $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/g
 773                 if $TargetPlatform =~ /^m68k-/; # this looks old...
 774
 775         if ( $TargetPlatform =~ /^alpha-/ &&
 776            ! $magic_rdata_seen &&
 777            $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/ ) {
 778             $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/;
 779             $magic_rdata_seen = 1;
 780         }
 781
 782         # pick some end-things and move them to the next chunk
 783
 784         # pin a funny end-thing on (for easier matching):
 785         $c .= 'FUNNY#END#THING';
 786
 787         while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/o ) {
 788
 789             $to_move = $1;
 790
 791             # on x86 we try not to copy any directives into a literal
 792             # chunk, rather we keep looking for the next real chunk.  This
 793             # is because we get things like
 794             #
 795             #    .globl blah_closure
 796             #    .LC32
 797             #           .string "..."
 798             #    blah_closure:
 799             #           ...
 800             #
 801             if ( $TargetPlatform =~ /^(i386|sparc)/ && $to_move =~ /${T_COPY_DIRVS}/ ) {
 802                 $j = $i + 1;
 803                 while ( $j < $numchks  && $chk[$j] =~ /$T_CONST_LBL/) {
 804                         $j++;
 805                 }
 806                 if ( $j < $numchks ) {
 807                         $chk[$j] = $to_move . $chk[$j];
 808                 }
 809             }
 810
 811             elsif ( $i < ($numchks - 1)
 812               && ( $to_move =~ /${T_COPY_DIRVS}/
 813                 || ($TargetPlatform =~ /^hppa/ && $to_move =~ /align/ && $chkcat[$i+1] eq 'literal') )) {
 814                 $chk[$i + 1] = $to_move . $chk[$i + 1];
 815                 # otherwise they're tossed
 816             }
 817
 818             $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/o;
 819         }
 820
 821         if ( $TargetPlatform =~ /^alpha-/ && $c =~ /^\t\.ent\s+(\S+)/ ) {
 822             $ent = $1;
 823             # toss all prologue stuff, except for loading gp, and the ..ng address
 824             if (($p, $r) = split(/^\t\.prologue/, $c)) {
 825                 if (($keep, $junk) = split(/\.\.ng:/, $p)) {
 826                     $keep =~ s/^\t\.frame.*\n/\t.frame \$30,0,\$26,0\n/;
 827                     $keep =~ s/^\t\.(mask|fmask).*\n//g;
 828                     $c = $keep . "..ng:\n";
 829                 } else {
 830                     print STDERR "malformed code block ($ent)?\n"
 831                 }
 832             }
 833             $c .= "\t.prologue" . $r;
 834         }
 835
 836         $c =~ s/FUNNY#END#THING//;
 837
 838 #       print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c;
 839
 840         $chk[$i] = $c; # update w/ convenience copy
 841     }
 842
 843     # open CHUNKS, ">/tmp/chunks2" or die "Cannot open /tmp/chunks2: $!\n";
 844     # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] }
 845     # close CHUNKS;
 846
 847     if ( $TargetPlatform =~ /^alpha-/ ) {
 848         # print out the header stuff first
 849         $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/$1"$ifile_root.hc"/;
 850         print OUTASM $chk[0];
 851
 852     } elsif ( $TargetPlatform =~ /^hppa/ ) {
 853         print OUTASM $chk[0];
 854
 855     } elsif ( $TargetPlatform =~ /^mips-/ ) {
 856         $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0];
 857
 858         # get rid of horrible "<dollar>Revision: .*$" strings
 859         local(@lines0) = split(/\n/, $chk[0]);
 860         local($z) = 0;
 861         while ( $z <= $#lines0 ) {
 862             if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/ ) {
 863                 undef($lines0[$z]);
 864                 $z++;
 865                 while ( $z <= $#lines0 ) {
 866                     undef($lines0[$z]);
 867                     last if $lines0[$z] =~ /[,\t]0x0$/;
 868                     $z++;
 869                 }
 870             }
 871             $z++;
 872         }
 873         $chk[0] = join("\n", @lines0);
 874         $chk[0] =~ s/\n\n+/\n/;
 875         print OUTASM $chk[0];
 876     }
 877
 878     # print out all the literal strings next
 879     for ($i = 0; $i < $numchks; $i++) {
 880         if ( $chkcat[$i] eq 'literal' ) {
 881             print OUTASM $T_HDR_literal, $chk[$i];
 882             print OUTASM "; end literal\n" if $TargetPlatform =~ /^hppa/; # for the splitter
 883
 884             $chkcat[$i] = 'DONE ALREADY';
 885         }
 886     }
 887
 888     # on the HPPA, print out all the bss next
 889     if ( $TargetPlatform =~ /^hppa/ ) {
 890         for ($i = 1; $i < $numchks; $i++) {
 891             if ( $chkcat[$i] eq 'bss' ) {
 892                 print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$BSS\$\n\t.align 4\n";
 893                 print OUTASM $chk[$i];
 894
 895                 $chkcat[$i] = 'DONE ALREADY';
 896             }
 897         }
 898     }
 899
 900     for ($i = $FIRST_MANGLABLE; $i < $numchks; $i++) {
 901 #       print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
 902
 903         next if $chkcat[$i] eq 'DONE ALREADY';
 904
 905         if ( $chkcat[$i] eq 'misc' ) {
 906             if ($chk[$i] ne '') {
 907                 print OUTASM $T_HDR_misc;
 908                 &print_doctored($chk[$i], 0);
 909             }
 910
 911         } elsif ( $chkcat[$i] eq 'toss' ) {
 912             print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n";
 913
 914         } elsif ( $chkcat[$i] eq 'data' ) {
 915             if ($chk[$i] ne '') {
 916                 print OUTASM $T_HDR_data;
 917                 print OUTASM $chk[$i];
 918             }
 919
 920         } elsif ( $chkcat[$i] eq 'consist' ) {
 921             if ( $chk[$i] =~ /$T_hsc_cc_PAT/o ) {
 922                 local($consist) = "$1.$2.$3";
 923                 $consist =~ s/,/./g;
 924                 $consist =~ s/\//./g;
 925                 $consist =~ s/-/_/g;
 926                 $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
 927                 #
 928                 # Using a cygnus-2.7-96q4 gcc build on hppas, the
 929                 # consistency chunk for ghc_cc_ID often (but not always!)
 930                 # gets lumped with a bunch of .IMPORT directives containing info on
 931                 # the code or data space nature of external symbols. We can't
 932                 # toss these, so once the consistency ID has been turned into
 933                 # a representable symbol, we substitute it for the symbol
 934                 # that the string was attached to in the first place (ghc_cc_ID.)
 935                 # (The original string is also substituted away.)
 936                 #
 937                 # This change may affect the code output on other platforms in
 938                 # adverse ways, hence we restrict this hack hppa targets only.
 939                 #
 940                 #    -- 2/98 SOF
 941                 if ( $TargetPlatform =~ /^hppa/ )  {
 942                         $chk[$i] =~ s/^${T_US}ghc.*c_ID$TPOSTLBL/$consist/o;
 943                         $chk[$i] =~ s/\t$T_hsc_cc_PAT/$T_HDR_misc/o;
 944                         $consist = $chk[$i]; #clumsily
 945                 }
 946                 print OUTASM $T_HDR_consist, "${consist}${T_POST_LBL}\n";
 947
 948             } elsif ( $TargetPlatform !~ /^(mips)-/ ) { # we just don't try in those case (ToDo)
 949                 # on mips: consistency string is just a v
 950                 # horrible bunch of .bytes,
 951                 # which I am too lazy to sort out (WDP 95/05)
 952
 953                 print STDERR "Couldn't grok consistency: ", $chk[$i];
 954             }
 955
 956         } elsif ( $chkcat[$i] eq 'splitmarker' ) {
 957             # we can just re-constitute this one...
 958             # NB: we emit _three_ underscores no matter what,
 959             # so ghc-split doesn't have to care.
 960             print OUTASM "___stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n";
 961
 962         } elsif ( $chkcat[$i] eq 'closure'
 963                || $chkcat[$i] eq 'srt'
 964                || $chkcat[$i] eq 'infotbl'
 965                || $chkcat[$i] eq 'slow'
 966                || $chkcat[$i] eq 'fast' ) { # do them in that order
 967             $symb = $chksymb[$i];
 968
 969             # CLOSURE
 970             if ( defined($closurechk{$symb}) ) {
 971                 print OUTASM $T_HDR_closure;
 972                 print OUTASM $chk[$closurechk{$symb}];
 973                 $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
 974             }
 975
 976             # SRT
 977             if ( defined($srtchk{$symb}) ) {
 978                 print OUTASM $T_HDR_srt;
 979                 print OUTASM $chk[$srtchk{$symb}];
 980                 $chkcat[$srtchk{$symb}] = 'DONE ALREADY';
 981             }
 982
 983             # INFO TABLE
 984             if ( defined($infochk{$symb}) ) {
 985
 986                 print OUTASM $T_HDR_info;
 987                 print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
 988
 989                 # entry code will be put here!
 990
 991                 $chkcat[$infochk{$symb}] = 'DONE ALREADY';
 992             }
 993
 994             # STD ENTRY POINT
 995             if ( defined($slowchk{$symb}) ) {
 996
 997                 # teach it to drop through to the fast entry point:
 998                 $c = $chk[$slowchk{$symb}];
 999
1000                 if ( defined($fastchk{$symb}) ) {
1001                     if ( $TargetPlatform =~ /^alpha-/ ) {
1002                         $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
1003                     } elsif ( $TargetPlatform =~ /^hppa/ ) {
1004                         $c =~ s/^\s+ldil.*\n\s+ldo.*\n\s+bv.*\n(.*\n)?\s+\.EXIT/$1\t.EXIT/;
1005                     } elsif ( $TargetPlatform =~ /^i386-/ ) {
1006                         # Reg alloc depending, gcc generated code may jump to the fast entry point via
1007                         # a number of registers.
1008                         $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%edx\n\tjmp\s+\*\%edx\n//;
1009                         $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%ecx\n\tjmp\s+\*\%ecx\n//;
1010                         $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%eax\n\tjmp\s+\*\%eax\n//;
1011                         # The next two only apply if we're not stealing %esi or %edi.
1012                         $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%esi\n\tjmp\s+\*\%esi\n// if ($StolenX86Regs < 3);
1013                         $c =~ s/^\tmovl\s+\$${T_US}${symb}_fast\d*,\s*\%edi\n\tjmp\s+\*\%edi\n// if ($StolenX86Regs < 4);
1014                     } elsif ( $TargetPlatform =~ /^mips-/ ) {
1015                         $c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
1016                     } elsif ( $TargetPlatform =~ /^m68k-/ ) {
1017                         $c =~ s/^\tjmp ${T_US}${symb}_fast\d+.*\n\tnop\n//;
1018                         $c =~ s/^\tjmp ${T_US}${symb}_fast\d+.*\n//;
1019                     } elsif ( $TargetPlatform =~ /^powerpc-apple-.*/ ) {
1020                         $c =~ s/^\taddis r9,r31,ha16\(L_${symb}_fast\d*\$non_lazy_ptr-L\d+\$pb\)\n\tlwz r9,lo16\(L_${symb}_fast\d*\$non_lazy_ptr-L\d+\$pb\)\(r9\)\n\tmtctr r9\n\tbctr\n//;
1021                                 #       addis r9,r31,ha16(L_XXXX_fast3$non_lazy_ptr-L32$pb)
1022                                 #       lwz r9,lo16(L_XXXX_fast3$non_lazy_ptr-L32$pb)(r9)
1023                                 #       mtctr r9
1024                                 #       bctr
1025                     } elsif ( $TargetPlatform =~ /^sparc-/ ) {
1026                         $c =~ s/^\tcall\s+${T_US}${symb}_fast\d+,.*\n\t\s*nop\n//;
1027                         $c =~ s/^\tcall\s+${T_US}${symb}_fast\d+,.*\n(\t\s*[a-z].*\n)/$1/;
1028                     } else {
1029                         print STDERR "$Pgm: mystery slow-fast dropthrough: $TargetPlatform\n";
1030                     }
1031                 }
1032
1033                 if ( $TargetPlatform !~ /^(alpha-|hppa|mips-|powerpc-apple-)/) {
1034                     # On alphas, hppa: no very good way to look for "dangling"
1035                     # references to fast-entry point.
1036                     # (questionable re hppa and mips...)
1037                     print STDERR "still has jump to fast entry point:\n$c"
1038                         if $c =~ /\b${T_US}${symb}_fast/;
1039                 }
1040
1041                 print OUTASM $T_HDR_entry;
1042
1043                 &print_doctored($c, 1); # NB: the 1!!!
1044
1045                 $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
1046             }
1047
1048             # FAST ENTRY POINT
1049             if ( defined($fastchk{$symb}) ) {
1050                 $c = $chk[$fastchk{$symb}];
1051                 if ( ! defined($slowchk{$symb})
1052                    # ToDo: the || clause can go once we're no longer
1053                    # concerned about producing exactly the same output as before
1054 #OLD:              || $TargetPlatform =~ /^(m68k|sparc|i386)-/
1055                    ) {
1056                     print OUTASM $T_HDR_fast;
1057                 }
1058
1059                 &print_doctored($c, 0);
1060                 $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
1061             }
1062
1063         } elsif ( $chkcat[$i] eq 'vector'
1064                || $chkcat[$i] eq 'direct' ) { # do them in that order
1065             $symb = $chksymb[$i];
1066
1067             # VECTOR TABLE
1068             if ( defined($vectorchk{$symb}) ) {
1069                 print OUTASM $T_HDR_vector;
1070
1071                 print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
1072                   # DO NOT DELETE THE NEXT LINE.  It fixes a rather subtle GC bug
1073                   # which showed up as a segfault reported by Ryszard Kubiak.
1074                   # Problem is with vector tables.  They wind up as follows:
1075                   #      .word some-word
1076                   #      .word some-other-word
1077                   #   fooble_vtbl:
1078                   # Problem is that we want the label fooble_vtbl to be considered
1079                   # in the same section as the vtbl itself, but the label actually
1080                   # lives at the next word along.  If a data segment should happen
1081                   # to immediately follow the vtbl, as it can in GHCi, the label will
1082                   # be malclassified as in the data rather than text segment (during
1083                   # GC), and so we will regard references to it as static closure
1084                   # pointers rather than as code pointers, which is an error which
1085                   # usually crashes the garbage collectors.
1086                   # To fix this, we place a dummy word after the label, so as to
1087                   # ensure that the label is in the same segment as the vtbl proper.
1088                   # The native code generator has an analogous fix; see
1089                   # ghc/compiler/nativeGen/AbsCStixGen.lhs line 107.
1090                 print OUTASM "${T_create_word} 0\n";
1091
1092                 # direct return code will be put here!
1093                 $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
1094
1095             } elsif ( $TargetPlatform =~ /^alpha-/ ) {
1096                 # Alphas: the commented nop is for the splitter, to ensure
1097                 # that no module ends with a label as the very last
1098                 # thing.  (The linker will adjust the label to point
1099                 # to the first code word of the next module linked in,
1100                 # even if alignment constraints cause the label to move!)
1101
1102                 print OUTASM "\t# nop\n";
1103             }
1104
1105         } elsif ( $chkcat[$i] eq 'toc' ) {
1106             # silly optimisation to print tocs, since they come in groups...
1107             print OUTASM $T_HDR_toc;
1108             local($j)   = $i;
1109             while ($chkcat[$j] eq 'toc')
1110               { if (   $chk[$j] !~ /\.tc UpdatePAP\[TC\]/ # not needed: always turned into a jump.
1111                    )
1112                 {
1113                   print OUTASM $chk[$j];
1114                 }
1115                 $chkcat[$j] = 'DONE ALREADY';
1116                 $j++;
1117             }
1118
1119         } else {
1120             &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm: $TargetPlatform)\n$chkcat[$i]\n$chk[$i]\n");
1121         }
1122     }
1123
1124     print OUTASM $EXTERN_DECLS if $TargetPlatform =~ /^mips-/;
1125
1126     # finished
1127     close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
1128     close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
1129 }
1130 \end{code}
1131
1132 \begin{code}
1133 sub mash_hppa_prologue { # OK, epilogue, too
1134     local($_) = @_;
1135
1136     # toss all prologue stuff
1137     s/^\s+\.ENTRY[^\0]*--- BEGIN ---/\t.ENTRY/;
1138
1139     # Lie about our .CALLINFO
1140     s/^\s+\.CALLINFO.*$/\t.CALLINFO NO_CALLS,NO_UNWIND/;
1141
1142     # Get rid of P'
1143
1144     s/LP'/L'/g;
1145     s/RP'/R'/g;
1146
1147     # toss all epilogue stuff
1148     s/^\s+--- END ---[^\0]*\.EXIT/\t.EXIT/;
1149
1150     # Sorry; we moved the _info stuff to the code segment.
1151     s/_info,DATA/_info,CODE/g;
1152
1153     return($_);
1154 }
1155 \end{code}
1156
1157 \begin{code}
1158 sub print_doctored {
1159     local($_, $need_fallthru_patch) = @_;
1160
1161     if ( $TargetPlatform !~ /^i386-/
1162       || ! /^\t[a-z]/  # no instructions in here, apparently
1163       || /^${T_US}__stginit_[A-Za-z0-9_]+${T_POST_LBL}/) {
1164         print OUTASM $_;
1165         return;
1166     }
1167     # OK, must do some x86 **HACKING**
1168
1169     local($entry_patch) = '';
1170     local($exit_patch)  = '';
1171
1172     # gotta watch out for weird instructions that
1173     # invisibly smash various regs:
1174     #   rep*    %ecx used for counting
1175     #   scas*   %edi used for destination index
1176     #   cmps*   %e[sd]i used for indices
1177     #   loop*   %ecx used for counting
1178     #
1179     # SIGH.
1180
1181     # We cater for:
1182     #  * use of STG reg [ nn(%ebx) ] where no machine reg avail
1183     #
1184     #  * GCC used an "STG reg" for its own purposes
1185     #
1186     #  * some secret uses of machine reg, requiring STG reg
1187     #    to be saved/restored
1188
1189     # The most dangerous "GCC uses" of an "STG reg" are when
1190     # the reg holds the target of a jmp -- it's tricky to
1191     # insert the patch-up code before we get to the target!
1192     # So here we change the jmps:
1193
1194     # --------------------------------------------------------
1195     # it can happen that we have jumps of the form...
1196     #   jmp *<something involving %esp>
1197     # or
1198     #   jmp <something involving another naughty register...>
1199     #
1200     # a reasonably-common case is:
1201     #
1202     #   movl $_blah,<bad-reg>
1203     #   jmp  *<bad-reg>
1204     #
1205
1206     s/^\tmovl\s+\$${T_US}(.*),(\%e[abcd]x)\n\tjmp\s+\*\2/\tjmp $T_US$1/g;
1207
1208     if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi?
1209         s/^\tmovl\s+(.*),\s*\%esi\n\tjmp\s+\*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
1210         s/^\tjmp\s+\*(.*\(.*\%esi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
1211         s/^\tjmp\s+\*\%esi\n/\tmovl \%esi,\%eax\n\tjmp \*\%eax\n/g;
1212         die "$Pgm: (mangler) still have jump involving \%esi!\n$_"
1213             if /(jmp|call)\s+.*\%esi/;
1214     }
1215     if ($StolenX86Regs <= 3 ) { # spurious uses of edi?
1216         s/^\tmovl\s+(.*),\s*\%edi\n\tjmp\s+\*%edi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
1217         s/^\tjmp\s+\*(.*\(.*\%edi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
1218         s/^\tjmp\s+\*\%edi\n/\tmovl \%edi,\%eax\n\tjmp \*\%eax\n/g;
1219         die "$Pgm: (mangler) still have jump involving \%edi!\n$_"
1220             if /(jmp|call)\s+.*\%edi/;
1221     }
1222
1223     # OK, now we can decide what our patch-up code is going to
1224     # be:
1225
1226     # Offsets into register table - you'd better update these magic
1227     # numbers should you change its contents!
1228     # local($OFFSET_R1)=0;  No offset for R1 in new RTS.
1229     local($OFFSET_Hp)=92;
1230
1231         # Note funky ".=" stuff; we're *adding* to these _patch guys
1232     if ( $StolenX86Regs <= 2
1233          && ( /[^0-9]\(\%ebx\)/ || /\%esi/ || /^\tcmps/ ) ) { # R1 (esi)
1234         $entry_patch .= "\tmovl \%esi,(\%ebx)\n";
1235         $exit_patch  .= "\tmovl (\%ebx),\%esi\n";
1236
1237         # nothing for call_{entry,exit} because %esi is callee-save
1238     }
1239     if ( $StolenX86Regs <= 3
1240          && ( /${OFFSET_Hp}\(\%ebx\)/ || /\%edi/ || /^\t(scas|cmps)/ ) ) { # Hp (edi)
1241         $entry_patch .= "\tmovl \%edi,${OFFSET_Hp}(\%ebx)\n";
1242         $exit_patch  .= "\tmovl ${OFFSET_Hp}(\%ebx),\%edi\n";
1243
1244         # nothing for call_{entry,exit} because %edi is callee-save
1245     }
1246
1247     # --------------------------------------------------------
1248     # next, here we go with non-%esp patching!
1249     #
1250     s/^(\t[a-z])/$entry_patch$1/; # before first instruction
1251
1252 # Before calling GC we must set up the exit condition before the call
1253 # and entry condition when we come back
1254
1255     # fix _all_ non-local jumps:
1256
1257     s/^\tjmp\s+\*${T_X86_PRE_LLBL_PAT}/\tJMP___SL/go;
1258     s/^\tjmp\s+${T_X86_PRE_LLBL_PAT}/\tJMP___L/go;
1259
1260     s/^(\tjmp\s+.*\n)/$exit_patch$1/g; # here's the fix...
1261
1262     s/^\tJMP___SL/\tjmp \*${T_X86_PRE_LLBL}/go;
1263     s/^\tJMP___L/\tjmp ${T_X86_PRE_LLBL}/go;
1264
1265     if ($StolenX86Regs == 2 ) {
1266         die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_"
1267             if /^\t(jmp|call)\s+.*\%e(si|di)/;
1268     } elsif ($StolenX86Regs == 3 ) {
1269         die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_"
1270             if /^\t(jmp|call)\s+.*\%edi/;
1271     }
1272
1273     # --------------------------------------------------------
1274     # that's it -- print it
1275     #
1276     #die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia
1277
1278     print OUTASM $_;
1279
1280     if ( $need_fallthru_patch ) { # exit patch for end of slow entry code
1281         print OUTASM $exit_patch;
1282         # ToDo: make it not print if there is a "jmp" at the end
1283     }
1284 }
1285 \end{code}
1286
1287 \begin{code}
1288 sub init_FUNNY_THINGS {
1289     %KNOWN_FUNNY_THING = (
1290         # example
1291         # "${T_US}stg_.*{T_POST_LBL}", 1,
1292     );
1293 }
1294 \end{code}
1295
1296 The following table reversal is used for both info tables and return
1297 vectors.  In both cases, we remove the first entry from the table,
1298 reverse the table, put the label at the end, and paste some code
1299 (that which is normally referred to by the first entry in the table)
1300 right after the table itself.  (The code pasting is done elsewhere.)
1301
1302 \begin{code}
1303 sub rev_tbl {
1304     local($symb, $tbl, $discard1) = @_;
1305
1306     local($before) = '';
1307     local($label) = '';
1308     local(@imports) = (); # hppa only
1309     local(@words) = ();
1310     local($after) = '';
1311     local(@lines) = split(/\n/, $tbl);
1312     local($i, $j);
1313
1314     # Deal with the header...
1315     for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t?${T_DOT_WORD}\s+/o; $i++) {
1316         $label .= $lines[$i] . "\n",
1317             next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/o
1318                  || $lines[$i] =~ /${T_DOT_GLOBAL}/o
1319                  || $lines[$i] =~ /^${T_US}\S+_vtbl${T_POST_LBL}$/o;
1320
1321         $before .= $lines[$i] . "\n"; # otherwise...
1322     }
1323
1324     # Grab the table data...
1325     if ( $TargetPlatform !~ /^hppa/ ) {
1326         for ( ; $i <= $#lines && $lines[$i] =~ /^\t?${T_DOT_WORD}\s+/o; $i++) {
1327             push(@words, $lines[$i]);
1328         }
1329     } else { # hppa weirdness
1330         for ( ; $i <= $#lines && $lines[$i] =~ /^\s+(${T_DOT_WORD}|\.IMPORT)/; $i++) {
1331             if ($lines[$i] =~ /^\s+\.IMPORT/) {
1332                 push(@imports, $lines[$i]);
1333             } else {
1334                 # We don't use HP's ``function pointers''
1335                 # We just use labels in code space, like normal people
1336                 $lines[$i] =~ s/P%//;
1337                 push(@words, $lines[$i]);
1338             }
1339         }
1340     }
1341
1342     # now throw away the first word (SRT) iff it is empty.
1343     # The .zero business is for Linux/ELF.
1344     # The .skip business is for Sparc/Solaris/ELF.
1345     # The .blockz business is for HPPA.
1346     if ($discard1 && $words[0] =~ /^\t?(${T_DOT_WORD}\s+0|\.zero\s+4|\.skip\s+4|\.blockz\s+4)/) {
1347         shift(@words)
1348     }
1349
1350     for (; $i <= $#lines; $i++) {
1351         $after .= $lines[$i] . "\n";
1352     }
1353
1354     # Alphas: If we have anonymous text (not part of a procedure), the
1355     # linker may complain about missing exception information.  Bleh.
1356     # To suppress this, we place a .ent/.end pair around the code.
1357     # At the same time, we have to be careful and not enclose any leading
1358     # .file/.loc directives.
1359     if ( $TargetPlatform =~ /^alpha-/ && $label =~ /^([A-Za-z0-9_]+):$/) {
1360         local ($ident) = $1;
1361         $before =~ s/^((\s*\.(file|loc)\s+[^\n]*\n)*)/$1\t.ent $ident\n/;
1362         $after .= "\t.end $ident\n";
1363     }
1364
1365     # Alphas: The heroic Simon Marlow found a bug in the Digital UNIX
1366     # assembler (!) wherein .quad constants inside .text sections are
1367     # first narrowed to 32 bits then sign-extended back to 64 bits.
1368     # This obviously screws up our 64-bit bitmaps, so we work around
1369     # the bug by replacing .quad with .align 3 + .long + .long [ccshan]
1370     if ( $TargetPlatform =~ /^alpha-/ ) {
1371         foreach (@words) {
1372             if (/^\s*\.quad\s+([-+0-9].*\S)\s*$/ && length $1 >= 10) {
1373                 local ($number) = $1;
1374                 if ($number =~ /^([-+])?(0x?)?([0-9]+)$/) {
1375                     local ($sign, $base, $digits) = ($1, $2, $3);
1376                     $base = (10, 8, 16)[length $base];
1377                     local ($hi, $lo) = (0, 0);
1378                     foreach $i (split(//, $digits)) {
1379                         $j = $lo * $base + $i;
1380                         $lo = $j % 4294967296;
1381                         $hi = $hi * $base + ($j - $lo) / 4294967296;
1382                     }
1383                     ($hi, $lo) = (4294967295 - $hi, 4294967296 - $lo)
1384                         if $sign eq "-";
1385                     $_ = "\t.align 3\n\t.long $lo\n\t.long $hi\n";
1386                     # printf STDERR "TURNING %s into 0x %08x %08x\n", $number, $hi, $lo;
1387                 } else {
1388                     print STDERR "Cannot handle \".quad $number\" in info table\n";
1389                     exit 1;
1390                 }
1391             }
1392         }
1393     }
1394
1395     $tbl = $before
1396          . (($TargetPlatform !~ /^hppa/) ? '' : join("\n", @imports) . "\n")
1397          . join("\n", @words) . "\n"
1398          . $label . $after;
1399
1400 #   print STDERR "before=$before\n";
1401 #   print STDERR "label=$label\n";
1402 #   print STDERR "words=",(reverse @words),"\n";
1403 #   print STDERR "after=$after\n";
1404
1405     $tbl;
1406 }
1407 \end{code}
1408
1409 The HP is a major nuisance.  The threaded code mangler moved info
1410 tables from data space to code space, but unthreaded code in the RTS
1411 still has references to info tables in data space.  Since the HP
1412 linker is very precise about where symbols live, we need to patch the
1413 references in the unthreaded RTS as well.
1414
1415 \begin{code}
1416 sub mini_mangle_asm_hppa {
1417     local($in_asmf, $out_asmf) = @_;
1418
1419     open(INASM, "< $in_asmf")
1420         || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
1421     open(OUTASM,"> $out_asmf")
1422         || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
1423
1424     while (<INASM>) {
1425         s/_info,DATA/_info,CODE/;   # Move _info references to code space
1426         s/P%_PR/_PR/;
1427         print OUTASM;
1428     }
1429
1430     # finished:
1431     close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
1432     close(INASM)  || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
1433 }
1434
1435 \end{code}
1436
1437 \begin{code}
1438 sub tidy_up_and_die {
1439     local($return_val, $msg) = @_;
1440     print STDERR $msg;
1441     exit (($return_val == 0) ? 0 : 1);
1442 }
1443 \end{code}