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