#include "HsVersions.h"
-import DriverState ( v_Build_tag, v_MainModIs )
-
-- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
-- import. Before, that wasn't the case, and CM therefore didn't
-- bother to compile it.
cgIdInfoId )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon, cgTyCon )
-import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
+import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord )
-import CLabel ( mkSRTLabel, mkClosureLabel, moduleRegdLabel,
- mkPlainModuleInitLabel, mkModuleInitLabel )
+import CLabel
import Cmm
import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
import PprCmm ( pprCmms )
import MachOp ( wordRep, MachHint(..) )
import StgSyn
-import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name, pREL_TOP_HANDLER )
-import CmdLineOpts ( DynFlags, DynFlag(..), opt_EnsureSplittableC,
- opt_SccProfilingOn )
+import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER )
+import Packages ( HomeModules )
+import DynFlags ( DynFlags(..), DynFlag(..), dopt )
+import StaticFlags ( opt_SccProfilingOn )
import HscTypes ( ForeignStubs(..), TypeEnv, typeEnvTyCons )
import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
import OccName ( mkLocalOcc )
-import TyCon ( isDataTyCon )
-import Module ( Module, mkModuleName )
+import TyCon ( TyCon )
+import Module ( Module, mkModule )
import ErrUtils ( dumpIfSet_dyn, showPass )
-import Panic ( assertPanic, trace )
-import qualified Module ( moduleName )
+import Panic ( assertPanic )
#ifdef DEBUG
import Outputable
#endif
-
-import DATA_IOREF ( readIORef )
\end{code}
\begin{code}
codeGen :: DynFlags
+ -> HomeModules
-> Module
- -> TypeEnv
+ -> [TyCon]
-> ForeignStubs
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> IO [Cmm] -- Output
-codeGen dflags this_mod type_env foreign_stubs imported_mods
+codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods
cost_centre_info stg_binds
= do
{ showPass dflags "CodeGen"
- ; way <- readIORef v_Build_tag
- ; mb_main_mod <- readIORef v_MainModIs
-
- ; let tycons = typeEnvTyCons type_env
- data_tycons = filter isDataTyCon tycons
+ ; let way = buildTag dflags
+ main_mod = mainModIs dflags
-- Why?
-- ; mapM_ (\x -> seq x (return ())) data_tycons
- ; code_stuff <- initC this_mod $ do
- { cmm_binds <- mapM (getCmm . cgTopBinding) stg_binds
- ; cmm_tycons <- mapM cgTyCon data_tycons
- ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
- this_mod mb_main_mod
- foreign_stubs imported_mods)
- ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
- }
+ ; code_stuff <- initC dflags hmods this_mod $ do
+ { cmm_binds <- mapM (getCmm . cgTopBinding dflags hmods) stg_binds
+ ; cmm_tycons <- mapM cgTyCon data_tycons
+ ; cmm_init <- getCmm (mkModuleInit dflags hmods way cost_centre_info
+ this_mod main_mod
+ foreign_stubs imported_mods)
+ ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+ }
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
startupHaskell() must supply the name of the init function for the "top"
module in the program, and we don't want to require that this name
has the version and way info appended to it.
- -------------------------------------------------------------------------- */
+ -------------------------------------------------------------------------- */
We initialise the module tree by keeping a work-stack,
* pointed to by Sp
\begin{code}
mkModuleInit
- :: String -- the "way"
+ :: DynFlags
+ -> HomeModules
+ -> String -- the "way"
-> CollectedCCs -- cost centre info
-> Module
- -> Maybe String -- Just m ==> we have flag: -main-is Foo.baz
+ -> Module -- name of the Main module
-> ForeignStubs
-> [Module]
-> Code
-mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
+mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs imported_mods
= do {
-
- -- Allocate the static boolean that records if this
- -- module has been registered already
- ; emitData Data [CmmDataLabel moduleRegdLabel,
- CmmStaticLit zeroCLit]
-
- ; emitSimpleProc real_init_lbl $ do
- { -- The return-code pops the work stack by
- -- incrementing Sp, and then jumpd to the popped item
- ret_blk <- forkLabelledCode $ stmtsC
- [ CmmAssign spReg (cmmRegOffW spReg 1)
- , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
-
- ; init_blk <- forkLabelledCode $ do
- { mod_init_code; stmtC (CmmBranch ret_blk) }
-
- ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- ret_blk)
- ; stmtC (CmmBranch init_blk)
- }
-
+ if opt_SccProfilingOn
+ then do { -- Allocate the static boolean that records if this
+ -- module has been registered already
+ emitData Data [CmmDataLabel moduleRegdLabel,
+ CmmStaticLit zeroCLit]
+
+ ; emitSimpleProc real_init_lbl $ do
+ { ret_blk <- forkLabelledCode ret_code
+
+ ; init_blk <- forkLabelledCode $ do
+ { mod_init_code; stmtC (CmmBranch ret_blk) }
+
+ ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
+ ret_blk)
+ ; stmtC (CmmBranch init_blk)
+ }
+ }
+ else emitSimpleProc real_init_lbl ret_code
-- Make the "plain" procedure jump to the "real" init procedure
; emitSimpleProc plain_init_lbl jump_to_init
-- When compiling the module in which the 'main' function lives,
- -- (that is, Module.moduleName this_mod == main_mod_name)
+ -- (that is, this_mod == main_mod)
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
- ; whenC (Module.moduleName this_mod == main_mod_name)
+ ; whenC (this_mod == main_mod)
(emitSimpleProc plain_main_init_lbl jump_to_init)
}
where
- plain_init_lbl = mkPlainModuleInitLabel this_mod
- real_init_lbl = mkModuleInitLabel this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
+ plain_init_lbl = mkPlainModuleInitLabel hmods this_mod
+ real_init_lbl = mkModuleInitLabel hmods this_mod way
+ plain_main_init_lbl = mkPlainModuleInitLabel hmods rOOT_MAIN
jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep
- main_mod_name = case mb_main_mod of
- Just mod_name -> mkModuleName mod_name
- Nothing -> mAIN_Name
-
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
-- init function for GHC.TopHandler.
extra_imported_mods
- | Module.moduleName this_mod == main_mod_name = [pREL_TOP_HANDLER]
- | otherwise = []
+ | this_mod == main_mod = [pREL_TOP_HANDLER]
+ | otherwise = []
mod_init_code = do
{ -- Set mod_reg to 1 to record that we've been here
stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
-- Now do local stuff
- ; registerForeignExports foreign_stubs
; initCostCentres cost_centre_info
- ; mapCs (registerModuleImport way) (imported_mods++extra_imported_mods)
+ ; mapCs (registerModuleImport hmods way)
+ (imported_mods++extra_imported_mods)
}
+ -- The return-code pops the work stack by
+ -- incrementing Sp, and then jumpd to the popped item
+ ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
+ , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
-----------------------
-registerModuleImport :: String -> Module -> Code
-registerModuleImport way mod
+registerModuleImport :: HomeModules -> String -> Module -> Code
+registerModuleImport hmods way mod
| mod == gHC_PRIM
= nopC
| otherwise -- Push the init procedure onto the work stack
= stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
- , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
-
------------------------
-registerForeignExports :: ForeignStubs -> Code
-registerForeignExports NoStubs
- = nopC
-registerForeignExports (ForeignStubs _ _ _ fe_bndrs)
- = mapM_ mk_export_register fe_bndrs
- where
- mk_export_register bndr
- = emitRtsCall SLIT("getStablePtr")
- [ (CmmLit (CmmLabel (mkClosureLabel (idName bndr))), PtrHint) ]
+ , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel hmods mod way)) ]
\end{code}
variable.
\begin{code}
-cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code
-cgTopBinding (StgNonRec id rhs, srts)
- = do { id' <- maybeExternaliseId id
- ; mapM_ (mkSRT [id']) srts
+cgTopBinding :: DynFlags -> HomeModules -> (StgBinding,[(Id,[Id])]) -> Code
+cgTopBinding dflags hmods (StgNonRec id rhs, srts)
+ = do { id' <- maybeExternaliseId dflags id
+ ; mapM_ (mkSRT hmods [id']) srts
; (id,info) <- cgTopRhs id' rhs
; addBindC id info -- Add the *un-externalised* Id to the envt,
-- so we find it when we look up occurrences
}
-cgTopBinding (StgRec pairs, srts)
+cgTopBinding dflags hmods (StgRec pairs, srts)
= do { let (bndrs, rhss) = unzip pairs
- ; bndrs' <- mapFCs maybeExternaliseId bndrs
+ ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
- ; mapM_ (mkSRT bndrs') srts
- ; new_binds <- fixC (\ new_binds -> do
+ ; mapM_ (mkSRT hmods bndrs') srts
+ ; _new_binds <- fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; nopC }
-mkSRT :: [Id] -> (Id,[Id]) -> Code
-mkSRT these (id,[]) = nopC
-mkSRT these (id,ids)
+mkSRT :: HomeModules -> [Id] -> (Id,[Id]) -> Code
+mkSRT hmods these (id,[]) = nopC
+mkSRT hmods these (id,ids)
= do { ids <- mapFCs remap ids
; id <- remap id
; emitRODataLits (mkSRTLabel (idName id))
- (map (CmmLabel . mkClosureLabel . idName) ids)
+ (map (CmmLabel . mkClosureLabel hmods . idName) ids)
}
where
-- Sigh, better map all the ids against the environment in
which refers to this name).
\begin{code}
-maybeExternaliseId :: Id -> FCode Id
-maybeExternaliseId id
- | opt_EnsureSplittableC, -- Externalise the name for -split-objs
+maybeExternaliseId :: DynFlags -> Id -> FCode Id
+maybeExternaliseId dflags id
+ | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs
isInternalName name = do { mod <- moduleName
; returnFC (setIdName id (externalise mod)) }
| otherwise = returnFC id
projects / ghc-hetmet.git / blobdiff