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