ghc/compiler/codeGen/CodeGen.lhs

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