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 StgSyn
  23 import CgMonad
  24 import AbsCSyn
  25 import CLabel           ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )
  26
  27 import PprAbsC          ( dumpRealC )
  28 import AbsCUtils        ( mkAbstractCs, flattenAbsC )
  29 import CgBindery        ( CgIdInfo, addBindC, addBindsC )
  30 import CgClosure        ( cgTopRhsClosure )
  31 import CgCon            ( cgTopRhsCon )
  32 import CgConTbls        ( genStaticConBits )
  33 import ClosureInfo      ( mkClosureLFInfo )
  34 import CmdLineOpts      ( opt_SccProfilingOn, opt_EnsureSplittableC,
  35                           opt_D_dump_absC
  36                         )
  37 import CostCentre       ( CostCentre, CostCentreStack )
  38 import Id               ( Id, idName )
  39 import Module           ( Module, moduleString, moduleName,
  40                           ModuleName )
  41 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  42 import Type             ( Type )
  43 import TyCon            ( TyCon, isDataTyCon )
  44 import Class            ( Class, classTyCon )
  45 import BasicTypes       ( TopLevelFlag(..) )
  46 import UniqSupply       ( mkSplitUniqSupply )
  47 import ErrUtils         ( dumpIfSet )
  48 import Util
  49 import Panic            ( assertPanic )
  50 \end{code}
  51
  52 \begin{code}
  53
  54
  55 codeGen :: Module               -- Module name
  56         -> [ModuleName]         -- Import names
  57         -> ([CostCentre],       -- Local cost-centres needing declaring/registering
  58             [CostCentre],       -- "extern" cost-centres needing declaring
  59             [CostCentreStack])  -- Pre-defined "singleton" cost centre stacks
  60         -> [Id]                 -- foreign-exported binders
  61         -> [TyCon] -> [Class]   -- Local tycons and classes
  62         -> [(StgBinding,[Id])]  -- Bindings to convert, with SRTs
  63         -> IO AbstractC         -- Output
  64
  65 codeGen mod_name imported_modules cost_centre_info fe_binders
  66         tycons classes stg_binds
  67   = mkSplitUniqSupply 'f'       >>= \ fl_uniqs  -> -- absC flattener
  68     let
  69         datatype_stuff    = genStaticConBits cinfo data_tycons
  70         code_stuff        = initC cinfo (cgTopBindings maybe_split stg_binds)
  71         init_stuff        = mkModuleInit fe_binders mod_name imported_modules
  72                                          cost_centre_info
  73
  74         abstractC = mkAbstractCs [ maybe_split,
  75                                    init_stuff,
  76                                    code_stuff,
  77                                    datatype_stuff]
  78                 -- Put datatype_stuff after code_stuff, because the
  79                 -- datatype closure table (for enumeration types)
  80                 -- to (say) PrelBase_True_closure, which is defined in code_stuff
  81
  82         flat_abstractC = flattenAbsC fl_uniqs abstractC
  83     in
  84     dumpIfSet opt_D_dump_absC "Abstract C" (dumpRealC abstractC)        >>
  85     return flat_abstractC
  86
  87   where
  88     data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
  89                         -- Generate info tables  for the data constrs arising
  90                         -- from class decls as well
  91
  92     maybe_split = if opt_EnsureSplittableC
  93                   then CSplitMarker
  94                   else AbsCNop
  95     cinfo       = MkCompInfo mod_name
  96 \end{code}
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection[codegen-init]{Module initialisation code}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 mkModuleInit
 106         :: [Id]                 -- foreign exported functions
 107         -> Module               -- module name
 108         -> [ModuleName]         -- import names
 109         -> ([CostCentre],       -- cost centre info
 110             [CostCentre],
 111             [CostCentreStack])
 112         -> AbstractC
 113 mkModuleInit fe_binders mod imps cost_centre_info
 114   = let
 115         register_fes =
 116            map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
 117
 118         fe_labels =
 119            map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
 120
 121         (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
 122
 123         mk_import_register import_name
 124           = CMacroStmt REGISTER_IMPORT [
 125                 CLbl (mkModuleInitLabel import_name) AddrRep
 126             ]
 127
 128         register_imports = map mk_import_register imps
 129     in
 130     mkAbstractCs [
 131         cc_decls,
 132         CModuleInitBlock (mkModuleInitLabel (Module.moduleName mod))
 133                          (mkAbstractCs (register_fes ++
 134                                         cc_regs :
 135                                         register_imports))
 136     ]
 137 \end{code}
 138
 139 Cost-centre profiling: Besides the usual stuff, we must produce
 140 declarations for the cost-centres defined in this module;
 141
 142 (The local cost-centres involved in this are passed into the
 143 code-generator.)
 144
 145 \begin{code}
 146 mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
 147   | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
 148   | otherwise =
 149         ( mkAbstractCs (
 150                 map (CCostCentreDecl True)   local_CCs ++
 151                 map (CCostCentreDecl False)  extern_CCs ++
 152                 map CCostCentreStackDecl     singleton_CCSs),
 153           mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
 154         )
 155   where
 156     mkCcRegister ccs cc_stacks
 157       = let
 158             register_ccs       = mkAbstractCs (map mk_register ccs)
 159             register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
 160         in
 161         [ register_ccs, register_cc_stacks ]
 162       where
 163         mk_register cc
 164           = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
 165
 166         mk_register_ccs ccs
 167           = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
 168 \end{code}
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 @cgTopBindings@ is only used for top-level bindings, since they need
 177 to be allocated statically (not in the heap) and need to be labelled.
 178 No unboxed bindings can happen at top level.
 179
 180 In the code below, the static bindings are accumulated in the
 181 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 182 This is so that we can write the top level processing in a compositional
 183 style, with the increasing static environment being plumbed as a state
 184 variable.
 185
 186 \begin{code}
 187 cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
 188
 189 cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
 190
 191 cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
 192
 193 cgTopBinding split ((StgNonRec name rhs), srt)
 194   = absC split                  `thenC`
 195     absC (mkSRT srt_label srt)  `thenC`
 196     setSRTLabel srt_label (
 197     cgTopRhs name rhs           `thenFC` \ (name, info) ->
 198     addBindC name info
 199     )
 200   where
 201     srt_label = mkSRTLabel (idName name)
 202
 203 cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
 204   = absC split                  `thenC`
 205     absC (mkSRT srt_label srt)  `thenC`
 206     setSRTLabel srt_label (
 207     fixC (\ new_binds -> addBindsC new_binds    `thenC`
 208                          mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
 209     )                     `thenFC` \ new_binds ->
 210     addBindsC new_binds
 211     )
 212   where
 213     srt_label = mkSRTLabel (idName name)
 214
 215 mkSRT :: CLabel -> [Id] -> AbstractC
 216 mkSRT lbl []  = AbsCNop
 217 mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
 218
 219 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 220 -- to enclose the listFCs in cgTopBinding, but that tickled the
 221 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 222
 223 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 224         -- the Id is passed along for setting up a binding...
 225
 226 cgTopRhs bndr (StgRhsCon cc con args)
 227   = forkStatics (cgTopRhsCon bndr con args)
 228
 229 cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
 230   = ASSERT(null fvs) -- There should be no free variables
 231     getSRTLabel `thenFC` \srt_label ->
 232     let lf_info =
 233           mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
 234     in
 235     forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)
 236 \end{code}