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