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 )
  26
  27 import PprAbsC          ( dumpRealC )
  28 import AbsCUtils        ( mkAbstractCs, mkAbsCStmts, 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 FiniteMap        ( FiniteMap )
  39 import Id               ( Id, idName )
  40 import Module           ( Module, moduleString, moduleName,
  41                           ModuleName, moduleNameString )
  42 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  43 import Type             ( Type )
  44 import TyCon            ( TyCon, isDataTyCon )
  45 import Class            ( Class, classTyCon )
  46 import BasicTypes       ( TopLevelFlag(..) )
  47 import UniqSupply       ( mkSplitUniqSupply )
  48 import ErrUtils         ( dumpIfSet )
  49 import Util
  50 import Panic            ( assertPanic )
  51 \end{code}
  52
  53 \begin{code}
  54
  55
  56 codeGen :: Module               -- Module name
  57         -> [ModuleName]         -- Import names
  58         -> ([CostCentre],       -- Local cost-centres needing declaring/registering
  59             [CostCentre],       -- "extern" cost-centres needing declaring
  60             [CostCentreStack])  -- Pre-defined "singleton" cost centre stacks
  61         -> [Id]                 -- foreign-exported binders
  62         -> [TyCon] -> [Class]   -- Local tycons and classes
  63         -> [(StgBinding,[Id])]  -- Bindings to convert, with SRTs
  64         -> IO AbstractC         -- Output
  65
  66 codeGen mod_name imported_modules cost_centre_info fe_binders
  67         tycons classes stg_binds
  68   = mkSplitUniqSupply 'f'       >>= \ fl_uniqs  -> -- absC flattener
  69     let
  70         datatype_stuff    = genStaticConBits cinfo data_tycons
  71         code_stuff        = initC cinfo (cgTopBindings maybe_split stg_binds)
  72         init_stuff        = mkModuleInit fe_binders mod_name imported_modules
  73                                          cost_centre_info
  74
  75         abstractC = mkAbstractCs [ init_stuff,
  76                                    datatype_stuff,
  77                                    code_stuff ]
  78
  79         flat_abstractC = flattenAbsC fl_uniqs abstractC
  80     in
  81     dumpIfSet 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         -> [ModuleName]         -- 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_reg_lbl mod_name
 121           = CLitLit (_PK_ ("__init_" ++ moduleNameString mod_name)) AddrRep
 122
 123         mk_import_register import_name
 124           = CMacroStmt REGISTER_IMPORT [mk_reg_lbl import_name]
 125
 126         register_imports = map mk_import_register imps
 127     in
 128     mkAbstractCs [
 129         cc_decls,
 130         CModuleInitBlock (mk_reg_lbl (Module.moduleName mod))
 131                          (mkAbstractCs (register_fes ++
 132                                         cc_regs :
 133                                         register_imports))
 134     ]
 135 \end{code}
 136
 137 Cost-centre profiling: Besides the usual stuff, we must produce
 138 declarations for the cost-centres defined in this module;
 139
 140 (The local cost-centres involved in this are passed into the
 141 code-generator.)
 142
 143 \begin{code}
 144 mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
 145   | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
 146   | otherwise =
 147         ( mkAbstractCs (
 148                 map (CCostCentreDecl True)   local_CCs ++
 149                 map (CCostCentreDecl False)  extern_CCs ++
 150                 map CCostCentreStackDecl     singleton_CCSs),
 151           mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
 152         )
 153   where
 154     mkCcRegister ccs cc_stacks
 155       = let
 156             register_ccs       = mkAbstractCs (map mk_register ccs)
 157             register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
 158         in
 159         [ register_ccs, register_cc_stacks ]
 160       where
 161         mk_register cc
 162           = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
 163
 164         mk_register_ccs ccs
 165           = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
 166 \end{code}
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 @cgTopBindings@ is only used for top-level bindings, since they need
 175 to be allocated statically (not in the heap) and need to be labelled.
 176 No unboxed bindings can happen at top level.
 177
 178 In the code below, the static bindings are accumulated in the
 179 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 180 This is so that we can write the top level processing in a compositional
 181 style, with the increasing static environment being plumbed as a state
 182 variable.
 183
 184 \begin{code}
 185 cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
 186
 187 cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
 188
 189 cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
 190
 191 cgTopBinding split ((StgNonRec name rhs), srt)
 192   = absC split                  `thenC`
 193     absC (mkSRT srt_label srt)  `thenC`
 194     setSRTLabel srt_label (
 195     cgTopRhs name rhs           `thenFC` \ (name, info) ->
 196     addBindC name info
 197     )
 198   where
 199     srt_label = mkSRTLabel (idName name)
 200
 201 cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
 202   = absC split                  `thenC`
 203     absC (mkSRT srt_label srt)  `thenC`
 204     setSRTLabel srt_label (
 205     fixC (\ new_binds -> addBindsC new_binds    `thenC`
 206                          mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
 207     )                     `thenFC` \ new_binds ->
 208     addBindsC new_binds
 209     )
 210   where
 211     srt_label = mkSRTLabel (idName name)
 212
 213 mkSRT :: CLabel -> [Id] -> AbstractC
 214 mkSRT lbl []  = AbsCNop
 215 mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
 216
 217 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 218 -- to enclose the listFCs in cgTopBinding, but that tickled the
 219 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 220
 221 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 222         -- the Id is passed along for setting up a binding...
 223
 224 cgTopRhs bndr (StgRhsCon cc con args)
 225   = forkStatics (cgTopRhsCon bndr con args (all zero_size args))
 226   where
 227     zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
 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}