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