From b8447a93b36d19f4c1dd81881ff10adf8c781fbe Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Mon, 13 May 2013 20:45:11 +0100 Subject: Make the current module available to labelDynamic It doesn't actually use it yet --- compiler/cmm/CLabel.hs | 4 +-- compiler/main/CodeOutput.lhs | 8 ++--- compiler/nativeGen/AsmCodeGen.lhs | 69 +++++++++++++++++++++------------------ compiler/nativeGen/NCGMonad.hs | 23 ++++++++----- compiler/nativeGen/PIC.hs | 45 +++++++++++++------------ 5 files changed, 84 insertions(+), 65 deletions(-) (limited to 'compiler') diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index a2830b9c2f..c14c958218 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -837,8 +837,8 @@ idInfoLabelType info = -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not. -labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool -labelDynamic dflags this_pkg lbl = +labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool +labelDynamic dflags this_pkg _this_mod lbl = case lbl of -- is the RTS in a DLL or not? RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index ce25727703..f94030306d 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -75,7 +75,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream ; showPass dflags "CodeOutput" ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs ; case hscTarget dflags of { - HscAsm -> outputAsm dflags filenm linted_cmm_stream; + HscAsm -> outputAsm dflags this_mod filenm linted_cmm_stream; HscC -> outputC dflags filenm linted_cmm_stream pkg_deps; HscLlvm -> outputLlvm dflags filenm linted_cmm_stream; HscInterpreted -> panic "codeOutput: HscInterpreted"; @@ -140,8 +140,8 @@ outputC dflags filenm cmm_stream packages %************************************************************************ \begin{code} -outputAsm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () -outputAsm dflags filenm cmm_stream +outputAsm :: DynFlags -> Module -> FilePath -> Stream IO RawCmmGroup () -> IO () +outputAsm dflags this_mod filenm cmm_stream | cGhcWithNativeCodeGen == "YES" = do ncg_uniqs <- mkSplitUniqSupply 'n' @@ -149,7 +149,7 @@ outputAsm dflags filenm cmm_stream _ <- {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags h ncg_uniqs cmm_stream + nativeCodeGen dflags this_mod h ncg_uniqs cmm_stream return () | otherwise diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index a0a0a7130a..a999f8f45a 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -151,14 +151,14 @@ data NcgImpl statics instr jumpDest = NcgImpl { } -------------------- -nativeCodeGen :: DynFlags -> Handle -> UniqSupply +nativeCodeGen :: DynFlags -> Module -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply -nativeCodeGen dflags h us cmms +nativeCodeGen dflags this_mod h us cmms = let platform = targetPlatform dflags nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO UniqSupply - nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + nCG' ncgImpl = nativeCodeGen' dflags this_mod ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (x86NcgImpl dflags) ArchX86_64 -> nCG' (x86_64NcgImpl dflags) @@ -255,19 +255,20 @@ type NativeGenAcc statics instr nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply -nativeCodeGen' dflags ncgImpl h us cmms +nativeCodeGen' dflags this_mod ncgImpl h us cmms = do let split_cmms = Stream.map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h - (ngs, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms ([], []) + (ngs, us') <- cmmNativeGenStream dflags this_mod ncgImpl bufh us split_cmms ([], []) finishNativeGen dflags ncgImpl bufh ngs return us' @@ -335,6 +336,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply @@ -342,19 +344,20 @@ cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGenStream dflags ncgImpl h us cmm_stream ngs@(impAcc, profAcc) +cmmNativeGenStream dflags this_mod ncgImpl h us cmm_stream ngs@(impAcc, profAcc) = do r <- Stream.runStream cmm_stream case r of Left () -> return ((reverse impAcc, reverse profAcc) , us) Right (cmms, cmm_stream') -> do - (ngs',us') <- cmmNativeGens dflags ncgImpl h us cmms ngs 0 - cmmNativeGenStream dflags ncgImpl h us' cmm_stream' ngs' + (ngs',us') <- cmmNativeGens dflags this_mod ncgImpl h us cmms ngs 0 + cmmNativeGenStream dflags this_mod ncgImpl h us' cmm_stream' ngs' -- | Do native code generation on all these cmms. -- cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply @@ -363,13 +366,13 @@ cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens _ _ _ us [] ngs _ +cmmNativeGens _ _ _ _ us [] ngs _ = return (ngs, us) -cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count +cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) (impAcc, profAcc) count = do (us', native, imports, colorStats, linearStats) - <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count + <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags this_mod ncgImpl us cmm count {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) @@ -386,7 +389,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count -- force evaluation all this stuff to avoid space leaks {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) - cmmNativeGens dflags ncgImpl h + cmmNativeGens dflags this_mod ncgImpl h us' cmms ((imports : impAcc), ((lsPprNative, colorStats, linearStats) : profAcc)) count' @@ -401,6 +404,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count cmmNativeGen :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmDecl -- ^ the cmm to generate code for @@ -411,7 +415,7 @@ cmmNativeGen , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators -cmmNativeGen dflags ncgImpl us cmm count +cmmNativeGen dflags this_mod ncgImpl us cmm count = do let platform = targetPlatform dflags @@ -423,7 +427,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- cmm to cmm optimisations let (opt_cmm, imports) = {-# SCC "cmmToCmm" #-} - cmmToCmm dflags fixed_cmm + cmmToCmm dflags this_mod fixed_cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" @@ -432,7 +436,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- generate native code from cmm let ((native, lastMinuteImports), usGen) = {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm + initUs us $ genMachCode dflags this_mod (cmmTopCodeGen ncgImpl) opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" @@ -816,15 +820,16 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) genMachCode :: DynFlags + -> Module -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) -> RawCmmDecl -> UniqSM ( [NatCmmDecl statics instr] , [CLabel]) -genMachCode dflags cmmTopCodeGen cmm_top +genMachCode dflags this_mod cmmTopCodeGen cmm_top = do { initial_us <- getUs - ; let initial_st = mkNatM_State initial_us 0 dflags + ; let initial_st = mkNatM_State initial_us 0 dflags this_mod (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) final_delta = natm_delta final_st final_imports = natm_imports final_st @@ -858,34 +863,36 @@ Ideas for other things we could do (put these in Hoopl please!): temp assignments, and certain assigns to mem...) -} -cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) -cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl live graph) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold (toBlockList graph) - return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') +cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm _ _ top@(CmmData _ _) = (top, []) +cmmToCmm dflags this_mod (CmmProc info lbl live graph) + = runCmmOpt dflags this_mod $ + do blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') -newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) +newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #)) instance Monad CmmOptM where - return x = CmmOptM $ \(imports, _) -> (# x,imports #) + return x = CmmOptM $ \_ _ imports -> (# x, imports #) (CmmOptM f) >>= g = - CmmOptM $ \(imports, dflags) -> - case f (imports, dflags) of + CmmOptM $ \dflags this_mod imports -> + case f dflags this_mod imports of (# x, imports' #) -> case g x of - CmmOptM g' -> g' (imports', dflags) + CmmOptM g' -> g' dflags this_mod imports' instance CmmMakeDynamicReferenceM CmmOptM where addImport = addImportCmmOpt + getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #) instance HasDynFlags CmmOptM where - getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) + getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #) -runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) -runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of +runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel]) +runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of (# result, imports #) -> (result, imports) cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index dd7eccb594..fec6805b4e 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -16,6 +16,7 @@ module NCGMonad ( mapAccumLNat, setDeltaNat, getDeltaNat, + getThisModuleNat, getBlockIdNat, getNewLabelNat, getNewRegNat, @@ -38,14 +39,16 @@ import CLabel ( CLabel, mkAsmTempLabel ) import UniqSupply import Unique ( Unique ) import DynFlags +import Module data NatM_State = NatM_State { - natm_us :: UniqSupply, - natm_delta :: Int, - natm_imports :: [(CLabel)], - natm_pic :: Maybe Reg, - natm_dflags :: DynFlags + natm_us :: UniqSupply, + natm_delta :: Int, + natm_imports :: [(CLabel)], + natm_pic :: Maybe Reg, + natm_dflags :: DynFlags, + natm_this_module :: Module } newtype NatM result = NatM (NatM_State -> (result, NatM_State)) @@ -53,9 +56,9 @@ newtype NatM result = NatM (NatM_State -> (result, NatM_State)) unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State -mkNatM_State us delta dflags - = NatM_State us delta [] Nothing dflags +mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> NatM_State +mkNatM_State us delta dflags this_mod + = NatM_State us delta [] Nothing dflags this_mod initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m @@ -105,6 +108,10 @@ setDeltaNat :: Int -> NatM () setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) +getThisModuleNat :: NatM Module +getThisModuleNat = NatM $ \ st -> (natm_this_module st, st) + + addImportNat :: CLabel -> NatM () addImportNat imp = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 6bf843affe..b36c0ae1e8 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -70,6 +70,7 @@ import CLabel ( mkForeignLabel ) import BasicTypes +import Module import Outputable @@ -99,9 +100,11 @@ data ReferenceKind class Monad m => CmmMakeDynamicReferenceM m where addImport :: CLabel -> m () + getThisModule :: m Module instance CmmMakeDynamicReferenceM NatM where addImport = addImportNat + getThisModule = getThisModuleNat cmmMakeDynamicReference :: CmmMakeDynamicReferenceM m @@ -115,10 +118,12 @@ cmmMakeDynamicReference dflags referenceKind 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 @@ -189,7 +194,7 @@ data LabelAccessStyle | AccessDirectly howToAccessLabel - :: DynFlags -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle + :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle -- Windows @@ -213,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 @@ -221,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. @@ -237,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 @@ -258,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 @@ -289,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 @@ -297,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. @@ -305,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 @@ -335,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 -- cgit v1.2.1