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 Packages ( HomeModules )
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_SccProfilingOn )
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 )
\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
- ++ if opt_SccProfilingOn
-#if defined(mingw32_HOST_OS)
- || True
-#endif
- then [cmm_init]
- else [])
+ ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
\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
-#if defined(mingw32_HOST_OS)
- ; registerForeignExports foreign_stubs
-#endif
; 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)
+cgTopBinding :: DynFlags -> HomeModules -> (StgBinding,[(Id,[Id])]) -> Code
+cgTopBinding dflags hmods (StgNonRec id rhs, srts)
= do { id' <- maybeExternaliseId dflags id
- ; mapM_ (mkSRT dflags [id']) srts
+ ; 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 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
projects / ghc-hetmet.git / blobdiff