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