PIC
Wolfgang Thaller
wolfgang.thaller at gmx.net
Wed Jul 7 11:41:00 EDT 2004
Position independent code works on Darwin/PowerPC!
... and now I think I might need some advice on how to clean up the
horrible mess I've made.
I'm attaching a set of preliminary patches; also, below is a summary of
what I've done.
- added a static flag -fPIC that switches on PIC generation.
- Extended CLabel by two new constructors, ImportedLabel and
ImportedCodeStubLabel.
- an importedLabel is the address of a label where the address of
the imported symbol is stored; for a label foo, it's called
__imp_foo on Windows and Lfoo$non_lazy_ptr on Darwin.
- an importedCodeStubLabel is a label for a piece of code that
calls an imported function. Lfoo$stub on Darwin, unused on
Windows.
- The cmmToCmm pass now replaces CmmLabels by the appropriate
combinations of CmmLoad and imported[CodeStub]Labels. (uses a
platform-dependent predicate labelShouldBeAccessedIndirectly, which
should perhaps be moved to CLabel).
- Extended the NCG Monad to keep track of a PIC base, which is a pair
(Reg, CLabel) used for offset calculations. This will be unused on
Windows, and used in slightly different ways on different platforms.
On Darwin, the CLabel is an address near the top of a function which
is calculated using a fake function call and stored in the Reg. For
ELF, I guess the Reg will hold the address of the GOT, and the CLabel
might go unused. We'll see.
- Did lots of PowerPC-specific things to MachCodeGen so that no
absolute references are generated in PIC code.
- For references from info tables to SRTs, slow entry points and large
bitmaps, the offset from the info table is stored instead. (in the
TABLES_NEXT_TO_CODE case only)
- Added macros like GET_SLOW_APPLY() to InfoMacros.h to make the
RTS cope with the change
- replaced info->slow_apply by GET_SLOW_APPLY(info) everywhere in
the RTS
- Added an ugly hack to the Mangler to replace labels of SRTs, slow
entry points and large bitmaps by offset expressions while
mangling info tables
- Extended CmmLit by a new constructor CmmLabelDiffOff, which is
used in CgInfoTbl to generate the offsets
- For Cmm, pretty-print (CmmLabelDiffOff a b off) as "a - b + i"
- For C, pretty-print (CmmLabelDiffOff a b off) as "a + i" and pray
that the mangler will replace "a" by "a - b" later.
- And now the really ugly part: Darwin doesn't want any relocations
in read-only segments, so...
- Put all static closures in writable data
- Hack PprMach and the Mangler to put info tables that have no code
(vector return points) into writable data space
- Hack the Mangler to put entry points that are known to be
polymorphic (stg_upd_frame, stg_seq_frame and a few more from the
RTS) into data space (even their direct entry code gets put into
data space!).
-------------- next part --------------
Index: ghc/compiler/cmm/CLabel.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/cmm/Attic/CLabel.hs,v
retrieving revision 1.1.2.14
diff -u -r1.1.2.14 CLabel.hs
--- ghc/compiler/cmm/CLabel.hs 2 Apr 2004 15:31:29 -0000 1.1.2.14
+++ ghc/compiler/cmm/CLabel.hs 7 Jul 2004 09:53:31 -0000
@@ -71,12 +71,18 @@
mkCCLabel, mkCCSLabel,
mkRtsCodeLabel, mkRtsDataLabel,
+ mkImportedLabel,
+ mkImportedCodeStubLabel,
+
infoLblToEntryLbl, entryLblToInfoLbl,
needsCDecl, isAsmTemp, externallyVisibleCLabel,
needsAmpersandInC,
CLabelType(..), labelType, labelDynamic, labelCouldBeDynamic,
+ importedLabelInfo,
pprCLabel
+
+ --,pprLabelType -- ###
) where
@@ -95,6 +101,7 @@
import Outputable
import FastString
+import Name -- ###
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -158,6 +165,22 @@
| CC_Label CostCentre
| CCS_Label CostCentreStack
+ -- Dynamic Linking in the NCG:
+ -- generated by the cmmToCmm pass or by the codegen itself.
+
+ -- A label that refers to the place where the address of an imported
+ -- entity is stored.
+ -- Win32: __imp_label
+ -- ELF: label at GOT (offset; only used in position independent code)
+ -- MachO (Mac OS X): Llabel$non_lazy_ptr
+ | ImportedLabel CLabel
+
+ -- A label that refers to a short piece of code that calls an imported
+ -- function.
+ -- Win32: not used
+ -- ELF: label at PLT
+ -- MachO (Mac OS X): Llabel$stub
+ | ImportedCodeStubLabel CLabel
deriving (Eq, Ord)
@@ -296,6 +319,19 @@
mkRtsSlowTickyCtrLabel :: String -> CLabel
mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+ -- Dynamic linking
+
+mkImportedLabel :: CLabel -> CLabel
+mkImportedLabel lbl = ImportedLabel lbl
+
+mkImportedCodeStubLabel :: CLabel -> CLabel
+mkImportedCodeStubLabel lbl = ImportedCodeStubLabel lbl
+
+importedLabelInfo :: CLabel -> Maybe (CLabel, Bool)
+importedLabelInfo (ImportedLabel lbl) = Just (lbl, False)
+importedLabelInfo (ImportedCodeStubLabel lbl) = Just (lbl, True)
+importedLabelInfo _ = Nothing
+
-- -----------------------------------------------------------------------------
-- Converting info labels to entry labels.
@@ -371,7 +407,8 @@
externallyVisibleCLabel (IdLabel id _) = isExternalName id
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
-
+externallyVisibleCLabel (ImportedLabel _) = False
+externallyVisibleCLabel (ImportedCodeStubLabel _) = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
@@ -404,6 +441,7 @@
ClosureTable -> DataLabel
_ -> CodeLabel
+labelType (ImportedCodeStubLabel _) = CodeLabel
labelType _ = DataLabel
@@ -423,9 +461,19 @@
RtsLabel RtsShouldNeverHappenCode -> False
RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not?
IdLabel n k -> isDllName n
+#if mingw32_TARGET_OS
ForeignLabel _ _ d -> d
+#else
+ -- On Mac OS X and on ELF platforms, false positives are OK,
+ -- so we claim that all foreign imports come from dynamic libraries
+ ForeignLabel _ _ _ -> True
+#endif
ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m))
PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m))
+
+ -- Note that ImportedLabels and ImportedCodeStubLabels do NOT
+ -- require dynamic linking; rather, they are part of the implementation
+ -- of dynamic linking itself.
_ -> False
-- Basically the same as above, but this time for Darwin only.
@@ -491,6 +539,12 @@
ptext asmTempLabelPrefix <> pprUnique u
else
char '_' <> pprUnique u
+
+pprCLabel (ImportedLabel lbl)
+ = pprImportedAsmLabel lbl
+
+pprCLabel (ImportedCodeStubLabel lbl)
+ = pprImportedCodeStubAsmLabel lbl
#endif
pprCLabel lbl =
@@ -626,3 +680,40 @@
#else
SLIT(".L")
#endif
+
+pprImportedAsmLabel :: CLabel -> SDoc
+pprImportedCodeStubAsmLabel :: CLabel -> SDoc
+
+#if darwin_TARGET_OS
+pprImportedAsmLabel lbl = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
+#elif mingw32_TARGET_OS
+pprImportedAsmLabel lbl = text "__imp_" <> pprCLabel lbl
+#else
+pprImportedAsmLabel lbl = panic "CLabel.pprImportedLabel not yet implemented"
+#endif
+
+#if darwin_TARGET_OS
+pprImportedCodeStubAsmLabel lbl = char 'L' <> pprCLabel lbl <> text "$stub"
+#elif mingw32_TARGET_OS
+pprImportedCodeStubAsmLabel lbl =
+ panic "CLabel.pprImportedCodeStubLabel should never be called on Win32"
+#else
+pprImportedCodeStubAsmLabel lbl =
+ panic "CLabel.pprImportedCodeStubLabel not yet implemented"
+#endif
+
+{-
+pprLabelType (IdLabel name info) = text "IdLabel" <> parens (
+ ppr name <+> pprUnique (nameUnique name))
+pprLabelType (CaseLabel u info) = text "CaseLabel"
+pprLabelType (AsmTempLabel u) = text "AsmTempLabel"
+pprLabelType (ModuleInitLabel mod way) = text "ModuleInitLabel"
+pprLabelType (PlainModuleInitLabel mod) = text "PlainModuleInitLabel"
+pprLabelType (ModuleRegdLabel) = text "ModuleRegdLabel"
+pprLabelType (RtsLabel info) = text "RtsLabel"
+pprLabelType (ForeignLabel lbl stdcall dyn) = text "ForeignLabel"
+pprLabelType (CC_Label cc) = text "CC_Label"
+pprLabelType (CCS_Label ccs) = text "CCS_Label"
+pprLabelType (ImportedLabel l) = text "ImportedLabel" <> parens (pprLabelType l)
+pprLabelType (ImportedCodeStubLabel l) = text "ImportedCodeStubLabel" <> parens (pprLabelType l)
+### -}
Index: ghc/compiler/cmm/Cmm.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/cmm/Attic/Cmm.hs,v
retrieving revision 1.1.2.37
diff -u -r1.1.2.37 Cmm.hs
--- ghc/compiler/cmm/Cmm.hs 11 Mar 2004 17:28:50 -0000 1.1.2.37
+++ ghc/compiler/cmm/Cmm.hs 7 Jul 2004 09:53:31 -0000
@@ -201,12 +201,20 @@
| CmmFloat Rational MachRep
| CmmLabel CLabel -- Address of label
| CmmLabelOff CLabel Int -- Address of label + byte offset
+
+ -- Due to limitations in the C backend, the following
+ -- MUST ONLY be used inside the info table indicated by label2
+ -- (label2 must be the info label), and label1 must be an
+ -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+ -- Don't use it at all unless tableNextToCode.
+ | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
cmmLitRep :: CmmLit -> MachRep
cmmLitRep (CmmInt _ rep) = rep
cmmLitRep (CmmFloat _ rep) = rep
cmmLitRep (CmmLabel _) = wordRep
cmmLitRep (CmmLabelOff _ _) = wordRep
+cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep
-----------------------------------------------------------------------------
-- A local label.
Index: ghc/compiler/cmm/PprC.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/cmm/Attic/PprC.hs,v
retrieving revision 1.1.2.62
diff -u -r1.1.2.62 PprC.hs
--- ghc/compiler/cmm/PprC.hs 14 Apr 2004 09:15:37 -0000 1.1.2.62
+++ ghc/compiler/cmm/PprC.hs 7 Jul 2004 09:53:32 -0000
@@ -356,9 +356,18 @@
CmmFloat f rep -> parens (machRepCType rep) <> (rational f)
CmmLabel clbl -> mkW_ <> pprLabel clbl
CmmLabelOff clbl i -> mkW_ <> pprLabel clbl <> char '+' <> int i
+ CmmLabelDiffOff clbl1 clbl2 i
+ -- WARNING:
+ -- * the lit must occur in the info table clbl2
+ -- * clbl1 must be an SRT, a slow entry point or a large bitmap
+ -- The Mangler is expected to convert any reference to an SRT,
+ -- a slow entry point or a large bitmap
+ -- from an info table to an offset.
+ -> mkW_ <> pprLabel clbl1 <> char '+' <> int i
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
pprLit1 lit@(CmmFloat _ _) = parens (pprLit lit)
pprLit1 other = pprLit other
Index: ghc/compiler/cmm/PprCmm.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/cmm/Attic/PprCmm.hs,v
retrieving revision 1.1.2.39
diff -u -r1.1.2.39 PprCmm.hs
--- ghc/compiler/cmm/PprCmm.hs 10 Mar 2004 10:25:19 -0000 1.1.2.39
+++ ghc/compiler/cmm/PprCmm.hs 7 Jul 2004 09:53:32 -0000
@@ -370,6 +370,8 @@
CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
CmmLabel clbl -> pprCLabel clbl
CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
+ CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
+ <> pprCLabel clbl2 <> ppr_offset i
-- --------------------------------------------------------------------------
-- Static data.
Index: ghc/compiler/codeGen/CgInfoTbls.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/codeGen/Attic/CgInfoTbls.hs,v
retrieving revision 1.1.2.22
diff -u -r1.1.2.22 CgInfoTbls.hs
--- ghc/compiler/codeGen/CgInfoTbls.hs 11 Mar 2004 11:47:39 -0000 1.1.2.22
+++ ghc/compiler/codeGen/CgInfoTbls.hs 7 Jul 2004 09:53:32 -0000
@@ -115,7 +115,7 @@
(mkIntCLit 0, fromIntegral (dataConTagZ con))
Nothing -> -- Not a constructor
- srtLabelAndLength srt
+ srtLabelAndLength srt info_lbl
ptrs = closurePtrsSize cl_info
nptrs = size - ptrs
@@ -136,11 +136,14 @@
| ArgGen liveness <- arg_descr
= [ fun_amode,
srt_label,
- mkLivenessCLit liveness,
- CmmLabel (mkSlowEntryLabel (closureName cl_info)) ]
+ makeRelativeRefTo info_lbl $ mkLivenessCLit liveness,
+ slow_entry ]
| needs_srt = [fun_amode, srt_label]
| otherwise = [fun_amode]
+ slow_entry = makeRelativeRefTo info_lbl (CmmLabel slow_entry_label)
+ slow_entry_label = mkSlowEntryLabel (closureName cl_info)
+
fun_amode = packHalfWordsCLit fun_type arity
fun_type = argDescrType arg_descr
@@ -208,11 +211,12 @@
; liveness <- buildContLiveness name live_slots
; srt_info <- getSRTInfo name srt
- ; let liveness_lit = mkLivenessCLit liveness
+ ; let liveness_lit = makeRelativeRefTo info_lbl $
+ mkLivenessCLit liveness
std_info = mkStdInfoTable zeroCLit zeroCLit cl_type
srt_len liveness_lit
- (srt_label, srt_len) = srtLabelAndLength srt_info
+ (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl
cl_type = case (null vector, isBigLiveness liveness) of
(True, True) -> rET_BIG
@@ -461,7 +465,30 @@
srt_escape = (-1) :: StgHalfWord
-srtLabelAndLength :: C_SRT -> (CmmLit, StgHalfWord)
-srtLabelAndLength NoC_SRT = (zeroCLit, 0)
-srtLabelAndLength (C_SRT lbl off bitmap) = (cmmLabelOffW lbl off, bitmap)
+srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
+srtLabelAndLength NoC_SRT _
+ = (zeroCLit, 0)
+srtLabelAndLength (C_SRT lbl off bitmap) info_lbl
+ = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap)
+-------------------------------------------------------------------------
+--
+-- Position independent code
+--
+-------------------------------------------------------------------------
+-- In order to support position independent code, we mustn't put absolute
+-- references into read-only space. Info tables in the tablesNextToCode
+-- case must be in .text, which is read-only, so we doctor the CmmLits
+-- to use relative offsets instead.
+
+-- Note that we don't apply this to the vectors of a vector return table,
+-- as it's easy to put them into writable data.
+
+makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
+makeRelativeRefTo info_lbl (CmmLabel lbl)
+ | tablesNextToCode
+ = CmmLabelDiffOff lbl info_lbl 0
+makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
+ | tablesNextToCode
+ = CmmLabelDiffOff lbl info_lbl off
+makeRelativeRefTo _ lit = lit
Index: ghc/compiler/main/CmdLineOpts.lhs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/main/CmdLineOpts.lhs,v
retrieving revision 1.183.2.2
diff -u -r1.183.2.2 CmdLineOpts.lhs
--- ghc/compiler/main/CmdLineOpts.lhs 11 Feb 2004 13:39:54 -0000 1.183.2.2
+++ ghc/compiler/main/CmdLineOpts.lhs 7 Jul 2004 09:53:33 -0000
@@ -92,7 +92,8 @@
opt_OmitBlackHoling,
opt_Static,
opt_Unregisterised,
- opt_EmitExternalCore
+ opt_EmitExternalCore,
+ opt_PIC
) where
#include "HsVersions.h"
@@ -805,6 +806,8 @@
-- Include full span info in error messages, instead of just the start position.
opt_ErrorSpans = lookUp FSLIT("-ferror-spans")
+
+opt_PIC = lookUp FSLIT("-fPIC")
\end{code}
%************************************************************************
@@ -847,7 +850,8 @@
"frule-check",
"frules-off",
"fcpr-off",
- "ferror-spans"
+ "ferror-spans",
+ "fPIC"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
Index: ghc/compiler/main/DriverFlags.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/main/DriverFlags.hs,v
retrieving revision 1.129.2.2
diff -u -r1.129.2.2 DriverFlags.hs
--- ghc/compiler/main/DriverFlags.hs 11 Feb 2004 13:39:55 -0000 1.129.2.2
+++ ghc/compiler/main/DriverFlags.hs 7 Jul 2004 09:53:34 -0000
@@ -618,10 +618,16 @@
-- for "normal" programs, but it doesn't support register variable
-- declarations.
-- -mdynamic-no-pic:
- -- As we don't support haskell code in shared libraries anyway,
- -- we might as well turn of PIC code generation and save space and time.
- -- This is completely optional.
- = return ( ["-no-cpp-precomp","-mdynamic-no-pic"], [] )
+ -- Turn of PIC code generation to save space and time.
+ -- -fno-common:
+ -- Don't generate "common" symbols - these are unwanted
+ -- in dynamic libraries.
+
+ = if opt_PIC
+ then return ( ["-no-cpp-precomp", "-fno-common"],
+ ["-fno-common"] )
+ else return ( ["-no-cpp-precomp", "-mdynamic-no-pic"],
+ ["-mdynamic-no-pic"] )
| prefixMatch "powerpc" cTARGETPLATFORM || prefixMatch "rs6000" cTARGETPLATFORM
= return ( ["-static"], ["-finhibit-size-directive"] )
Index: ghc/compiler/nativeGen/AsmCodeGen.lhs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/AsmCodeGen.lhs,v
retrieving revision 1.60.6.25
diff -u -r1.60.6.25 AsmCodeGen.lhs
--- ghc/compiler/nativeGen/AsmCodeGen.lhs 16 Jun 2004 13:18:33 -0000 1.60.6.25
+++ ghc/compiler/nativeGen/AsmCodeGen.lhs 7 Jul 2004 09:53:35 -0000
@@ -23,7 +23,9 @@
import Cmm
import PprCmm ( pprStmt, pprCmms )
import MachOp
-import CLabel ( CLabel, mkSplitMarkerLabel )
+import CLabel ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel,
+ labelDynamic, externallyVisibleCLabel,
+ mkImportedLabel, mkImportedCodeStubLabel )
#if powerpc_TARGET_ARCH
import CLabel ( mkRtsCodeLabel )
#endif
@@ -34,11 +36,12 @@
import FastTypes
#if darwin_TARGET_OS
import PprMach ( pprDyldSymbolStub )
-import List ( group, sort )
+import List ( groupBy, sortBy )
+import CLabel ( pprCLabel )
#endif
import ErrUtils ( dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_Static,
- opt_EnsureSplittableC )
+ opt_EnsureSplittableC, opt_PIC )
import Digraph
import qualified Pretty
@@ -146,8 +149,34 @@
#if darwin_TARGET_OS
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
- map head $ group $ sort imps
+{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
+ map head $ group $ sort imps-}
+
+ -- (Hack) sometimes two Labels pretty-print the same, but have
+ -- different uniques; so we compare their text versions...
+ dyld_stubs imps = Pretty.vcat $
+ map (pprDyldSymbolStub . (\(a,b,c) -> (a,b)) . head) $
+ groupBy (\(a,_,b) (c,_,d) -> (a,b) == (c,d)) $
+ sortBy (\(a,_,b) (c,_,d) -> compare (a,b) (c,d)) $
+ map doPpr imps
+
+ where doPpr (isCode, lbl) = (isCode, lbl,
+ Pretty.render $ pprCLabel lbl astyle)
+ astyle = mkCodeStyle AsmStyle
+
+{-
+ dyldtrace imps = trace
+ (show $
+ map (map renderit) $
+ filter ( (>1) . length ) $
+ groupBy (\a b -> Pretty.render (pprCLabel (snd a) astyle)
+ == Pretty.render (pprCLabel (snd b) astyle)) imps)
+ imps
+ where astyle = mkCodeStyle AsmStyle
+ cstyle = mkCodeStyle CStyle
+ renderit (isCode, label) =
+ (isCode, Pretty.render $ pprCLabel label astyle,
+ Pretty.render $ pprLabelType label astyle)-}
#else
dyld_stubs imps = Pretty.empty
#endif
@@ -323,7 +352,7 @@
fixAssign (CmmAssign (CmmGlobal reg) src)
| Left realreg <- reg_or_addr
- = returnUs [CmmAssign (CmmGlobal reg) (cmmExprConFold src)]
+ = returnUs [CmmAssign (CmmGlobal reg) (cmmExprConFold False src)]
| Right baseRegAddr <- reg_or_addr
= returnUs [CmmStore baseRegAddr src]
-- Replace register leaves with appropriate StixTrees for
@@ -375,27 +404,27 @@
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
- -> case cmmExprConFold src of
+ -> case cmmExprConFold False src of
CmmReg reg' | reg == reg' -> CmmNop
new_src -> CmmAssign reg new_src
CmmStore addr src
- -> CmmStore (cmmExprConFold addr) (cmmExprConFold src)
+ -> CmmStore (cmmExprConFold False addr) (cmmExprConFold False src)
CmmJump addr regs
- -> CmmJump (cmmExprConFold addr) regs
+ -> CmmJump (cmmExprConFold True addr) regs
CmmCall target regs args vols
-> CmmCall (case target of
CmmForeignCall e conv ->
- CmmForeignCall (cmmExprConFold e) conv
+ CmmForeignCall (cmmExprConFold True e) conv
other -> other)
regs
- [ (cmmExprConFold arg,hint) | (arg,hint) <- args ]
+ [ (cmmExprConFold False arg,hint) | (arg,hint) <- args ]
vols
CmmCondBranch test dest
- -> let test_opt = cmmExprConFold test
+ -> let test_opt = cmmExprConFold False test
in
case test_opt of
CmmLit (CmmInt 0 _) ->
@@ -403,32 +432,51 @@
showSDoc (pprStmt stmt)))
CmmLit (CmmInt n _) -> CmmBranch dest
- other -> CmmCondBranch (cmmExprConFold test) dest
+ other -> CmmCondBranch (cmmExprConFold False test) dest
CmmSwitch expr ids
- -> CmmSwitch (cmmExprConFold expr) ids
+ -> CmmSwitch (cmmExprConFold False expr) ids
other
-> other
-cmmExprConFold expr
+cmmExprConFold isJumpTarget expr
= case expr of
CmmLoad addr rep
- -> CmmLoad (cmmExprConFold addr) rep
+ -> CmmLoad (cmmExprConFold False addr) rep
CmmMachOp mop args
-- For MachOps, we first optimize the children, and then we try
-- our hand at some constant-folding.
- -> cmmMachOpFold mop (map cmmExprConFold args)
+ -> cmmMachOpFold mop (map (cmmExprConFold False) args)
+
+#if !mingw32_TARGET_ARCH
+ CmmLit (CmmLabel lbl)
+ | labelShouldBeAccessedIndirectly lbl && isJumpTarget
+ -> CmmLit $ CmmLabel $ mkImportedCodeStubLabel $ lbl
+#endif
+
+ CmmLit (CmmLabel lbl)
+ | labelShouldBeAccessedIndirectly lbl
+ -> CmmLoad (CmmLit $ CmmLabel $ mkImportedLabel lbl) wordRep
+
+ CmmLit (CmmLabelOff lbl off)
+ | labelShouldBeAccessedIndirectly lbl
+ -> CmmMachOp (MO_Add wordRep) [
+ (CmmLoad (CmmLit $ CmmLabel $ mkImportedLabel lbl) wordRep),
+ (CmmLit $ CmmInt (fromIntegral off) wordRep)
+ ]
#if powerpc_TARGET_ARCH
- -- On powerpc, it's easier to jump directly to a label than
+ -- On powerpc (non-PIC), it's easier to jump directly to a label than
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal GCEnter1)
+ | not opt_PIC
-> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
+ | not opt_PIC
-> CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
#endif
@@ -443,12 +491,12 @@
Left realreg -> expr
Right baseRegAddr
-> case mid of
- BaseReg -> cmmExprConFold baseRegAddr
- other -> cmmExprConFold (CmmLoad baseRegAddr
+ BaseReg -> cmmExprConFold False baseRegAddr
+ other -> cmmExprConFold False (CmmLoad baseRegAddr
(globalRegRep mid))
-- eliminate zero offsets
CmmRegOff reg 0
- -> cmmExprConFold (CmmReg reg)
+ -> cmmExprConFold False (CmmReg reg)
CmmRegOff (CmmGlobal mid) offset
-- RegOf leaves are just a shorthand form. If the reg maps
@@ -457,7 +505,7 @@
-> case get_GlobalReg_reg_or_addr mid of
Left realreg -> expr
Right baseRegAddr
- -> cmmExprConFold (CmmMachOp (MO_Add wordRep) [
+ -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
CmmReg (CmmGlobal mid),
CmmLit (CmmInt (fromIntegral offset)
wordRep)])
@@ -654,6 +702,20 @@
cmmMachOpFold mop args = CmmMachOp mop args
+labelShouldBeAccessedIndirectly :: CLabel -> Bool
+#if mingw32_TARGET_OS
+labelShouldBeAccessedIndirectly lbl = labelDynamic lbl
+#elif darwin_TARGET_OS
+labelShouldBeAccessedIndirectly lbl = labelDynamic lbl
+ || externallyVisibleCLabel lbl
+ -- && not (inCurrentModule lbl)
+-- For non-PIC (executables < 32MB):
+-- labelShouldBeAccessedIndirectly lbl = labelCouldBeDynamic lbl
+#else
+-- ELF:
+-- False for non-PIC, like darwin for PIC
+labelShouldBeAccessedIndirectly lbl = False
+#endif
-- -----------------------------------------------------------------------------
-- exactLog2
@@ -847,5 +909,6 @@
rev (MO_S_Gt r) = MO_S_Le r
rev (MO_S_Le r) = MO_S_Gt r
rev (MO_S_Ge r) = MO_S_Lt r
+
\end{code}
Index: ghc/compiler/nativeGen/MachCodeGen.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/Attic/MachCodeGen.hs,v
retrieving revision 1.1.2.53
diff -u -r1.1.2.53 MachCodeGen.hs
--- ghc/compiler/nativeGen/MachCodeGen.hs 19 Jun 2004 21:42:21 -0000 1.1.2.53
+++ ghc/compiler/nativeGen/MachCodeGen.hs 7 Jul 2004 09:53:37 -0000
@@ -28,7 +28,7 @@
import CLabel
-- The rest:
-import CmdLineOpts ( opt_Static )
+import CmdLineOpts ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
import Pretty
@@ -60,7 +60,13 @@
cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
cmmTopCodeGen (CmmProc info lab params blocks) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
- return (CmmProc info lab params (concat nat_blocks) : concat statics)
+ picBaseMb <- getPicBaseMaybeNat
+ let proc = CmmProc info lab params (concat nat_blocks)
+ proc' <- case picBaseMb of
+ Just picBase -> initializePicCodeGen picBase proc
+ Nothing -> return proc
+ return (proc' : concat statics)
+
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat] -- no translation, we just use CmmStatic
@@ -1370,6 +1376,46 @@
addr_code `snocOL` LD pk dst addr
return (Any pk code)
+
+getRegister (CmmLit (CmmInt i rep))
+ | Just imm <- makeImmediate rep True i
+ = let
+ code dst = unitOL (LI dst imm)
+ in
+ return (Any rep code)
+
+getRegister (CmmLit (CmmFloat f frep)) = do
+ lbl <- getNewLabelNat
+ Amode addr addr_code <- getAmode (CmmLit $ CmmLabel lbl)
+ let code dst =
+ LDATA ReadOnlyData [CmmDataLabel lbl,
+ CmmStaticLit (CmmFloat f frep)]
+ `consOL` (addr_code `snocOL` LD frep dst addr)
+ return (Any frep code)
+
+getRegister (CmmLit (CmmLabel lbl))
+ = do
+ (code, lo) <- picLabelCode lbl 0
+ let code' dst = code dst `snocOL` ADD dst dst (RIImm lo)
+ return (Any I32 code')
+
+getRegister (CmmLit (CmmLabelOff lbl off))
+ = do
+ (code, lo) <- picLabelCode lbl off
+ let code' dst = code dst `snocOL` ADD dst dst (RIImm lo)
+ return (Any I32 code')
+
+getRegister (CmmLit lit)
+ = let
+ rep = cmmLitRep lit
+ imm = litToImm lit
+ code dst = toOL [
+ LIS dst (HI imm),
+ OR dst dst (RIImm (LO imm))
+ ]
+ in
+ return (Any rep code)
+
-- catch simple cases of zero- or sign-extended load
getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode mem
@@ -1489,60 +1535,6 @@
MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y
MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y
-getRegister (CmmLit (CmmInt i rep))
- | Just imm <- makeImmediate rep True i
- = let
- code dst = unitOL (LI dst imm)
- in
- return (Any rep code)
-
-getRegister (CmmLit (CmmFloat f F32)) = do
- lbl <- getNewLabelNat
- tmp <- getNewRegNat I32
- let code dst = toOL [
- LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat f F32)],
- LIS tmp (HA (ImmCLbl lbl)),
- LD F32 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
- ]
- -- in
- return (Any F32 code)
-
-getRegister (CmmLit (CmmFloat d F64)) = do
- lbl <- getNewLabelNat
- tmp <- getNewRegNat I32
- let code dst = toOL [
- LDATA ReadOnlyData [CmmDataLabel lbl,
- CmmStaticLit (CmmFloat d F64)],
- LIS tmp (HA (ImmCLbl lbl)),
- LD F64 dst (AddrRegImm tmp (LO (ImmCLbl lbl)))
- ]
- -- in
- return (Any F32 code)
-
-#if darwin_TARGET_OS
-getRegister (CmmLit (CmmLabel lbl))
- | labelCouldBeDynamic lbl
- = do
- addImportNat False lbl
- let imm = ImmDyldNonLazyPtr lbl
- code dst = toOL [
- LIS dst (HA imm),
- LD I32 dst (AddrRegImm dst (LO imm))
- ]
- return (Any I32 code)
-#endif
-
-getRegister (CmmLit lit)
- = let
- rep = cmmLitRep lit
- imm = litToImm lit
- code dst = toOL [
- LIS dst (HI imm),
- OR dst dst (RIImm (LO imm))
- ]
- in
- return (Any rep code)
getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
-- extend?Rep: wrap integer expression of type rep
@@ -1565,6 +1557,27 @@
Fixed _ reg code ->
return (reg, code)
+picLabelCode :: CLabel -> Int -> NatM (Reg -> InstrBlock, Imm)
+
+picLabelCode lbl off
+ = do
+ case importedLabelInfo lbl of
+ Just (lbl', isCode) -> addImportNat isCode lbl'
+ Nothing -> return ()
+
+ case opt_PIC of
+ False -> do
+ let imm | off == 0 = ImmCLbl lbl
+ | otherwise = ImmIndex lbl off
+ let code dst = unitOL $ LIS dst (HA imm)
+ return (code, LO imm)
+ True -> do
+ (reg, baseLabel) <- getPicBaseNat wordRep
+ let imm = ImmConstantDiff (ImmCLbl lbl) (ImmCLbl baseLabel)
+ imm' | off == 0 = imm
+ | otherwise = ImmConstantSum imm (ImmInt off)
+ code dst = unitOL $ ADDIS dst reg (HA imm')
+ return (code, LO imm')
#endif /* powerpc_TARGET_ARCH */
@@ -1760,6 +1773,18 @@
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
+getAmode (CmmLit (CmmLabel lbl))
+ = do
+ tmp <- getNewRegNat I32
+ (code,lo) <- picLabelCode lbl 0
+ return (Amode (AddrRegImm tmp lo) (code tmp))
+
+getAmode (CmmLit (CmmLabelOff lbl off))
+ = do
+ tmp <- getNewRegNat I32
+ (code,lo) <- picLabelCode lbl off
+ return (Amode (AddrRegImm tmp lo) (code tmp))
+
getAmode (CmmLit lit)
= do
tmp <- getNewRegNat I32
@@ -2444,7 +2469,11 @@
#if powerpc_TARGET_ARCH
genJump (CmmLit (CmmLabel lbl))
- = return (unitOL $ JMP lbl)
+ = do
+ case importedLabelInfo lbl of
+ Just (lbl', True) -> addImportNat True lbl'
+ Nothing -> return ()
+ return (unitOL $ JMP lbl)
genJump tree
= do
@@ -3147,7 +3176,9 @@
case labelOrExpr of
Left lbl -> do
- addImportNat True lbl
+ case importedLabelInfo lbl of
+ Just (lbl', True) -> addImportNat True lbl'
+ Nothing -> return ()
return ( codeBefore
`snocOL` BL lbl usedRegs
`appOL` codeAfter)
@@ -3286,9 +3317,15 @@
(labelOrExpr, reduceToF32) = case target of
CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> (Left lbl, False)
CmmForeignCall expr conv -> (Right expr, False)
- CmmPrim mop -> (Left $ mkForeignLabel label Nothing False, reduce)
+ CmmPrim mop -> (Left label, reduce)
where
- (label, reduce) = case mop of
+ label =
+#if darwin_TARGET_OS
+ mkImportedCodeStubLabel $
+#endif
+ mkForeignLabel functionName Nothing False
+
+ (functionName, reduce) = case mop of
MO_F32_Exp -> (FSLIT("exp"), True)
MO_F32_Log -> (FSLIT("log"), True)
MO_F32_Sqrt -> (FSLIT("sqrt"), True)
@@ -3349,23 +3386,41 @@
-- in
return code
#elif powerpc_TARGET_ARCH
-genSwitch expr ids = do
- (reg,e_code) <- getSomeReg expr
- tmp <- getNewRegNat I32
- lbl <- getNewLabelNat
- let
- jumpTable = map jumpTableEntry ids
-
- code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
- SLW tmp reg (RIImm (ImmInt 2)),
- ADDIS tmp tmp (HA (ImmCLbl lbl)),
- LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
- MTCTR tmp,
- BCTR [ id | Just id <- ids ]
- ]
- -- in
- return code
+genSwitch expr ids
+ | opt_PIC
+ = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ (tableReg,t_code) <- getSomeReg $ CmmLit $ CmmLabel lbl
+ let
+ jumpTable = map jumpTableEntry ids
+
+ code = e_code `appOL` t_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ LD I32 tmp (AddrRegReg tableReg tmp),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ return code
+ | otherwise
+ = do
+ (reg,e_code) <- getSomeReg expr
+ tmp <- getNewRegNat I32
+ lbl <- getNewLabelNat
+ let
+ jumpTable = map jumpTableEntry ids
+
+ code = e_code `appOL` toOL [
+ LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ SLW tmp reg (RIImm (ImmInt 2)),
+ ADDIS tmp tmp (HA (ImmCLbl lbl)),
+ LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
+ MTCTR tmp,
+ BCTR [ id | Just id <- ids ]
+ ]
+ return code
#else
genSwitch expr ids = panic "ToDo: genSwitch"
#endif
@@ -4148,6 +4203,7 @@
lbl <- getNewLabelNat
itmp <- getNewRegNat I32
ftmp <- getNewRegNat F64
+ Amode addr addr_code <- getAmode $ CmmLit $ CmmLabel lbl
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA ReadOnlyData
@@ -4158,9 +4214,9 @@
ST I32 itmp (spRel 3),
LIS itmp (ImmInt 0x4330),
ST I32 itmp (spRel 2),
- LD F64 ftmp (spRel 2),
- LIS itmp (HA (ImmCLbl lbl)),
- LD F64 dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
+ LD F64 ftmp (spRel 2)
+ ] `appOL` addr_code `appOL` toOL [
+ LD F64 dst addr,
FSUB F64 dst ftmp dst
] `appOL` maybe_frsp dst
@@ -4201,4 +4257,13 @@
eXTRA_STK_ARGS_HERE :: Int
eXTRA_STK_ARGS_HERE
= IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???))
+#endif
+
+#if darwin_TARGET_OS
+initializePicCodeGen (picReg, picLabel) (CmmProc info lab params blocks)
+ = return $ CmmProc info lab params (b':tail blocks)
+ where BasicBlock bID insns = head blocks
+ b' = BasicBlock bID (FETCHPC picReg picLabel : insns)
+#else
+initializePicCodeGen (picReg, picLabel) proc = panic "initializePicCodeGen"
#endif
Index: ghc/compiler/nativeGen/MachInstrs.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/Attic/MachInstrs.hs,v
retrieving revision 1.1.2.23
diff -u -r1.1.2.23 MachInstrs.hs
--- ghc/compiler/nativeGen/MachInstrs.hs 19 Jun 2004 21:33:17 -0000 1.1.2.23
+++ ghc/compiler/nativeGen/MachInstrs.hs 7 Jul 2004 09:53:37 -0000
@@ -661,6 +661,9 @@
| CRNOR Int Int Int -- condition register nor
| MFCR Reg -- move from condition register
+ | FETCHPC Reg CLabel -- pseudo-instruction:
+ -- bcl to next insn, mflr reg
+
condUnsigned GU = True
condUnsigned LU = True
condUnsigned GEU = True
Index: ghc/compiler/nativeGen/MachRegs.lhs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/MachRegs.lhs,v
retrieving revision 1.50.2.16
diff -u -r1.50.2.16 MachRegs.lhs
--- ghc/compiler/nativeGen/MachRegs.lhs 10 Mar 2004 10:25:30 -0000 1.50.2.16
+++ ghc/compiler/nativeGen/MachRegs.lhs 7 Jul 2004 09:53:38 -0000
@@ -107,6 +107,8 @@
| ImmIndex CLabel Int
| ImmFloat Rational
| ImmDouble Rational
+ | ImmConstantSum Imm Imm
+ | ImmConstantDiff Imm Imm
#if sparc_TARGET_ARCH
| LO Imm {- Possible restrictions... -}
| HI Imm
@@ -115,10 +117,6 @@
| LO Imm
| HI Imm
| HA Imm {- high halfword adjusted -}
-#if darwin_TARGET_OS
- -- special dyld (dynamic linker) things
- | ImmDyldNonLazyPtr CLabel -- Llabel$non_lazy_ptr
-#endif
#endif
strImmLit s = ImmLit (text s)
@@ -128,6 +126,10 @@
litToImm (CmmFloat f F64) = ImmDouble f
litToImm (CmmLabel l) = ImmCLbl l
litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off)
+ = ImmConstantSum
+ (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+ (ImmInt off)
-- -----------------------------------------------------------------------------
-- Addressing modes
Index: ghc/compiler/nativeGen/NCGMonad.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/Attic/NCGMonad.hs,v
retrieving revision 1.1.2.5
diff -u -r1.1.2.5 NCGMonad.hs
--- ghc/compiler/nativeGen/NCGMonad.hs 10 Mar 2004 10:25:31 -0000 1.1.2.5
+++ ghc/compiler/nativeGen/NCGMonad.hs 7 Jul 2004 09:53:38 -0000
@@ -13,6 +13,7 @@
initNat, addImportNat, getUniqueNat,
mapAccumLNat, setDeltaNat, getDeltaNat,
getBlockIdNat, getNewLabelNat, getNewRegNat, getNewRegPairNat,
+ getPicBaseMaybeNat, getPicBaseNat
) where
#include "HsVersions.h"
@@ -28,7 +29,8 @@
data NatM_State = NatM_State {
natm_us :: UniqSupply,
natm_delta :: Int,
- natm_imports :: [(Bool,CLabel)]
+ natm_imports :: [(Bool,CLabel)],
+ natm_pic :: Maybe (Reg, CLabel)
}
newtype NatM result = NatM (NatM_State -> (result, NatM_State))
@@ -36,7 +38,7 @@
unNat (NatM a) = a
mkNatM_State :: UniqSupply -> Int -> NatM_State
-mkNatM_State us delta = NatM_State us delta []
+mkNatM_State us delta = NatM_State us delta [] Nothing
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) }
@@ -66,20 +68,20 @@
return (b__3, x__2:xs__2)
getUniqueNat :: NatM Unique
-getUniqueNat = NatM $ \ (NatM_State us delta imports) ->
+getUniqueNat = NatM $ \ (NatM_State us delta imports pic) ->
case splitUniqSupply us of
- (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports))
+ (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic))
getDeltaNat :: NatM Int
getDeltaNat = NatM $ \ st -> (natm_delta st, st)
setDeltaNat :: Int -> NatM ()
-setDeltaNat delta = NatM $ \ (NatM_State us _ imports) ->
- ((), NatM_State us delta imports)
+setDeltaNat delta = NatM $ \ (NatM_State us _ imports pic) ->
+ ((), NatM_State us delta imports pic)
addImportNat :: Bool -> CLabel -> NatM ()
-addImportNat is_code imp = NatM $ \ (NatM_State us delta imports) ->
- ((), NatM_State us delta ((is_code,imp):imports))
+addImportNat is_code imp = NatM $ \ (NatM_State us delta imports pic) ->
+ ((), NatM_State us delta ((is_code,imp):imports) pic)
getBlockIdNat :: NatM BlockId
getBlockIdNat = do u <- getUniqueNat; return (BlockId u)
@@ -96,3 +98,15 @@
let lo = mkVReg u rep; hi = getHiVRegFromLo lo
return (lo,hi)
+getPicBaseMaybeNat :: NatM (Maybe (Reg, CLabel))
+getPicBaseMaybeNat = NatM (\state -> (natm_pic state, state))
+
+getPicBaseNat :: MachRep -> NatM (Reg, CLabel)
+getPicBaseNat rep = do
+ mbPicBase <- getPicBaseMaybeNat
+ case mbPicBase of
+ Just picBase -> return picBase
+ Nothing -> do
+ reg <- getNewRegNat rep
+ lbl <- getNewLabelNat
+ NatM (\state -> ((reg,lbl), state { natm_pic = Just (reg,lbl) }))
Index: ghc/compiler/nativeGen/PprMach.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/Attic/PprMach.hs,v
retrieving revision 1.1.2.30
diff -u -r1.1.2.30 PprMach.hs
--- ghc/compiler/nativeGen/PprMach.hs 19 Jun 2004 21:33:16 -0000 1.1.2.30
+++ ghc/compiler/nativeGen/PprMach.hs 7 Jul 2004 09:53:39 -0000
@@ -37,6 +37,8 @@
import FastString
import qualified Outputable
+import CmdLineOpts ( opt_PIC )
+
#if __GLASGOW_HASKELL__ >= 504
import Data.Array.ST
import Data.Word ( Word8 )
@@ -66,6 +68,14 @@
-- special case for split markers:
pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
+ -- For PIC code, we have to put vector tables into
+ -- the writable Data section.
+pprNatCmmTop (CmmProc info lbl params [])
+ | opt_PIC
+ = pprSectionHeader Data $$
+ vcat (map pprData info) $$
+ pprLabel (entryLblToInfoLbl lbl)
+
pprNatCmmTop (CmmProc info lbl params blocks) =
pprSectionHeader Text $$
(if not (null info)
@@ -378,15 +388,17 @@
pprImm (ImmInt i) = int i
pprImm (ImmInteger i) = integer i
-pprImm (ImmCLbl l) = (if labelDynamic l then text "__imp_" else empty)
- <> pprCLabel_asm l
-pprImm (ImmIndex l i) = (if labelDynamic l then text "__imp_" else empty)
- <> pprCLabel_asm l <> char '+' <> int i
+pprImm (ImmCLbl l) = pprCLabel_asm l
+pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i
pprImm (ImmLit s) = s
pprImm (ImmFloat _) = panic "pprImm:ImmFloat"
pprImm (ImmDouble _) = panic "pprImm:ImmDouble"
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+ <> lparen <> pprImm b <> rparen
+
#if sparc_TARGET_ARCH
pprImm (LO i)
= hcat [ pp_lo, pprImm i, rparen ]
@@ -415,9 +427,6 @@
where
pp_ha = text "ha16("
-pprImm (ImmDyldNonLazyPtr lbl)
- = ptext SLIT("L") <> pprCLabel_asm lbl <> ptext SLIT("$non_lazy_ptr")
-
#else
pprImm (LO i)
= pprImm i <> text "@l"
@@ -1958,9 +1967,8 @@
ptext SLIT("bctr")
]
pprInstr (BL lbl _) = hcat [
- ptext SLIT("\tbl\tL"),
- pprCLabel_asm lbl,
- ptext SLIT("$stub")
+ ptext SLIT("\tbl\t"),
+ pprCLabel_asm lbl
]
pprInstr (BCTRL _) = hcat [
char '\t',
@@ -2089,6 +2097,12 @@
pprReg reg
]
+pprInstr (FETCHPC reg lbl) = vcat [
+ hcat [ ptext SLIT("\tbcl\t20,31,"), pprCLabel_asm lbl ],
+ pprCLabel_asm lbl <> char ':',
+ hcat [ ptext SLIT("\tmflr\t"), pprReg reg ]
+ ]
+
pprInstr _ = panic "pprInstr (ppc)"
pprLogic op reg1 reg2 ri = hcat [
@@ -2150,16 +2164,41 @@
#if darwin_TARGET_OS
pprDyldSymbolStub (True, lbl) =
- vcat [
- ptext SLIT(".symbol_stub"),
- ptext SLIT("L") <> pprLbl <> ptext SLIT("$stub:"),
- ptext SLIT("\t.indirect_symbol") <+> pprLbl,
- ptext SLIT("\tlis r11,ha16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)"),
- ptext SLIT("\tlwz r12,lo16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)(r11)"),
- ptext SLIT("\tmtctr r12"),
- ptext SLIT("\taddi r11,r11,lo16(L") <> pprLbl <> ptext SLIT("$lazy_ptr)"),
- ptext SLIT("\tbctr"),
- ptext SLIT(".lazy_symbol_pointer"),
+ case opt_PIC of
+ False ->
+ vcat [
+ ptext SLIT(".symbol_stub"),
+ ptext SLIT("L") <> pprLbl <> ptext SLIT("$stub:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprLbl,
+ ptext SLIT("\tlis r11,ha16(L") <> pprLbl
+ <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tlwz r12,lo16(L") <> pprLbl
+ <> ptext SLIT("$lazy_ptr)(r11)"),
+ ptext SLIT("\tmtctr r12"),
+ ptext SLIT("\taddi r11,r11,lo16(L") <> pprLbl
+ <> ptext SLIT("$lazy_ptr)"),
+ ptext SLIT("\tbctr")
+ ]
+ True ->
+ vcat [
+ ptext SLIT(".section __TEXT,__picsymbolstub1,symbol_stubs,pure_instructions,32"),
+ ptext SLIT("L") <> pprLbl <> ptext SLIT("$stub:"),
+ ptext SLIT("\t.indirect_symbol") <+> pprLbl,
+ ptext SLIT("\tmflr r0"),
+ ptext SLIT("\tbcl 20,31,L0$") <> pprLbl,
+ ptext SLIT("L0$") <> pprLbl <> char ':',
+ ptext SLIT("\tmflr r11"),
+ ptext SLIT("\taddis r11,r11,ha16(L") <> pprLbl
+ <> ptext SLIT("$lazy_ptr-L0$") <> pprLbl <> char ')',
+ ptext SLIT("\tmtlr r0"),
+ ptext SLIT("\tlwzu r12,lo16(L") <> pprLbl
+ <> ptext SLIT("$lazy_ptr-L0$") <> pprLbl
+ <> ptext SLIT(")(r11)"),
+ ptext SLIT("\tmtctr r12"),
+ ptext SLIT("\tbctr")
+ ]
+ $+$ vcat [
+ ptext SLIT(".lazy_symbol_pointer"),
ptext SLIT("L") <> pprLbl <> ptext SLIT("$lazy_ptr:"),
ptext SLIT("\t.indirect_symbol") <+> pprLbl,
ptext SLIT("\t.long dyld_stub_binding_helper")
Index: ghc/compiler/nativeGen/RegAllocInfo.hs
===================================================================
RCS file: /home/cvs/root/fptools/ghc/compiler/nativeGen/Attic/RegAllocInfo.hs,v
retrieving revision 1.1.2.20
diff -u -r1.1.2.20 RegAllocInfo.hs
--- ghc/compiler/nativeGen/RegAllocInfo.hs 19 Jun 2004 21:52:10 -0000 1.1.2.20
+++ ghc/compiler/nativeGen/RegAllocInfo.hs 7 Jul 2004 09:53:40 -0000
@@ -344,6 +344,7 @@
FCTIWZ r1 r2 -> usage ([r2], [r1])
FRSP r1 r2 -> usage ([r2], [r1])
MFCR reg -> usage ([], [reg])
+ FETCHPC reg lbl -> usage ([], [reg])
_ -> noUsage
where
usage (src, dst) = RU (filter interesting src)
@@ -621,6 +622,7 @@
FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2)
FRSP r1 r2 -> FRSP (env r1) (env r2)
MFCR reg -> MFCR (env reg)
+ FETCHPC reg lbl -> FETCHPC (env reg) lbl
_ -> instr
where
fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
Index: ghc/driver/mangler/ghc-asm.lprl
===================================================================
RCS file: /home/cvs/root/fptools/ghc/driver/mangler/ghc-asm.lprl,v
retrieving revision 1.106.2.3
diff -u -r1.106.2.3 ghc-asm.lprl
--- ghc/driver/mangler/ghc-asm.lprl 2 Apr 2004 15:31:32 -0000 1.106.2.3
+++ ghc/driver/mangler/ghc-asm.lprl 7 Jul 2004 09:53:41 -0000
@@ -301,6 +301,7 @@
$T_HDR_info = "\t\.text\n\t\.align 2\n";
$T_HDR_entry = "\t\.text\n\t\.align 2\n";
$T_HDR_vector = "\t\.text\n\t\.align 2\n";
+ $T_HDR_vecinfo = "\t\.data\n\t\.align 2\n"; # ### writable for PIC
#--------------------------------------------------------#
} elsif ( $TargetPlatform =~ /^powerpc-.*-linux/ ) {
@@ -561,6 +562,11 @@
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^${T_US}(stg_ap_stack_entries|stg_stack_save_entries|stg_arg_bitmaps)${T_POST_LBL}$/o ) {
+ $chk[++$i] = $_;
+ $chkcat[$i] = 'data';
+ $chksymb[$i] = '';
+
} elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
; # toss it
@@ -1074,7 +1080,18 @@
# INFO TABLE
if ( defined($infochk{$symb}) ) {
- print OUTASM $T_HDR_info;
+ if ( defined($entrychk{$symb}) ) {
+ if ( $symb =~ /^(stg_ap_0|stg_catch_frame|stg_ctoi_ret_R1p|stg_stop_thread|stg_upd_frame|stg_seq_frame)/ ) {
+ ### HACK: special case for a few known polymorphic returns:
+ # put them in the same place as vector tables, which should be
+ # relocatable (=writable on most platforms)
+ print OUTASM $T_HDR_vecinfo;
+ } else {
+ print OUTASM $T_HDR_info;
+ }
+ } else {
+ print OUTASM $T_HDR_vecinfo;
+ }
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will be put here!
@@ -1087,8 +1104,12 @@
$c = $chk[$entrychk{$symb}];
- print OUTASM $T_HDR_entry;
-
+ if ( $symb =~ /^(stg_ap_0|stg_catch_frame|stg_ctoi_ret_R1p|stg_stop_thread|stg_upd_frame|stg_seq_frame)/ ) {
+ ### HACK: special case for a few known polymorphic returns:
+ # make sure we're in the same section as the info table
+ } else {
+ print OUTASM $T_HDR_entry;
+ }
&print_doctored($c, 1); # NB: the 1!!!
$chkcat[$entrychk{$symb}] = 'DONE ALREADY';
@@ -1350,10 +1371,19 @@
# Grab the table data...
if ( $TargetPlatform !~ /^hppa/ ) {
for ( ; $i <= $#lines && $lines[$i] =~ /^\t?${T_DOT_WORD}\s+/o; $i++) {
- push(@words, $lines[$i]);
+ $line = $lines[$i];
+ # Convert addresses of SRTs, slow entrypoints and large bitmaps
+ # to offsets (relative to the info label),
+ # in order to support position independent code.
+ $line =~ s/([A-Za-z0-9_]+)_srt/\1_srt - \1_info/;
+ $line =~ s/([A-Za-z0-9_]+)_slow/\1_slow - \1_info/;
+ $line =~ s/([A-Za-z0-9_]+)_btm/\1_btm - \1_info/;
+ push(@words, $line);
}
} else { # hppa weirdness
for ( ; $i <= $#lines && $lines[$i] =~ /^\s+(${T_DOT_WORD}|\.IMPORT)/; $i++) {
+ # FIXME: the RTS now expects offsets instead of addresses
+ # for _srt, _slow and _btm labels.
if ($lines[$i] =~ /^\s+\.IMPORT/) {
push(@imports, $lines[$i]);
} else {
Index: ghc/includes/InfoMacros.h
===================================================================
RCS file: /home/cvs/root/fptools/ghc/includes/InfoMacros.h,v
retrieving revision 1.22
diff -u -r1.22 InfoMacros.h
--- ghc/includes/InfoMacros.h 14 May 2003 09:14:01 -0000 1.22
+++ ghc/includes/InfoMacros.h 7 Jul 2004 09:53:42 -0000
@@ -14,13 +14,28 @@
srt_bitmap : srt_bitmap_, \
type : type_
+#ifdef TABLES_NEXT_TO_CODE
+ // Will be converted to an offset by the Mangler
+#define INIT_SRT_FIELD(srt_) srt_offset : (StgWord) srt_
+#else
+#define INIT_SRT_FIELD(srt_) srt : srt_
+#endif
+
+#ifdef TABLES_NEXT_TO_CODE
+ // Will be converted to an offset by the Mangler
+#define INIT_SLOW_APPLY(slow_apply_) slow_apply_offset : (StgWord) slow_apply_
+#else
+#define INIT_SLOW_APPLY(slow_apply_) slow_apply : slow_apply_
+#endif
+
+
#define THUNK_INFO(srt_, srt_off_) \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_)
+ INIT_SRT_FIELD( (StgSRT *)((StgClosure **)srt_+srt_off_))
#define FUN_GEN_INFO(srt_, srt_off_, fun_type_, arity_, bitmap_, slow_apply_) \
#define RET_INFO(srt_, srt_off_) \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_)
+ INIT_SRT_FIELD( (StgSRT *)((StgClosure **)srt_+srt_off_))
#ifdef PROFILING
#define PROF_INFO(type_str, desc_str) \
@@ -289,11 +304,11 @@
STD_INFO(srt_bitmap_,type_), \
INIT_ENTRY(entry) \
}, \
- srt : (StgSRT *)((StgClosure **)srt_+srt_off_), \
+ INIT_SRT_FIELD((StgSRT *)((StgClosure **)srt_+srt_off_)),\
arity : arity_, \
fun_type : fun_type_, \
bitmap : (W_)bitmap_, \
- slow_apply : slow_apply_ \
+ INIT_SLOW_APPLY( slow_apply_ ) \
}
/* return-vectors ----------------------------------------------------------*/
@@ -687,6 +702,36 @@
#define DLL_SRT_ENTRY(x) ((StgClosure*)(((char*)&DLL_IMPORT_DATA_VAR(x)) + 1))
#else
#define DLL_SRT_ENTRY(x) no-can-do
+#endif
+
+// GET_SRT(info)
+// info must be a Stg[Fun|Ret|Thunk]InfoTable* (an info table that has a SRT)
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_SRT(info) ((StgSRT*) (((StgWord) ((info)+1)) + (info)->srt_offset))
+#else
+#define GET_SRT(info) ((info)->srt)
+#endif
+
+// GET_SLOW_APPLY(StgFuninfoTable* info)
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_SLOW_APPLY(info) ((StgFun*) (((StgWord) ((info)+1)) \
+ + (info)->slow_apply_offset))
+#else
+#define GET_SLOW_APPLY(info) ((info)->slow_apply)
+#endif
+
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+ + (info)->layout.large_bitmap_offset))
+#else
+#define GET_LARGE_BITMAP(info) ((info)->layout.large_bitmap)
+#endif
+
+#ifdef TABLES_NEXT_TO_CODE
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+ + (info)->bitmap))
+#else
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) ((info)->bitmap))
#endif
#endif /* INFOMACROS_H */
Index: ghc/includes/InfoTables.h
===================================================================
RCS file: /home/cvs/root/fptools/ghc/includes/InfoTables.h,v
retrieving revision 1.32.2.1
diff -u -r1.32.2.1 InfoTables.h
--- ghc/includes/InfoTables.h 29 Jan 2004 09:21:45 -0000 1.32.2.1
+++ ghc/includes/InfoTables.h 7 Jul 2004 09:53:42 -0000
@@ -230,7 +230,11 @@
StgWord bitmap; // word-sized bit pattern describing
// a stack frame: see below
+#ifndef TABLES_NEXT_TO_CODE
StgLargeBitmap* large_bitmap; // pointer to large bitmap structure
+#else
+ StgWord large_bitmap_offset; // offset from info table to large bitmap structure
+#endif
StgWord selector_offset; // used in THUNK_SELECTORs
@@ -287,9 +291,9 @@
typedef struct _StgFunInfoTable {
#if defined(TABLES_NEXT_TO_CODE)
- StgFun *slow_apply; // apply to args on the stack
+ StgWord slow_apply_offset; // apply to args on the stack
StgWord bitmap; // arg ptr/nonptr bitmap
- StgSRT *srt; // pointer to the SRT table
+ StgWord srt_offset; // offset to the SRT table
StgHalfWord fun_type; // function type
StgHalfWord arity; // function arity
StgInfoTable i;
@@ -312,7 +316,7 @@
typedef struct _StgRetInfoTable {
#if defined(TABLES_NEXT_TO_CODE)
- StgSRT *srt; // pointer to the SRT table
+ StgWord srt_offset; // offset to the SRT table
StgInfoTable i;
#else
StgInfoTable i;
@@ -332,7 +336,11 @@
#if !defined(TABLES_NEXT_TO_CODE)
StgInfoTable i;
#endif
+#if defined(TABLES_NEXT_TO_CODE)
+ StgWord srt_offset; // offset to the SRT table
+#else
StgSRT *srt; // pointer to the SRT table
+#endif
#if defined(TABLES_NEXT_TO_CODE)
StgInfoTable i;
#endif
Index: ghc/rts/Adjustor.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/Adjustor.c,v
retrieving revision 1.27
diff -u -r1.27 Adjustor.c
--- ghc/rts/Adjustor.c 28 Dec 2003 13:02:46 -0000 1.27
+++ ghc/rts/Adjustor.c 7 Jul 2004 09:53:42 -0000
@@ -84,8 +84,8 @@
}
-static unsigned char __obscure_ccall_ret_code [] =
#if defined(i386_TARGET_ARCH)
+static unsigned char __obscure_ccall_ret_code [] =
/* Now here's something obscure for you:
When generating an adjustor thunk that uses the C calling
@@ -110,7 +110,6 @@
};
#else
/* No such mind-twisters on non-Intel platforms */
- { };
#endif
#if defined(alpha_TARGET_ARCH)
@@ -584,5 +583,9 @@
rtsBool
initAdjustor(void)
{
+#if defined(i386_TARGET_ARCH)
return execPage(__obscure_ccall_ret_code, rtsFalse);
+#else
+ return rtsTrue;
+#endif
}
Index: ghc/rts/Apply.hc
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/Apply.hc,v
retrieving revision 1.5
diff -u -r1.5 Apply.hc
--- ghc/rts/Apply.hc 10 Mar 2003 13:27:34 -0000 1.5
+++ ghc/rts/Apply.hc 7 Jul 2004 09:53:42 -0000
@@ -126,7 +126,7 @@
StgFunInfoTable *info;
info = get_fun_itbl(R1.cl);
if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
- JMP_(info->slow_apply);
+ JMP_(GET_SLOW_APPLY(info));
} else if (info->fun_type == ARG_BCO) {
Sp -= 2;
Sp[1] = R1.w;
@@ -194,7 +194,7 @@
StgFunInfoTable *info;
info = get_fun_itbl(R1.cl);
if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
- JMP_(info->slow_apply);
+ JMP_(GET_SLOW_APPLY(info));
} else if (info->fun_type == ARG_BCO) {
Sp -= 2;
Sp[1] = R1.w;
Index: ghc/rts/GC.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/GC.c,v
retrieving revision 1.164.2.1
diff -u -r1.164.2.1 GC.c
--- ghc/rts/GC.c 23 Apr 2004 15:36:37 -0000 1.164.2.1
+++ ghc/rts/GC.c 7 Jul 2004 09:53:45 -0000
@@ -2268,7 +2268,7 @@
StgThunkInfoTable *thunk_info;
thunk_info = itbl_to_thunk_itbl(info);
- scavenge_srt((StgClosure **)thunk_info->srt, thunk_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(thunk_info), thunk_info->i.srt_bitmap);
}
STATIC_INLINE void
@@ -2277,7 +2277,7 @@
StgFunInfoTable *fun_info;
fun_info = itbl_to_fun_itbl(info);
- scavenge_srt((StgClosure **)fun_info->srt, fun_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(fun_info), fun_info->i.srt_bitmap);
}
STATIC_INLINE void
@@ -2286,7 +2286,7 @@
StgRetInfoTable *ret_info;
ret_info = itbl_to_ret_itbl(info);
- scavenge_srt((StgClosure **)ret_info->srt, ret_info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(ret_info), ret_info->i.srt_bitmap);
}
/* -----------------------------------------------------------------------------
@@ -2336,8 +2336,8 @@
size = BITMAP_SIZE(fun_info->bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->bitmap)->size;
- scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
default:
@@ -2376,7 +2376,7 @@
bitmap = BITMAP_BITS(fun_info->bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- scavenge_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ scavenge_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
case ARG_BCO:
@@ -3739,7 +3739,7 @@
p = scavenge_small_bitmap(p, size, bitmap);
follow_srt:
- scavenge_srt((StgClosure **)info->srt, info->i.srt_bitmap);
+ scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
continue;
case RET_BCO: {
@@ -3762,9 +3762,9 @@
{
nat size;
- size = info->i.layout.large_bitmap->size;
+ size = GET_LARGE_BITMAP(&info->i)->size;
p++;
- scavenge_large_bitmap(p, info->i.layout.large_bitmap, size);
+ scavenge_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
p += size;
// and don't forget to follow the SRT
goto follow_srt;
Index: ghc/rts/GCCompact.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/GCCompact.c,v
retrieving revision 1.18
diff -u -r1.18 GCCompact.c
--- ghc/rts/GCCompact.c 12 Nov 2003 17:49:07 -0000 1.18
+++ ghc/rts/GCCompact.c 7 Jul 2004 09:53:45 -0000
@@ -220,8 +220,8 @@
size = BITMAP_SIZE(fun_info->bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->bitmap)->size;
- thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
default:
@@ -329,8 +329,8 @@
case RET_BIG:
case RET_VEC_BIG:
p++;
- size = info->i.layout.large_bitmap->size;
- thread_large_bitmap(p, info->i.layout.large_bitmap, size);
+ size = GET_LARGE_BITMAP(&info->i)->size;
+ thread_large_bitmap(p, GET_LARGE_BITMAP(&info->i), size);
p += size;
continue;
@@ -372,7 +372,7 @@
bitmap = BITMAP_BITS(fun_info->bitmap);
goto small_bitmap;
case ARG_GEN_BIG:
- thread_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap, size);
+ thread_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), size);
p += size;
break;
case ARG_BCO:
Index: ghc/rts/HeapStackCheck.hc
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/HeapStackCheck.hc,v
retrieving revision 1.31
diff -u -r1.31 HeapStackCheck.hc
--- ghc/rts/HeapStackCheck.hc 14 May 2003 09:13:59 -0000 1.31
+++ ghc/rts/HeapStackCheck.hc 7 Jul 2004 09:53:45 -0000
@@ -718,7 +718,7 @@
if (info->fun_type == ARG_GEN) {
size = BITMAP_SIZE(info->bitmap);
} else if (info->fun_type == ARG_GEN_BIG) {
- size = ((StgLargeBitmap *)info->bitmap)->size;
+ size = GET_FUN_LARGE_BITMAP(info)->size;
} else {
size = BITMAP_SIZE(stg_arg_bitmaps[info->fun_type]);
}
@@ -778,7 +778,7 @@
if (info->fun_type == ARG_GEN || info->fun_type == ARG_GEN_BIG) {
// regs already saved by the heap check code
DEBUG_ONLY(fprintf(stderr, "stg_gc_fun_ret(ARG_GEN)\n"););
- JMP_(info->slow_apply);
+ JMP_(GET_SLOW_APPLY(info));
} else if (info->fun_type == ARG_BCO) {
// cover this case just to be on the safe side
Sp -= 2;
Index: ghc/rts/Linker.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/Linker.c,v
retrieving revision 1.143.2.4
diff -u -r1.143.2.4 Linker.c
--- ghc/rts/Linker.c 2 Apr 2004 15:31:34 -0000 1.143.2.4
+++ ghc/rts/Linker.c 7 Jul 2004 09:53:47 -0000
@@ -3615,14 +3615,24 @@
static void machoInitSymbolsWithoutUnderscore()
{
- void *p;
+ extern void* symbolsWithoutUnderscore[];
+ void **p = symbolsWithoutUnderscore;
+ __asm__ volatile(".data\n_symbolsWithoutUnderscore:");
+
+#undef Sym
+#define Sym(x) \
+ __asm__ volatile(".long " # x);
-#undef Sym
-#define Sym(x) \
- __asm__ ("lis %0,hi16(" #x ")\n\tori %0,%0,lo16(" #x ")" : "=r" (p)); \
- ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, p);
-
RTS_MACHO_NOUNDERLINE_SYMBOLS
+ __asm__ volatile(".text");
+
+#undef Sym
+#define Sym(x) \
+ ghciInsertStrHashTable("(GHCi built-in symbols)", symhash, #x, *p++);
+
+ RTS_MACHO_NOUNDERLINE_SYMBOLS
+
+#undef Sym
}
#endif
Index: ghc/rts/Printer.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/Printer.c,v
retrieving revision 1.62
diff -u -r1.62 Printer.c
--- ghc/rts/Printer.c 12 Nov 2003 17:49:08 -0000 1.62
+++ ghc/rts/Printer.c 7 Jul 2004 09:53:48 -0000
@@ -617,7 +617,7 @@
break;
case ARG_GEN_BIG:
printLargeBitmap(spBottom, sp+2,
- (StgLargeBitmap *)fun_info->bitmap,
+ GET_FUN_LARGE_BITMAP(fun_info),
BITMAP_SIZE(fun_info->bitmap));
break;
default:
Index: ghc/rts/RetainerProfile.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/RetainerProfile.c,v
retrieving revision 1.10
diff -u -r1.10 RetainerProfile.c
--- ghc/rts/RetainerProfile.c 16 May 2003 14:39:29 -0000 1.10
+++ ghc/rts/RetainerProfile.c 7 Jul 2004 09:53:49 -0000
@@ -334,11 +334,11 @@
{
if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
info->type = posTypeLargeSRT;
- info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
+ info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
info->next.large_srt.offset = 0;
} else {
info->type = posTypeSRT;
- info->next.srt.srt = (StgClosure **)(infoTable->srt);
+ info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
}
}
@@ -348,11 +348,11 @@
{
if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
info->type = posTypeLargeSRT;
- info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
+ info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
info->next.large_srt.offset = 0;
} else {
info->type = posTypeSRT;
- info->next.srt.srt = (StgClosure **)(infoTable->srt);
+ info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
}
}
@@ -1324,7 +1324,7 @@
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
follow_srt:
- retainSRT((StgClosure **)info->srt, info->i.srt_bitmap, c, c_child_r);
+ retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
continue;
case RET_BCO: {
@@ -1343,9 +1343,9 @@
// large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
- size = info->i.layout.large_bitmap->size;
+ size = GET_LARGE_BITMAP(&info->i)->size;
p++;
- retain_large_bitmap(p, info->i.layout.large_bitmap,
+ retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
size, c, c_child_r);
p += size;
// and don't forget to follow the SRT
@@ -1388,8 +1388,8 @@
p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
break;
case ARG_GEN_BIG:
- size = ((StgLargeBitmap *)fun_info->bitmap)->size;
- retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+ size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+ retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
size, c, c_child_r);
p += size;
break;
@@ -1444,7 +1444,7 @@
(StgClosure *)pap, c_child_r);
break;
case ARG_GEN_BIG:
- retain_large_bitmap(p, (StgLargeBitmap *)fun_info->bitmap,
+ retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
size, (StgClosure *)pap, c_child_r);
p += size;
break;
Index: ghc/rts/Sanity.c
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/Sanity.c,v
retrieving revision 1.34
diff -u -r1.34 Sanity.c
--- ghc/rts/Sanity.c 3 Jul 2003 15:14:58 -0000 1.34
+++ ghc/rts/Sanity.c 7 Jul 2004 09:53:49 -0000
@@ -153,8 +153,8 @@
case RET_BIG: // large bitmap (> 32 entries)
case RET_VEC_BIG:
- size = info->i.layout.large_bitmap->size;
- checkLargeBitmap((StgPtr)c + 1, info->i.layout.large_bitmap, size);
+ size = GET_LARGE_BITMAP(&info->i)->size;
+ checkLargeBitmap((StgPtr)c + 1, GET_LARGE_BITMAP(&info->i), size);
return 1 + size;
case RET_FUN:
@@ -172,7 +172,7 @@
break;
case ARG_GEN_BIG:
checkLargeBitmap((StgPtr)ret_fun->payload,
- (StgLargeBitmap *)fun_info->bitmap, size);
+ GET_FUN_LARGE_BITMAP(fun_info), size);
break;
default:
checkSmallBitmap((StgPtr)ret_fun->payload,
@@ -362,7 +362,7 @@
break;
case ARG_GEN_BIG:
checkLargeBitmap( (StgPtr)pap->payload,
- (StgLargeBitmap *)fun_info->bitmap,
+ GET_FUN_LARGE_BITMAP(fun_info),
pap->n_args );
break;
case ARG_BCO:
Index: ghc/rts/Storage.h
===================================================================
RCS file: /home/cvs/root/fptools/ghc/rts/Storage.h,v
retrieving revision 1.53
diff -u -r1.53 Storage.h
--- ghc/rts/Storage.h 12 Nov 2003 17:49:11 -0000 1.53
+++ ghc/rts/Storage.h 7 Jul 2004 09:53:50 -0000
@@ -429,7 +429,7 @@
case RET_BIG:
case RET_VEC_BIG:
- return 1 + info->i.layout.large_bitmap->size;
+ return 1 + GET_LARGE_BITMAP(&info->i)->size;
case RET_BCO:
return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);
-------------- next part --------------
Cheers,
Wolfgang
More information about the Cvs-ghc
mailing list