Skip to content

GitLab

GHC
GHC
Commit b8447a93 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files
Options

Make the current module available to labelDynamic 

It doesn't actually use it yet
parent 58dccedb
Hide whitespace changes
Inline Side-by-side
Showing with 84 additions and 65 deletions
compiler/cmm/CLabel.hs
View file @ b8447a93
......@@ -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)
......
compiler/main/CodeOutput.lhs
View file @ b8447a93
......@@ -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
......
compiler/nativeGen/AsmCodeGen.lhs
View file @ b8447a93
......@@ -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
......
compiler/nativeGen/NCGMonad.hs
View file @ b8447a93
......@@ -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})
......
compiler/nativeGen/PIC.hs
View file @ b8447a93
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment