compiler/codeGen/CodeGen.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The Code Generator
   7
   8 This module says how things get going at the top level.
   9
  10 @codeGen@ is the interface to the outside world.  The \tr{cgTop*}
  11 functions drive the mangling of top-level bindings.
  12
  13 \begin{code}
  14 module CodeGen ( codeGen ) where
  15
  16 #include "HsVersions.h"
  17
  18 -- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
  19 -- import.  Before, that wasn't the case, and CM therefore didn't
  20 -- bother to compile it.
  21 import CgExpr           ( {-NOTHING!-} )        -- DO NOT DELETE THIS IMPORT
  22 import CgProf
  23 import CgMonad
  24 import CgBindery
  25 import CgClosure
  26 import CgCon
  27 import CgUtils
  28 import CgHpc
  29
  30 import CLabel
  31 import Cmm
  32 import CmmUtils
  33 import PprCmm
  34
  35 import StgSyn
  36 import PrelNames
  37 import DynFlags
  38 import StaticFlags
  39
  40 import HscTypes
  41 import CostCentre
  42 import Id
  43 import Name
  44 import TyCon
  45 import Module
  46 import ErrUtils
  47 import Panic
  48 \end{code}
  49
  50 \begin{code}
  51 codeGen :: DynFlags
  52         -> Module
  53         -> [TyCon]
  54         -> [Module]             -- directly-imported modules
  55         -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
  56         -> [(StgBinding,[(Id,[Id])])]   -- Bindings to convert, with SRTs
  57         -> HpcInfo
  58         -> IO [Cmm]             -- Output
  59
  60                 -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
  61                 -- possible for object splitting to split up the
  62                 -- pieces later.
  63
  64 codeGen dflags this_mod data_tycons imported_mods
  65         cost_centre_info stg_binds hpc_info
  66   = do
  67   { showPass dflags "CodeGen"
  68   ; let way = buildTag dflags
  69         main_mod = mainModIs dflags
  70
  71 -- Why?
  72 --   ; mapM_ (\x -> seq x (return ())) data_tycons
  73
  74   ; code_stuff <- initC dflags this_mod $ do
  75                 { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
  76                 ; cmm_tycons <- mapM cgTyCon data_tycons
  77                 ; cmm_init   <- getCmm (mkModuleInit way cost_centre_info
  78                                              this_mod main_mod
  79                                              imported_mods hpc_info)
  80                 ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
  81                 }
  82                 -- Put datatype_stuff after code_stuff, because the
  83                 -- datatype closure table (for enumeration types) to
  84                 -- (say) PrelBase_True_closure, which is defined in
  85                 -- code_stuff
  86
  87   ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
  88
  89   ; return code_stuff }
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection[codegen-init]{Module initialisation code}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 /* -----------------------------------------------------------------------------
  99    Module initialisation
 100
 101    The module initialisation code looks like this, roughly:
 102
 103         FN(__stginit_Foo) {
 104           JMP_(__stginit_Foo_1_p)
 105         }
 106
 107         FN(__stginit_Foo_1_p) {
 108         ...
 109         }
 110
 111    We have one version of the init code with a module version and the
 112    'way' attached to it.  The version number helps to catch cases
 113    where modules are not compiled in dependency order before being
 114    linked: if a module has been compiled since any modules which depend on
 115    it, then the latter modules will refer to a different version in their
 116    init blocks and a link error will ensue.
 117
 118    The 'way' suffix helps to catch cases where modules compiled in different
 119    ways are linked together (eg. profiled and non-profiled).
 120
 121    We provide a plain, unadorned, version of the module init code
 122    which just jumps to the version with the label and way attached.  The
 123    reason for this is that when using foreign exports, the caller of
 124    startupHaskell() must supply the name of the init function for the "top"
 125    module in the program, and we don't want to require that this name
 126    has the version and way info appended to it.
 127    --------------------------------------------------------------------------  */
 128
 129 We initialise the module tree by keeping a work-stack,
 130         * pointed to by Sp
 131         * that grows downward
 132         * Sp points to the last occupied slot
 133
 134
 135 \begin{code}
 136 mkModuleInit
 137         :: String               -- the "way"
 138         -> CollectedCCs         -- cost centre info
 139         -> Module
 140         -> Module               -- name of the Main module
 141         -> [Module]
 142         -> HpcInfo
 143         -> Code
 144 mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
 145   = do  { -- Allocate the static boolean that records if this
 146           -- module has been registered already
 147           emitData Data [CmmDataLabel moduleRegdLabel,
 148                          CmmStaticLit zeroCLit]
 149
 150         ; whenC (opt_Hpc) $
 151               hpcTable this_mod hpc_info
 152
 153           -- we emit a recursive descent module search for all modules
 154           -- and *choose* to chase it in :Main, below.
 155           -- In this way, Hpc enabled modules can interact seamlessly with
 156           -- not Hpc enabled moduled, provided Main is compiled with Hpc.
 157
 158         ; emitSimpleProc real_init_lbl $ do
 159                        { ret_blk <- forkLabelledCode ret_code
 160
 161                         ; init_blk <- forkLabelledCode $ do
 162                                         { mod_init_code; stmtC (CmmBranch ret_blk) }
 163
 164                         ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
 165                                     ret_blk)
 166                         ; stmtC (CmmBranch init_blk)
 167                         }
 168
 169             -- Make the "plain" procedure jump to the "real" init procedure
 170         ; emitSimpleProc plain_init_lbl jump_to_init
 171
 172         -- When compiling the module in which the 'main' function lives,
 173         -- (that is, this_mod == main_mod)
 174         -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
 175         -- RTS to invoke.  We must consult the -main-is flag in case the
 176         -- user specified a different function to Main.main
 177
 178         -- Notice that the recursive descent is optional, depending on what options
 179         -- are enabled.
 180
 181         ; whenC (this_mod == main_mod)
 182                 (emitSimpleProc plain_main_init_lbl rec_descent_init)
 183     }
 184   where
 185     plain_init_lbl = mkPlainModuleInitLabel this_mod
 186     real_init_lbl  = mkModuleInitLabel this_mod way
 187     plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
 188
 189     jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
 190
 191     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
 192
 193     -- Main refers to GHC.TopHandler.runIO, so make sure we call the
 194     -- init function for GHC.TopHandler.
 195     extra_imported_mods
 196         | this_mod == main_mod = [gHC_TOP_HANDLER]
 197         | otherwise            = []
 198
 199     mod_init_code = do
 200         {       -- Set mod_reg to 1 to record that we've been here
 201           stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
 202
 203         ; whenC (opt_SccProfilingOn) $ do
 204             initCostCentres cost_centre_info
 205
 206         ; whenC (opt_Hpc) $
 207             initHpc this_mod hpc_info
 208
 209         ; mapCs (registerModuleImport way)
 210                 (imported_mods++extra_imported_mods)
 211
 212         }
 213
 214                     -- The return-code pops the work stack by
 215                     -- incrementing Sp, and then jumpd to the popped item
 216     ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
 217                       , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ]
 218
 219
 220     rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
 221                        then jump_to_init
 222                        else ret_code
 223
 224 -----------------------
 225 registerModuleImport :: String -> Module -> Code
 226 registerModuleImport way mod
 227   | mod == gHC_PRIM
 228   = nopC
 229   | otherwise   -- Push the init procedure onto the work stack
 230   = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
 231            , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
 232 \end{code}
 233
 234
 235
 236 Cost-centre profiling: Besides the usual stuff, we must produce
 237 declarations for the cost-centres defined in this module;
 238
 239 (The local cost-centres involved in this are passed into the
 240 code-generator.)
 241
 242 \begin{code}
 243 initCostCentres :: CollectedCCs -> Code
 244 -- Emit the declarations, and return code to register them
 245 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
 246   | not opt_SccProfilingOn = nopC
 247   | otherwise
 248   = do  { mapM_ emitCostCentreDecl       local_CCs
 249         ; mapM_ emitCostCentreStackDecl  singleton_CCSs
 250         ; mapM_ emitRegisterCC           local_CCs
 251         ; mapM_ emitRegisterCCS          singleton_CCSs
 252         }
 253 \end{code}
 254
 255 %************************************************************************
 256 %*                                                                      *
 257 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
 258 %*                                                                      *
 259 %************************************************************************
 260
 261 @cgTopBinding@ is only used for top-level bindings, since they need
 262 to be allocated statically (not in the heap) and need to be labelled.
 263 No unboxed bindings can happen at top level.
 264
 265 In the code below, the static bindings are accumulated in the
 266 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 267 This is so that we can write the top level processing in a compositional
 268 style, with the increasing static environment being plumbed as a state
 269 variable.
 270
 271 \begin{code}
 272 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
 273 cgTopBinding dflags (StgNonRec id rhs, srts)
 274   = do  { id' <- maybeExternaliseId dflags id
 275         ; mapM_ (mkSRT [id']) srts
 276         ; (id,info) <- cgTopRhs id' rhs
 277         ; addBindC id info      -- Add the *un-externalised* Id to the envt,
 278                                 -- so we find it when we look up occurrences
 279         }
 280
 281 cgTopBinding dflags (StgRec pairs, srts)
 282   = do  { let (bndrs, rhss) = unzip pairs
 283         ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
 284         ; let pairs' = zip bndrs' rhss
 285         ; mapM_ (mkSRT bndrs')  srts
 286         ; _new_binds <- fixC (\ new_binds -> do
 287                 { addBindsC new_binds
 288                 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
 289         ; nopC }
 290
 291 mkSRT :: [Id] -> (Id,[Id]) -> Code
 292 mkSRT _ (_,[])  = nopC
 293 mkSRT these (id,ids)
 294   = do  { ids <- mapFCs remap ids
 295         ; id  <- remap id
 296         ; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id))
 297                (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
 298         }
 299   where
 300         -- Sigh, better map all the ids against the environment in
 301         -- case they've been externalised (see maybeExternaliseId below).
 302     remap id = case filter (==id) these of
 303                 (id':_) -> returnFC id'
 304                 [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
 305
 306 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 307 -- to enclose the listFCs in cgTopBinding, but that tickled the
 308 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 309
 310 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 311         -- The Id is passed along for setting up a binding...
 312         -- It's already been externalised if necessary
 313
 314 cgTopRhs bndr (StgRhsCon _cc con args)
 315   = forkStatics (cgTopRhsCon bndr con args)
 316
 317 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
 318   = ASSERT(null fvs)    -- There should be no free variables
 319     setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
 320     setSRT srt $
 321     forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
 322 \end{code}
 323
 324
 325 %************************************************************************
 326 %*                                                                      *
 327 \subsection{Stuff to support splitting}
 328 %*                                                                      *
 329 %************************************************************************
 330
 331 If we're splitting the object, we need to externalise all the top-level names
 332 (and then make sure we only use the externalised one in any C label we use
 333 which refers to this name).
 334
 335 \begin{code}
 336 maybeExternaliseId :: DynFlags -> Id -> FCode Id
 337 maybeExternaliseId dflags id
 338   | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
 339     isInternalName name = do { mod <- getModuleName
 340                              ; returnFC (setIdName id (externalise mod)) }
 341   | otherwise           = returnFC id
 342   where
 343     externalise mod = mkExternalName uniq mod new_occ loc
 344     name    = idName id
 345     uniq    = nameUnique name
 346     new_occ = mkLocalOcc uniq (nameOccName name)
 347     loc     = nameSrcSpan name
 348         -- We want to conjure up a name that can't clash with any
 349         -- existing name.  So we generate
 350         --      Mod_$L243foo
 351         -- where 243 is the unique.
 352 \end{code}