diff options
Diffstat (limited to 'compiler/nativeGen/PIC.hs')
| -rw-r--r-- | compiler/nativeGen/PIC.hs | 82 |
1 files changed, 41 insertions, 41 deletions
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 5fff8cbdbb..b36c0ae1e8 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -35,6 +35,7 @@ module PIC ( cmmMakeDynamicReference, + CmmMakeDynamicReferenceM(..), ReferenceKind(..), needImportedSymbols, pprImportedSymbol, @@ -69,6 +70,7 @@ import CLabel ( mkForeignLabel ) import BasicTypes +import Module import Outputable @@ -96,26 +98,32 @@ data ReferenceKind | JumpReference deriving(Eq) +class Monad m => CmmMakeDynamicReferenceM m where + addImport :: CLabel -> m () + getThisModule :: m Module -cmmMakeDynamicReference, cmmMakeDynamicReference' - :: Monad m => DynFlags - -> (CLabel -> m ()) -- a monad & a function - -- used for recording imported symbols - -> ReferenceKind -- whether this is the target of a jump - -> CLabel -- the label - -> m CmmExpr +instance CmmMakeDynamicReferenceM NatM where + addImport = addImportNat + getThisModule = getThisModuleNat -cmmMakeDynamicReference = cmmMakeDynamicReference' +cmmMakeDynamicReference + :: CmmMakeDynamicReferenceM m + => DynFlags + -> ReferenceKind -- whether this is the target of a jump + -> CLabel -- the label + -> m CmmExpr -cmmMakeDynamicReference' dflags addImport referenceKind lbl +cmmMakeDynamicReference dflags referenceKind lbl | Just _ <- dynamicLinkerLabelInfo lbl = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through | otherwise - = case howToAccessLabel + = do this_mod <- getThisModule + case howToAccessLabel dflags (platformArch $ targetPlatform dflags) (platformOS $ targetPlatform dflags) + this_mod referenceKind lbl of AccessViaStub -> do @@ -186,7 +194,7 @@ data LabelAccessStyle | AccessDirectly howToAccessLabel - :: DynFlags -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle + :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle -- Windows @@ -210,7 +218,7 @@ howToAccessLabel -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. -- -howToAccessLabel dflags _ OSMinGW32 _ lbl +howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl -- Assume all symbols will be in the same PE, so just access them directly. | gopt Opt_Static dflags @@ -218,7 +226,7 @@ howToAccessLabel dflags _ OSMinGW32 _ lbl -- If the target symbol is in another PE we need to access it via the -- appropriate __imp_SYMBOL pointer. - | labelDynamic dflags (thisPackage dflags) lbl + | labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaSymbolPtr -- Target symbol is in the same PE as the caller, so just access it directly. @@ -234,9 +242,9 @@ howToAccessLabel dflags _ OSMinGW32 _ lbl -- It is always possible to access something indirectly, -- even when it's not necessary. -- -howToAccessLabel dflags arch OSDarwin DataReference lbl +howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl -- data access to a dynamic library goes via a symbol pointer - | labelDynamic dflags (thisPackage dflags) lbl + | labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaSymbolPtr -- when generating PIC code, all cross-module data references must @@ -255,21 +263,21 @@ howToAccessLabel dflags arch OSDarwin DataReference lbl | otherwise = AccessDirectly -howToAccessLabel dflags arch OSDarwin JumpReference lbl +howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl -- dyld code stubs don't work for tailcalls because the -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: | arch == ArchX86 || arch == ArchX86_64 - , labelDynamic dflags (thisPackage dflags) lbl + , labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaSymbolPtr -howToAccessLabel dflags arch OSDarwin _ lbl +howToAccessLabel dflags arch OSDarwin this_mod _ lbl -- Code stubs are the usual method of choice for imported code; -- not needed on x86_64 because Apple's new linker, ld64, generates -- them automatically. | arch /= ArchX86_64 - , labelDynamic dflags (thisPackage dflags) lbl + , labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaStub | otherwise @@ -286,7 +294,7 @@ howToAccessLabel dflags arch OSDarwin _ lbl -- from position independent code. It is also required from the main program -- when dynamic libraries containing Haskell code are used. -howToAccessLabel _ ArchPPC_64 os kind _ +howToAccessLabel _ ArchPPC_64 os _ kind _ | osElfTarget os = if kind == DataReference -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC @@ -294,7 +302,7 @@ howToAccessLabel _ ArchPPC_64 os kind _ -- actually, .label instead of label else AccessDirectly -howToAccessLabel dflags _ os _ _ +howToAccessLabel dflags _ os _ _ _ -- no PIC -> the dynamic linker does everything for us; -- if we don't dynamically link to Haskell code, -- it actually manages to do so without messing thins up. @@ -302,11 +310,11 @@ howToAccessLabel dflags _ os _ _ , not (gopt Opt_PIC dflags) && gopt Opt_Static dflags = AccessDirectly -howToAccessLabel dflags arch os DataReference lbl +howToAccessLabel dflags arch os this_mod DataReference lbl | osElfTarget os = case () of -- A dynamic label needs to be accessed via a symbol pointer. - _ | labelDynamic dflags (thisPackage dflags) lbl + _ | labelDynamic dflags (thisPackage dflags) this_mod lbl -> AccessViaSymbolPtr -- For PowerPC32 -fPIC, we have to access even static data @@ -332,24 +340,24 @@ howToAccessLabel dflags arch os DataReference lbl -- (AccessDirectly, because we get an implicit symbol stub) -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) -howToAccessLabel dflags arch os CallReference lbl +howToAccessLabel dflags arch os this_mod CallReference lbl | osElfTarget os - , labelDynamic dflags (thisPackage dflags) lbl && not (gopt Opt_PIC dflags) + , labelDynamic dflags (thisPackage dflags) this_mod lbl && not (gopt Opt_PIC dflags) = AccessDirectly | osElfTarget os , arch /= ArchX86 - , labelDynamic dflags (thisPackage dflags) lbl && gopt Opt_PIC dflags + , labelDynamic dflags (thisPackage dflags) this_mod lbl && gopt Opt_PIC dflags = AccessViaStub -howToAccessLabel dflags _ os _ lbl +howToAccessLabel dflags _ os this_mod _ lbl | osElfTarget os - = if labelDynamic dflags (thisPackage dflags) lbl + = if labelDynamic dflags (thisPackage dflags) this_mod lbl then AccessViaSymbolPtr else AccessDirectly -- all other platforms -howToAccessLabel dflags _ _ _ _ +howToAccessLabel dflags _ _ _ _ _ | not (gopt Opt_PIC dflags) = AccessDirectly @@ -771,19 +779,11 @@ initializePicBase_x86 ArchX86 os picReg BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab live (ListGraph blocks) : statics) - = return (CmmProc info lab live (ListGraph blocks') : statics) - - where blocks' = case blocks of - [] -> [] - (b:bs) -> fetchPC b : map maybeFetchPC bs - - maybeFetchPC b@(BasicBlock bID _) - | bID `mapMember` info = fetchPC b - | otherwise = b + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) - fetchPC (BasicBlock bID insns) = - BasicBlock bID (X86.FETCHPC picReg : insns) + where BasicBlock bID insns = entry + block' = BasicBlock bID (X86.FETCHPC picReg : insns) initializePicBase_x86 _ _ _ _ = panic "initializePicBase_x86: not needed" |