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 opt_SccProfilingOn
 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         ; initCostCentres cost_centre_info
 208         ; mapCs (registerModuleImport dflags way)
 209                 (imported_mods++extra_imported_mods)
 210         }
 211
 212                     -- The return-code pops the work stack by
 213                     -- incrementing Sp, and then jumpd to the popped item
 214     ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
 215                       , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ]
 216
 217 -----------------------
 218 registerModuleImport :: DynFlags -> String -> Module -> Code
 219 registerModuleImport dflags way mod
 220   | mod == gHC_PRIM
 221   = nopC
 222   | otherwise   -- Push the init procedure onto the work stack
 223   = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
 224            , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ]
 225 \end{code}
 226
 227
 228
 229 Cost-centre profiling: Besides the usual stuff, we must produce
 230 declarations for the cost-centres defined in this module;
 231
 232 (The local cost-centres involved in this are passed into the
 233 code-generator.)
 234
 235 \begin{code}
 236 initCostCentres :: CollectedCCs -> Code
 237 -- Emit the declarations, and return code to register them
 238 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
 239   | not opt_SccProfilingOn = nopC
 240   | otherwise
 241   = do  { mapM_ emitCostCentreDecl       local_CCs
 242         ; mapM_ emitCostCentreStackDecl  singleton_CCSs
 243         ; mapM_ emitRegisterCC           local_CCs
 244         ; mapM_ emitRegisterCCS          singleton_CCSs
 245         }
 246 \end{code}
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 @cgTopBinding@ is only used for top-level bindings, since they need
 255 to be allocated statically (not in the heap) and need to be labelled.
 256 No unboxed bindings can happen at top level.
 257
 258 In the code below, the static bindings are accumulated in the
 259 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 260 This is so that we can write the top level processing in a compositional
 261 style, with the increasing static environment being plumbed as a state
 262 variable.
 263
 264 \begin{code}
 265 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
 266 cgTopBinding dflags (StgNonRec id rhs, srts)
 267   = do  { id' <- maybeExternaliseId dflags id
 268         ; mapM_ (mkSRT dflags [id']) srts
 269         ; (id,info) <- cgTopRhs id' rhs
 270         ; addBindC id info      -- Add the *un-externalised* Id to the envt,
 271                                 -- so we find it when we look up occurrences
 272         }
 273
 274 cgTopBinding dflags (StgRec pairs, srts)
 275   = do  { let (bndrs, rhss) = unzip pairs
 276         ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
 277         ; let pairs' = zip bndrs' rhss
 278         ; mapM_ (mkSRT dflags bndrs')  srts
 279         ; _new_binds <- fixC (\ new_binds -> do
 280                 { addBindsC new_binds
 281                 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
 282         ; nopC }
 283
 284 mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code
 285 mkSRT dflags these (id,[])  = nopC
 286 mkSRT dflags these (id,ids)
 287   = do  { ids <- mapFCs remap ids
 288         ; id  <- remap id
 289         ; emitRODataLits (mkSRTLabel (idName id))
 290                        (map (CmmLabel . mkClosureLabel dflags . idName) ids)
 291         }
 292   where
 293         -- Sigh, better map all the ids against the environment in
 294         -- case they've been externalised (see maybeExternaliseId below).
 295     remap id = case filter (==id) these of
 296                 (id':_) -> returnFC id'
 297                 [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
 298
 299 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 300 -- to enclose the listFCs in cgTopBinding, but that tickled the
 301 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 302
 303 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 304         -- The Id is passed along for setting up a binding...
 305         -- It's already been externalised if necessary
 306
 307 cgTopRhs bndr (StgRhsCon cc con args)
 308   = forkStatics (cgTopRhsCon bndr con args)
 309
 310 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
 311   = ASSERT(null fvs)    -- There should be no free variables
 312     setSRTLabel (mkSRTLabel (idName bndr)) $
 313     forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body)
 314 \end{code}
 315
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection{Stuff to support splitting}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 If we're splitting the object, we need to externalise all the top-level names
 324 (and then make sure we only use the externalised one in any C label we use
 325 which refers to this name).
 326
 327 \begin{code}
 328 maybeExternaliseId :: DynFlags -> Id -> FCode Id
 329 maybeExternaliseId dflags id
 330   | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
 331     isInternalName name = do { mod <- moduleName
 332                              ; returnFC (setIdName id (externalise mod)) }
 333   | otherwise           = returnFC id
 334   where
 335     externalise mod = mkExternalName uniq mod new_occ Nothing loc
 336     name    = idName id
 337     uniq    = nameUnique name
 338     new_occ = mkLocalOcc uniq (nameOccName name)
 339     loc     = nameSrcLoc name
 340         -- We want to conjure up a name that can't clash with any
 341         -- existing name.  So we generate
 342         --      Mod_$L243foo
 343         -- where 243 is the unique.
 344 \end{code}