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
  27 import DriverState      ( v_Build_tag, v_MainModIs )
  28 import StgSyn
  29 import CgMonad
  30 import AbsCSyn
  31 import PrelNames        ( gHC_PRIM, rOOT_MAIN, mAIN_Name, pREL_TOP_HANDLER )
  32 import CLabel           ( mkSRTLabel, mkClosureLabel,
  33                           mkPlainModuleInitLabel, mkModuleInitLabel )
  34 import PprAbsC          ( dumpRealC )
  35 import AbsCUtils        ( mkAbstractCs, flattenAbsC )
  36 import CgBindery        ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
  37 import CgClosure        ( cgTopRhsClosure )
  38 import CgCon            ( cgTopRhsCon )
  39 import CgConTbls        ( genStaticConBits )
  40 import ClosureInfo      ( mkClosureLFInfo )
  41 import CmdLineOpts      ( DynFlags, DynFlag(..),
  42                           opt_SccProfilingOn, opt_EnsureSplittableC )
  43 import HscTypes         ( ForeignStubs(..), TypeEnv, typeEnvTyCons )
  44 import CostCentre       ( CollectedCCs )
  45 import Id               ( Id, idName, setIdName )
  46 import Name             ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
  47 import OccName          ( mkLocalOcc )
  48 import PrimRep          ( PrimRep(..) )
  49 import TyCon            ( isDataTyCon )
  50 import Module           ( Module, mkModuleName )
  51 import BasicTypes       ( TopLevelFlag(..) )
  52 import UniqSupply       ( mkSplitUniqSupply )
  53 import ErrUtils         ( dumpIfSet_dyn, showPass )
  54 import Panic            ( assertPanic )
  55 import qualified Module ( moduleName )
  56
  57 #ifdef DEBUG
  58 import Outputable
  59 #endif
  60
  61 import DATA_IOREF       ( readIORef )
  62 \end{code}
  63
  64 \begin{code}
  65 codeGen :: DynFlags
  66         -> Module
  67         -> TypeEnv
  68         -> ForeignStubs
  69         -> [Module]             -- directly-imported modules
  70         -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
  71         -> [(StgBinding,[(Id,[Id])])]   -- Bindings to convert, with SRTs
  72         -> IO AbstractC         -- Output
  73
  74 codeGen dflags this_mod type_env foreign_stubs imported_mods
  75         cost_centre_info stg_binds
  76   = do
  77         showPass dflags "CodeGen"
  78         fl_uniqs <- mkSplitUniqSupply 'f'
  79         way <- readIORef v_Build_tag
  80         mb_main_mod <- readIORef v_MainModIs
  81
  82         let
  83             tycons         = typeEnvTyCons type_env
  84             data_tycons    = filter isDataTyCon tycons
  85
  86         mapM_ (\x -> seq x (return ())) data_tycons
  87
  88         let
  89
  90             cinfo          = MkCompInfo this_mod
  91
  92             datatype_stuff = genStaticConBits cinfo data_tycons
  93             code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)
  94             init_stuff     = mkModuleInit way cost_centre_info
  95                                           this_mod mb_main_mod
  96                                           foreign_stubs imported_mods
  97
  98             abstractC = mkAbstractCs [ maybeSplitCode,
  99                                        init_stuff,
 100                                        code_stuff,
 101                                        datatype_stuff]
 102                 -- Put datatype_stuff after code_stuff, because the
 103                 -- datatype closure table (for enumeration types) to
 104                 -- (say) PrelBase_True_closure, which is defined in
 105                 -- code_stuff
 106
 107         dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
 108
 109         return $! flattenAbsC fl_uniqs abstractC
 110 \end{code}
 111
 112 %************************************************************************
 113 %*                                                                      *
 114 \subsection[codegen-init]{Module initialisation code}
 115 %*                                                                      *
 116 %************************************************************************
 117
 118 \begin{code}
 119 mkModuleInit
 120         :: String               -- the "way"
 121         -> CollectedCCs         -- cost centre info
 122         -> Module
 123         -> Maybe String         -- Just m ==> we have flag: -main-is Foo.baz
 124         -> ForeignStubs
 125         -> [Module]
 126         -> AbstractC
 127 mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods
 128   = let
 129         (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
 130
 131         register_foreign_exports
 132                 = case foreign_stubs of
 133                         NoStubs                     -> []
 134                         ForeignStubs _ _ _ fe_bndrs -> map mk_export_register fe_bndrs
 135
 136         mk_export_register bndr
 137           = CMacroStmt REGISTER_FOREIGN_EXPORT [lbl]
 138           where
 139             lbl = CLbl (mkClosureLabel (idName bndr)) PtrRep
 140                 -- we don't want/need to init GHC.Prim, so filter it out
 141
 142         mk_import_register mod
 143             | mod == gHC_PRIM = AbsCNop
 144             | otherwise       = CMacroStmt REGISTER_IMPORT [
 145                                    CLbl (mkModuleInitLabel mod way) AddrRep
 146                                 ]
 147
 148         extra_imported_mods
 149           | Module.moduleName this_mod == main_mod_name = [ pREL_TOP_HANDLER ]
 150           | otherwise                                   = [ ]
 151
 152         register_mod_imports =
 153                 map mk_import_register (imported_mods ++ extra_imported_mods)
 154
 155         -- When compiling the module in which the 'main' function lives,
 156         -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
 157         -- RTS to invoke.  We must consult the -main-is flag in case the
 158         -- user specified a different function to Main.main
 159         main_mod_name = case mb_main_mod of
 160                           Just mod_name -> mkModuleName mod_name
 161                           Nothing       -> mAIN_Name
 162         main_init_block
 163           | Module.moduleName this_mod /= main_mod_name
 164           = AbsCNop     -- The normal case
 165           | otherwise   -- this_mod contains the main function
 166           = CCodeBlock (mkPlainModuleInitLabel rOOT_MAIN)
 167                        (CJump (CLbl (mkPlainModuleInitLabel this_mod) CodePtrRep))
 168
 169     in
 170     mkAbstractCs [
 171         cc_decls,
 172         CModuleInitBlock (mkPlainModuleInitLabel this_mod)
 173                          (mkModuleInitLabel this_mod way)
 174                          (mkAbstractCs (register_foreign_exports ++
 175                                         cc_regs :
 176                                         register_mod_imports)),
 177         main_init_block
 178     ]
 179 \end{code}
 180
 181 Cost-centre profiling: Besides the usual stuff, we must produce
 182 declarations for the cost-centres defined in this module;
 183
 184 (The local cost-centres involved in this are passed into the
 185 code-generator.)
 186
 187 \begin{code}
 188 mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
 189   | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
 190   | otherwise =
 191         ( mkAbstractCs (
 192                 map (CCostCentreDecl True)   local_CCs ++
 193                 map (CCostCentreDecl False)  extern_CCs ++
 194                 map CCostCentreStackDecl     singleton_CCSs),
 195           mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
 196         )
 197   where
 198     mkCcRegister ccs cc_stacks
 199       = let
 200             register_ccs       = mkAbstractCs (map mk_register ccs)
 201             register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
 202         in
 203         [ register_ccs, register_cc_stacks ]
 204       where
 205         mk_register cc
 206           = CCallProfCCMacro FSLIT("REGISTER_CC") [mkCCostCentre cc]
 207
 208         mk_register_ccs ccs
 209           = CCallProfCCMacro FSLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
 210 \end{code}
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 @cgTopBinding@ is only used for top-level bindings, since they need
 219 to be allocated statically (not in the heap) and need to be labelled.
 220 No unboxed bindings can happen at top level.
 221
 222 In the code below, the static bindings are accumulated in the
 223 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 224 This is so that we can write the top level processing in a compositional
 225 style, with the increasing static environment being plumbed as a state
 226 variable.
 227
 228 \begin{code}
 229 cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code
 230 cgTopBinding (StgNonRec id rhs, srts)
 231   = absC maybeSplitCode         `thenC`
 232     maybeExternaliseId id       `thenFC` \ id' ->
 233     mapM_ (mkSRT [id']) srts    `thenC`
 234     cgTopRhs id' rhs            `thenFC` \ (id, info) ->
 235     addBindC id info            `thenC`
 236         -- Add the un-externalised Id to the envt, so we
 237         -- find it when we look up occurrences
 238     nopC
 239
 240 cgTopBinding (StgRec pairs, srts)
 241   = absC maybeSplitCode                 `thenC`
 242     let
 243         (bndrs, rhss) = unzip pairs
 244     in
 245     mapFCs maybeExternaliseId bndrs     `thenFC` \ bndrs' ->
 246     let
 247         pairs' = zip bndrs' rhss
 248     in
 249     mapM_ (mkSRT bndrs')  srts          `thenC`
 250     fixC (\ new_binds ->
 251                 addBindsC new_binds             `thenC`
 252                 mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
 253      )  `thenFC` \ new_binds ->
 254      nopC
 255
 256 mkSRT :: [Id] -> (Id,[Id]) -> Code
 257 mkSRT these (id,[])  = nopC
 258 mkSRT these (id,ids)
 259   = mapFCs remap ids `thenFC` \ ids ->
 260     remap id         `thenFC` \ id ->
 261     absC (CSRT (mkSRTLabel (idName id)) (map (mkClosureLabel . idName) ids))
 262   where
 263         -- sigh, better map all the ids against the environment in case they've
 264         -- been externalised (see maybeExternaliseId below).
 265     remap id = case filter (==id) these of
 266                 [] ->  getCAddrModeAndInfo id
 267                                 `thenFC` \ (id, _, _) -> returnFC id
 268                 (id':_) -> returnFC id'
 269
 270 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 271 -- to enclose the listFCs in cgTopBinding, but that tickled the
 272 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 273
 274 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 275         -- The Id is passed along for setting up a binding...
 276         -- It's already been externalised if necessary
 277
 278 cgTopRhs bndr (StgRhsCon cc con args)
 279   = forkStatics (cgTopRhsCon bndr con args)
 280
 281 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
 282   = ASSERT(null fvs)    -- There should be no free variables
 283     let
 284         srt_label = mkSRTLabel (idName bndr)
 285         lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
 286     in
 287     setSRTLabel srt_label $
 288       forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
 289 \end{code}
 290
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{Stuff to support splitting}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 If we're splitting the object, we need to externalise all the top-level names
 299 (and then make sure we only use the externalised one in any C label we use
 300 which refers to this name).
 301
 302 \begin{code}
 303 maybeExternaliseId :: Id -> FCode Id
 304 maybeExternaliseId id
 305   | opt_EnsureSplittableC,      -- Externalise the name for -split-objs
 306     isInternalName name
 307   = moduleName                           `thenFC` \ mod ->
 308     returnFC (setIdName id (mkExternalName uniq mod new_occ Nothing (nameSrcLoc name)))
 309   | otherwise
 310   = returnFC id
 311   where
 312     name       = idName id
 313     uniq       = nameUnique name
 314     new_occ    = mkLocalOcc uniq (nameOccName name)
 315         -- We want to conjure up a name that can't clash with any
 316         -- existing name.  So we generate
 317         --      Mod_$L243foo
 318         -- where 243 is the unique.
 319
 320 maybeSplitCode
 321   | opt_EnsureSplittableC = CSplitMarker
 322   | otherwise             = AbsCNop
 323 \end{code}