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