X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fdriver%2Fmangler%2Fghc-asm.lprl;h=9cdd983d10795a2a7f1abf7d8e14854a6e9485ed;hb=cb470321d910dca529dc5363cb87932eeb8ee9c5;hp=44f4693c7555511a2fcaec8e751e8b3143fc9258;hpb=630af8101b7af8583542fc45616383608cb3f76a;p=ghc-hetmet.git diff --git a/ghc/driver/mangler/ghc-asm.lprl b/ghc/driver/mangler/ghc-asm.lprl index 44f4693..9cdd983 100644 --- a/ghc/driver/mangler/ghc-asm.lprl +++ b/ghc/driver/mangler/ghc-asm.lprl @@ -66,7 +66,11 @@ $ifile = $ARGV[0]; $ofile = $ARGV[1]; if ( $TargetPlatform =~ /^i386-/ ) { - $StolenX86Regs = $ARGV[2]; + if ($ARGV[2] eq '') { + $StolenX86Regs = 4; + } else { + $StolenX86Regs = $ARGV[2]; + } } &mangle_asm($ifile,$ofile); @@ -89,14 +93,14 @@ sub init_TARGET_STUFF { $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) $T_US = ''; # _ if symbols have an underscore on the front $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP - $T_CONST_LBL = '^\$C(\d+):$'; # regexp for what such a lbl looks like + $T_CONST_LBL = '^\$L?C(\d+):$'; # regexp for what such a lbl looks like $T_POST_LBL = ':'; $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)'; $T_COPY_DIRVS = '^\s*(\#|\.(file|globl|ent|loc))'; $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"'; - $T_DOT_WORD = '\.quad'; + $T_DOT_WORD = '\.(long|quad|byte|word)'; $T_DOT_GLOBAL = '^\t\.globl'; $T_HDR_literal = "\.rdata\n\t\.align 3\n"; $T_HDR_misc = "\.text\n\t\.align 3\n"; @@ -109,6 +113,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.align 3\n"; $T_HDR_vector = "\.text\n\t\.align 3\n"; $T_HDR_direct = "\.text\n\t\.align 3\n"; + $T_create_word = "\t.quad"; #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^hppa/ ) { @@ -136,9 +141,10 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; $T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; $T_HDR_direct = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n"; + $T_create_word = "\t.word"; #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|netbsd|openbsd|nextstep3|cygwin32|mingw32)$/ ) { + } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|openbsd|nextstep3|cygwin32|mingw32)$/ ) { # NeXT added but not tested. CaS $T_STABBY = 1; # 1 iff .stab things (usually if a.out format) @@ -167,14 +173,15 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.align 2,0x90\n"; $T_HDR_vector = "\.text\n\t\.align 2\n"; # NB: requires padding $T_HDR_direct = "\.text\n\t\.align 2,0x90\n"; + $T_create_word = "\t.word"; #--------------------------------------------------------# - } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|freebsd|netbsd_elf)$/ ) { + } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|freebsd|netbsd)$/ ) { $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) $T_US = ''; # _ if symbols have an underscore on the front $T_PRE_APP = # regexp that says what comes before APP/NO_APP - ($TargetPlatform =~ /-(linux|freebsd|netbsd_elf)$/) ? '#' : '/' ; + ($TargetPlatform =~ /-(linux|freebsd|netbsd)$/) ? '#' : '/' ; $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like $T_POST_LBL = ':'; $T_X86_PRE_LLBL_PAT = '\.L'; @@ -184,7 +191,7 @@ sub init_TARGET_STUFF { $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)'; $T_COPY_DIRVS = '\.(globl)'; - if ( $TargetPlatform =~ /freebsd|netbsd_elf/ ) { + if ( $TargetPlatform =~ /freebsd|netbsd/ ) { $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"'; } else { $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"'; @@ -203,6 +210,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.align 4\n"; $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding $T_HDR_direct = "\.text\n\t\.align 4\n"; + $T_create_word = "\t.word"; #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/ ) { @@ -230,6 +238,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.even\n"; $T_HDR_vector = "\.text\n\t\.even\n"; $T_HDR_direct = "\.text\n\t\.even\n"; + $T_create_word = "\t.long"; #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^mips-.*/ ) { @@ -257,6 +266,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\t\.text\n\t\.align 2\n"; $T_HDR_vector = "\t\.text\n\t\.align 2\n"; $T_HDR_direct = "\t\.text\n\t\.align 2\n"; + $T_create_word = "\t.word"; #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^powerpc-.*|^rs6000-.*/ ) { @@ -285,6 +295,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "# fast\n\.csect \.text[PR]\n\t\.align 2\n"; $T_HDR_vector = "# vector\n\.csect \.data[RW]\n\t\.align 2\n"; #not RO!? $T_HDR_direct = "# direct\n"; + $T_create_word = "\t.long"; #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^sparc-.*-solaris2/ ) { @@ -312,6 +323,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.align 4\n"; $T_HDR_vector = "\.text\n\t\.align 4\n"; $T_HDR_direct = "\.text\n\t\.align 4\n"; + $T_create_word = "\t.word"; #--------------------------------------------------------# } elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/ ) { @@ -339,6 +351,7 @@ sub init_TARGET_STUFF { $T_HDR_fast = "\.text\n\t\.align 4\n"; $T_HDR_vector = "\.text\n\t\.align 4\n"; $T_HDR_direct = "\.text\n\t\.align 4\n"; + $T_create_word = "\t.word"; #--------------------------------------------------------# } else { @@ -417,6 +430,7 @@ sub mangle_asm { $i = 0; $chkcat[0] = 'misc'; $chk[0] = ''; while () { + tr/\r//d if $TargetPlatform =~ /-mingw32$/; # In case Perl doesn't convert line endings next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o; next if $T_STABBY && /^\.stab.*ghc.*c_ID/; next if /^\t\.def.*endef$/; @@ -428,7 +442,7 @@ sub mangle_asm { last if /^_section_\.text:$/ && $TargetPlatform =~ /^powerpc-|^rs6000-/; if ( $TargetPlatform =~ /^mips-/ - && /^\t\.(globl \S+ \.text|comm\t)/ ) { + && /^\t\.(globl\S+\.text|comm\t)/ ) { $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/; # As a temporary solution for compiling "foreign export" declarations, @@ -564,18 +578,16 @@ sub mangle_asm { $chksymb[$i] = ''; } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/ - && /^(_uname|uname|stat|fstat):/ ) { - # for some utterly bizarre reason, this platform - # likes to drop little local C routines with these names - # into each and every .o file that #includes the - # relevant system .h file. Yuck. We just don't - # tolerate them in .hc files (which we are processing - # here). If you need to call one of these things from - # Haskell, make a call to your own C wrapper, then - # put that C wrapper (which calls one of these) in a - # plain .c file. WDP 95/12 + && /^[A-Za-z0-9][A-Za-z0-9_]*:/ ) { + # Some Solaris system headers contain function definitions (as + # opposed to mere prototypes), which end up in the .hc file when + # a Haskell module foreign imports the corresponding system + # functions (most notably stat()). We put them into the text + # segment. Note that this currently does not extend to function + # names starting with an underscore. + # - chak 7/2001 $chk[++$i] = $_; - $chkcat[$i] = 'toss'; + $chkcat[$i] = 'misc'; $chksymb[$i] = $1; } elsif ( /^${T_US}[A-Za-z0-9_]/o @@ -585,13 +597,15 @@ sub mangle_asm { || ! /^(L\.\.\d+|LT\.\..*):$/ ) ) { local($thing); chop($thing = $_); - print "Funny global thing?: $_" - unless $KNOWN_FUNNY_THING{$thing} - || /^${T_US}stg_.*${T_POST_LBL}$/o # RTS internals + print STDERR "Funny global thing?: $_" + unless # $KNOWN_FUNNY_THING{$thing} + /^${T_US}stg_.*${T_POST_LBL}$/o # RTS internals (now dead?) + || /^${T_US}__stg_.*${T_POST_LBL}$/o # more RTS internals || /^${T_US}__fexp_.*${T_POST_LBL}$/o # foreign export - || /^${T_US}__init.*${T_POST_LBL}$/o # __init + || /^${T_US}__stginit.*${T_POST_LBL}$/o # __stginit || /^${T_US}.*_btm${T_POST_LBL}$/o # large bitmaps - || /^${T_US}.*_closure_tbl${T_POST_LBL}$/o; # closure tables + || /^${T_US}.*_closure_tbl${T_POST_LBL}$/o # closure tables + || /^_uname:/o; # x86/Solaris2 $chk[++$i] = $_; $chkcat[$i] = 'misc'; if ($TargetPlatform =~ /^powerpc-|^rs6000-/) @@ -605,6 +619,10 @@ sub mangle_asm { } $numchks = $#chk + 1; + # open CHUNKS, ">/tmp/chunks1" or die "Cannot open /tmp/chunks1: $!\n"; + # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] } + # close CHUNKS; + # the division into chunks is imperfect; # we throw some things over the fence into the next # chunk. @@ -614,12 +632,13 @@ sub mangle_asm { # output. local($FIRST_MANGLABLE) = ($TargetPlatform =~ /^(alpha-|hppa|mips-)/) ? 1 : 0; + local($FIRST_TOSSABLE ) = ($TargetPlatform =~ /^(hppa|mips-)/) ? 1 : 0; # print STDERR "first chunk to mangle: $FIRST_MANGLABLE\n"; # Alphas: NB: we start meddling at chunk 1, not chunk 0 # The first ".rdata" is quite magical; as of GCC 2.7.x, it - # spits a ".quad 0" in after the v first ".rdata"; we + # spits a ".quad 0" in after the very first ".rdata"; we # detect this special case (tossing the ".quad 0")! local($magic_rdata_seen) = 0; @@ -656,7 +675,7 @@ sub mangle_asm { } }; - for ($i = $FIRST_MANGLABLE; $i < $numchks; $i++) { + for ($i = $FIRST_TOSSABLE; $i < $numchks; $i++) { $c = $chk[$i]; # convenience copy # print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c; @@ -758,7 +777,7 @@ sub mangle_asm { print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n"; } - print "WARNING: Epilogue junk?: $e\n" if $e =~ /^\t\s*[^\.\s\n]/ + print STDERR "WARNING: Epilogue junk?: $e\n" if $e =~ /^\t\s*[^\.\s\n]/ && $TargetPlatform !~ /^powerpc-/; #ToDo: remove test # glue together what's left @@ -841,12 +860,14 @@ sub mangle_asm { # toss all prologue stuff, except for loading gp, and the ..ng address if (($p, $r) = split(/^\t\.prologue/, $c)) { if (($keep, $junk) = split(/\.\.ng:/, $p)) { + $keep =~ s/^\t\.frame.*\n/\t.frame \$30,0,\$26,0\n/; + $keep =~ s/^\t\.(mask|fmask).*\n//g; $c = $keep . "..ng:\n"; } else { print STDERR "malformed code block ($ent)?\n" } } - $c .= "\t.frame \$30,0,\$26,0\n\t.prologue" . $r; + $c .= "\t.prologue" . $r; } $c =~ s/FUNNY#END#THING//; @@ -856,6 +877,10 @@ sub mangle_asm { $chk[$i] = $c; # update w/ convenience copy } + # open CHUNKS, ">/tmp/chunks2" or die "Cannot open /tmp/chunks2: $!\n"; + # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] } + # close CHUNKS; + if ( $TargetPlatform =~ /^alpha-/ ) { # print out the header stuff first $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/$1"$ifile_root.hc"/; @@ -932,7 +957,7 @@ sub mangle_asm { }; &print_doctored($chk[$i], 0); if ($TargetPlatform =~ /^powerpc-|^rs6000-/ && $printDS) { -#ok if ($chksymb[$i] !~ /\__init_Main/) { +#ok if ($chksymb[$i] !~ /\__stginit_Main/) { print OUTASM "\.csect ${chksymb[$i]}[DS]\n"; print OUTASM "${p}TOC[tc0], 0\n"; #ok } @@ -1084,7 +1109,7 @@ sub mangle_asm { # references to fast-entry point. # (questionable re hppa and mips...) print STDERR "still has jump to fast entry point:\n$c" - if $c =~ /${T_US}${symb}_fast/; + if $c =~ /\b${T_US}${symb}_fast/; } print OUTASM $T_HDR_entry; @@ -1137,6 +1162,25 @@ sub mangle_asm { print OUTASM $chk[$vectorchk{$symb}]; } else { print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0); + # DO NOT DELETE THE NEXT LINE. It fixes a rather subtle GC bug + # which showed up as a segfault reported by Ryszard Kubiak. + # Problem is with vector tables. They wind up as follows: + # .word some-word + # .word some-other-word + # fooble_vtbl: + # Problem is that we want the label fooble_vtbl to be considered + # in the same section as the vtbl itself, but the label actually + # lives at the next word along. If a data segment should happen + # to immediately follow the vtbl, as it can in GHCi, the label will + # be malclassified as in the data rather than text segment (during + # GC), and so we will regard references to it as static closure + # pointers rather than as code pointers, which is an error which + # usually crashes the garbage collectors. + # To fix this, we place a dummy word after the label, so as to + # ensure that the label is in the same segment as the vtbl proper. + # The native code generator has an analogous fix; see + # ghc/compiler/nativeGen/AbsCStixGen.lhs line 107. + print OUTASM "${T_create_word} 0\n"; } # direct return code will be put here! $chkcat[$vectorchk{$symb}] = 'DONE ALREADY'; @@ -1213,7 +1257,7 @@ sub print_doctored { if ( $TargetPlatform !~ /^i386-/ || ! /^\t[a-z]/ # no instructions in here, apparently - || /^${T_US}__init_[A-Za-z0-9_]+${T_POST_LBL}/) { + || /^${T_US}__stginit_[A-Za-z0-9_]+${T_POST_LBL}/) { print OUTASM $_; return; } @@ -1362,7 +1406,7 @@ sub rev_tbl { local(@words) = (); local($after) = ''; local(@lines) = split(/\n/, $tbl); - local($i, $j); #local ($i, $extra, $words_to_pad, $j); + local($i, $j); # Deal with the header... for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t?${T_DOT_WORD}\s+/o; $i++) { @@ -1400,23 +1444,49 @@ sub rev_tbl { shift(@words) } -# Padding removed to reduce code size and improve performance on Pentiums. -# Simon M. 13/4/96 - # for 486-cache-friendliness, we want our tables aligned - # on 16-byte boundaries (.align 4). Let's pad: -# $extra = ($#words + 1) % 4; -# $words_to_pad = ($extra == 0) ? 0 : 4 - $extra; -# for ($j = 0; $j < $words_to_pad; $j++) { push(@words, "\t${T_DOT_WORD} 0"); } - for (; $i <= $#lines; $i++) { $after .= $lines[$i] . "\n"; } - # Alphas:If we have anonymous text (not part of a procedure), the + # Alphas: If we have anonymous text (not part of a procedure), the # linker may complain about missing exception information. Bleh. + # To suppress this, we place a .ent/.end pair around the code. + # At the same time, we have to be careful and not enclose any leading + # .file/.loc directives. if ( $TargetPlatform =~ /^alpha-/ && $label =~ /^([A-Za-z0-9_]+):$/) { - $before = "\t.ent $1\n" . $before; - $after .= "\t.end $1\n"; + local ($ident) = $1; + $before =~ s/^((\s*\.(file|loc)\s+[^\n]*\n)*)/$1\t.ent $ident\n/; + $after .= "\t.end $ident\n"; + } + + # Alphas: The heroic Simon Marlow found a bug in the Digital UNIX + # assembler (!) wherein .quad constants inside .text sections are + # first narrowed to 32 bits then sign-extended back to 64 bits. + # This obviously screws up our 64-bit bitmaps, so we work around + # the bug by replacing .quad with .align 3 + .long + .long [ccshan] + if ( $TargetPlatform =~ /^alpha-/ ) { + foreach (@words) { + if (/^\s*\.quad\s+([-+0-9].*\S)\s*$/ && length $1 >= 10) { + local ($number) = $1; + if ($number =~ /^([-+])?(0x?)?([0-9]+)$/) { + local ($sign, $base, $digits) = ($1, $2, $3); + $base = (10, 8, 16)[length $base]; + local ($hi, $lo) = (0, 0); + foreach $i (split(//, $digits)) { + $j = $lo * $base + $i; + $lo = $j % 4294967296; + $hi = $hi * $base + ($j - $lo) / 4294967296; + } + ($hi, $lo) = (4294967295 - $hi, 4294967296 - $lo) + if $sign eq "-"; + $_ = "\t.align 3\n\t.long $lo\n\t.long $hi\n"; + # printf STDERR "TURNING %s into 0x %08x %08x\n", $number, $hi, $lo; + } else { + print STDERR "Cannot handle \".quad $number\" in info table\n"; + exit 1; + } + } + } } $tbl = $before