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