import StgCmmHpc
import StgCmmTicky
-import MkZipCfgCmm
-import Cmm
-import CmmUtils
+import MkGraph
+import CmmExpr
+import CmmDecl
import CLabel
import PprCmm
import StgSyn
-import PrelNames
import DynFlags
-import StaticFlags
import HscTypes
import CostCentre
import Type
import DataCon
import Name
-import OccName
import TyCon
import Module
import ErrUtils
codeGen :: DynFlags
-> Module
-> [TyCon]
- -> [Module] -- Directly-imported modules
- -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
+ -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> HpcInfo
- -> IO [CmmZ] -- Output
+ -> IO [Cmm] -- Output
-codeGen dflags this_mod data_tycons imported_mods
+codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
= do { showPass dflags "New CodeGen"
- ; let way = buildTag dflags
- 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
; cmm_tycons <- mapM cgTyCon data_tycons
- ; cmm_init <- getCmm (mkModuleInit way cost_centre_info
- this_mod main_mod
- imported_mods hpc_info)
- ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
+ ; cmm_init <- getCmm (mkModuleInit cost_centre_info
+ this_mod hpc_info)
+ ; return (cmm_init : cmm_binds ++ concat cmm_tycons)
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- possible for object splitting to split up the
-- pieces later.
+ -- Note [codegen-split-init] the cmm_init block must
+ -- come FIRST. This is because when -split-objs is on
+ -- we need to combine this block with its
+ -- initialisation routines; see Note
+ -- [pipeline-split-init].
+
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
; return code_stuff }
cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
cgTopBinding dflags (StgNonRec id rhs, _srts)
= do { id' <- maybeExternaliseId dflags id
- --; mapM_ (mkSRT [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
+ ; info <- cgTopRhs id' rhs
+ ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
+ -- so we find it when we look up occurrences
}
cgTopBinding dflags (StgRec pairs, _srts)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
- --; mapM_ (mkSRT bndrs') srts
- ; fixC (\ new_binds -> do
+ ; fixC_(\ new_binds -> do
{ addBindsC new_binds
; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
; return () }
---mkSRT :: [Id] -> (Id,[Id]) -> FCode ()
---mkSRT these (id,ids)
--- | null ids = nopC
--- | otherwise
--- = do { ids <- mapFCs remap ids
--- ; id <- remap id
--- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id))
--- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
--- }
--- where
--- -- Sigh, better map all the ids against the environment in
--- -- case they've been externalised (see maybeExternaliseId below).
--- remap id = case filter (==id) these of
--- (id':_) -> returnFC id'
--- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
-
-- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
-
---------------------------------------------------------------
-- Module initialisation code
---------------------------------------------------------------
-}
mkModuleInit
- :: String -- the "way"
- -> CollectedCCs -- cost centre info
+ :: CollectedCCs -- cost centre info
-> Module
- -> Module -- name of the Main module
- -> [Module]
- -> HpcInfo
+ -> HpcInfo
-> FCode ()
-mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
- = do { -- Allocate the static boolean that records if this
- -- module has been registered already
- emitData Data [CmmDataLabel moduleRegdLabel,
- CmmStaticLit zeroCLit]
-
- ; init_hpc <- initHpc this_mod hpc_info
- ; init_prof <- initCostCentres cost_centre_info
-
- -- We emit a recursive descent module search for all modules
- -- and *choose* to chase it in :Main, below.
- -- In this way, Hpc enabled modules can interact seamlessly with
- -- not Hpc enabled moduled, provided Main is compiled with Hpc.
-
- ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs
- [ check_already_done retId
- , init_prof
- , init_hpc
- , catAGraphs $ map (registerImport way) all_imported_mods
- , mkBranch retId ]
- -- 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, 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
-
- -- Notice that the recursive descent is optional, depending on what options
- -- are enabled.
-
-
- ; whenC (this_mod == main_mod)
- (emitSimpleProc plain_main_init_lbl rec_descent_init)
- }
- where
- plain_init_lbl = mkPlainModuleInitLabel this_mod
- real_init_lbl = mkModuleInitLabel this_mod way
- plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
-
- jump_to_init = mkJump (mkLblExpr real_init_lbl) []
-
-
- -- Main refers to GHC.TopHandler.runIO, so make sure we call the
- -- init function for GHC.TopHandler.
- extra_imported_mods
- | this_mod == main_mod = [gHC_TOP_HANDLER]
- | otherwise = []
- all_imported_mods = imported_mods ++ extra_imported_mods
-
- mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
- check_already_done retId
- = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
- (mkLabel retId Nothing <*> mkReturn []) mkNop
- <*> -- Set mod_reg to 1 to record that we've been here
- mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
-
- -- The return-code pops the work stack by
- -- incrementing Sp, and then jumpd to the popped item
- ret_code = mkAssign spReg (cmmRegOffW spReg 1)
- <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) []
-
- rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
- then jump_to_init
- else ret_code
-
------------------------
-registerImport :: String -> Module -> CmmAGraph
-registerImport way mod
- | mod == gHC_PRIM
- = mkNop
- | otherwise -- Push the init procedure onto the work stack
- = mkCmmCall init_lbl [] [] NoC_SRT
- where
- init_lbl = mkLblExpr $ mkModuleInitLabel mod way
-
+mkModuleInit cost_centre_info this_mod hpc_info
+ = do { initHpc this_mod hpc_info
+ ; initCostCentres cost_centre_info
+ -- For backwards compatibility: user code may refer to this
+ -- label for calling hs_add_root().
+ ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ]
+ }
---------------------------------------------------------------
-- Generating static stuff for algebraic data types
closures predeclared.
-}
-cgTyCon :: TyCon -> FCode [CmmZ] -- All constructors merged together
+cgTyCon :: TyCon -> FCode [Cmm] -- All constructors merged together
cgTyCon tycon
= do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
; return (extra ++ constrs)
}
-cgEnumerationTyCon :: TyCon -> FCode [CmmZ]
+cgEnumerationTyCon :: TyCon -> FCode [Cmm]
cgEnumerationTyCon tycon
| isEnumerationTyCon tycon
= do { tbl <- getCmm $
(dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
emit_info cl_info ticky_code
- = do { code_blks <- getCode (mk_code ticky_code)
- ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+ = emitClosureAndInfoTable cl_info NativeDirectCall []
+ $ mk_code ticky_code
mk_code ticky_code
= -- NB: We don't set CC when entering data (WDP 94/06)
- do { ticky_code
+ do { _ <- ticky_code
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_things)
; emitReturn [cmmOffsetB (CmmReg nodeReg)
projects / ghc-hetmet.git / blobdiff