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