Make the current module available to labelDynamic

It doesn't actually use it yet

5 files changed, 84 insertions, 65 deletions

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