cgIdInfoId )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon, cgTyCon )
-import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall )
+import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord )
import CLabel
import Cmm
import StgSyn
import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER )
-import DynFlags ( DynFlags(..), DynFlag(..) )
-import StaticFlags ( opt_SplitObjs, opt_SccProfilingOn )
+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 TyCon ( TyCon )
import Module ( Module, mkModule )
import ErrUtils ( dumpIfSet_dyn, showPass )
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"
; let way = buildTag dflags
- mb_main_mod = mainModIs dflags
-
- ; let tycons = typeEnvTyCons type_env
- data_tycons = filter isDataTyCon tycons
+ main_mod = mainModIs dflags
-- Why?
-- ; mapM_ (\x -> seq x (return ())) data_tycons
- ; code_stuff <- initC dflags this_mod $ do
- { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
+ ; 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 way cost_centre_info
- this_mod mb_main_mod
+ ; 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])
+ ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
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
:: 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 dflags 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
(emitSimpleProc plain_main_init_lbl jump_to_init)
}
where
- plain_init_lbl = mkPlainModuleInitLabel dflags this_mod
- real_init_lbl = mkModuleInitLabel dflags this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel dflags 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 = case mb_main_mod of
- Just mod_name -> mkModule mod_name
- Nothing -> mAIN
-
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
-- init function for GHC.TopHandler.
extra_imported_mods
stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
-- Now do local stuff
- ; registerForeignExports foreign_stubs
; initCostCentres cost_centre_info
- ; mapCs (registerModuleImport dflags way)
+ ; 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 :: DynFlags -> String -> Module -> Code
-registerModuleImport dflags 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 dflags 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 (mkLocalClosureLabel (idName bndr))),
- PtrHint) ]
+ , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel hmods mod way)) ]
\end{code}
variable.
\begin{code}
-cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
-cgTopBinding dflags (StgNonRec id rhs, srts)
- = do { id' <- maybeExternaliseId id
- ; mapM_ (mkSRT dflags [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 dflags (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 dflags bndrs') srts
+ ; mapM_ (mkSRT hmods bndrs') srts
; _new_binds <- fixC (\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; nopC }
-mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code
-mkSRT dflags these (id,[]) = nopC
-mkSRT dflags 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 dflags . 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_SplitObjs, -- 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