functions drive the mangling of top-level bindings.
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module CodeGen ( codeGen ) where
#include "HsVersions.h"
import CgHpc
import CLabel
-import Cmm
-import CmmUtils
-import PprCmm
-import MachOp
+import OldCmm
+import OldCmmUtils
+import OldPprCmm
import StgSyn
import PrelNames
import DynFlags
import StaticFlags
-import PackageConfig
import HscTypes
import CostCentre
import Id
import Name
-import OccName
import TyCon
import Module
import ErrUtils
-
-#ifdef DEBUG
import Panic
-#endif
\end{code}
\begin{code}
-> HpcInfo
-> IO [Cmm] -- Output
+ -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
+ -- possible for object splitting to split up the
+ -- pieces later.
+
codeGen dflags this_mod data_tycons imported_mods
cost_centre_info stg_binds hpc_info
= do
{ showPass dflags "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)
+ ; cmm_init <- getCmm (mkModuleInit dflags cost_centre_info
+ this_mod imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
}
-- Put datatype_stuff after code_stuff, because the
\begin{code}
mkModuleInit
- :: String -- the "way"
+ :: DynFlags
-> CollectedCCs -- cost centre info
-> Module
- -> Module -- name of the Main module
-> [Module]
-> HpcInfo
-> Code
-mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
+mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info
= do { -- Allocate the static boolean that records if this
-- module has been registered already
emitData Data [CmmDataLabel moduleRegdLabel,
(emitSimpleProc plain_main_init_lbl rec_descent_init)
}
where
+ -- The way string we attach to the __stginit label to catch
+ -- accidental linking of modules compiled in different ways. We
+ -- omit "dyn" from this way, because we want to be able to load
+ -- both dynamic and non-dynamic modules into a dynamic GHC.
+ way = mkBuildTag (filter want_way (ways dflags))
+ want_way w = not (wayRTSOnly w) && wayName w /= WayDyn
+
+ main_mod = mainModIs dflags
+
plain_init_lbl = mkPlainModuleInitLabel this_mod
real_init_lbl = mkModuleInitLabel this_mod way
plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
- mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep
+ mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
-- init function for GHC.TopHandler.
-- 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) [] ]
+ , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ]
rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
; nopC }
mkSRT :: [Id] -> (Id,[Id]) -> Code
-mkSRT these (id,[]) = nopC
+mkSRT _ (_,[]) = nopC
mkSRT these (id,ids)
= do { ids <- mapFCs remap ids
; id <- remap id
- ; emitRODataLits (mkSRTLabel (idName id))
- (map (CmmLabel . mkClosureLabel . idName) ids)
+ ; emitRODataLits "CodeGen.mkSRT" (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
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
-cgTopRhs bndr (StgRhsCon cc con args)
+cgTopRhs bndr (StgRhsCon _cc con args)
= forkStatics (cgTopRhsCon bndr con args)
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
= ASSERT(null fvs) -- There should be no free variables
- setSRTLabel (mkSRTLabel (idName bndr)) $
+ setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
setSRT srt $
forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
\end{code}