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 -- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
  23 -- import.  Before, that wasn't the case, and CM therefore didn't
  24 -- bother to compile it.
  25 import CgExpr           ( {-NOTHING!-} )        -- DO NOT DELETE THIS IMPORT
  26
  27 import StgSyn
  28 import CgMonad
  29 import AbsCSyn
  30 import CLabel           ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )
  31
  32 import PprAbsC          ( dumpRealC )
  33 import AbsCUtils        ( mkAbstractCs, flattenAbsC )
  34 import CgBindery        ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
  35 import CgClosure        ( cgTopRhsClosure )
  36 import CgCon            ( cgTopRhsCon )
  37 import CgConTbls        ( genStaticConBits )
  38 import ClosureInfo      ( mkClosureLFInfo )
  39 import CmdLineOpts      ( DynFlags, DynFlag(..),
  40                           opt_SccProfilingOn, opt_EnsureSplittableC )
  41 import CostCentre       ( CostCentre, CostCentreStack )
  42 import Id               ( Id, idName, setIdName )
  43 import Name             ( globaliseName )
  44 import Module           ( Module )
  45 import PrimRep          ( PrimRep(..) )
  46 import TyCon            ( TyCon, isDataTyCon )
  47 import BasicTypes       ( TopLevelFlag(..) )
  48 import UniqSupply       ( mkSplitUniqSupply )
  49 import ErrUtils         ( dumpIfSet_dyn, showPass )
  50 import Panic            ( assertPanic )
  51
  52 #ifdef DEBUG
  53 import Id               ( idCafInfo )
  54 import IdInfo           ( mayHaveCafRefs )
  55 import Outputable
  56 #endif
  57 \end{code}
  58
  59 \begin{code}
  60 codeGen :: DynFlags
  61         -> Module               -- Module name
  62         -> [Module]             -- Import names
  63         -> ([CostCentre],       -- Local cost-centres needing declaring/registering
  64             [CostCentre],       -- "extern" cost-centres needing declaring
  65             [CostCentreStack])  -- Pre-defined "singleton" cost centre stacks
  66         -> [Id]                 -- foreign-exported binders
  67         -> [TyCon]              -- Local tycons, including ones from classes
  68         -> [(StgBinding,[Id])]  -- Bindings to convert, with SRTs
  69         -> IO AbstractC         -- Output
  70
  71 codeGen dflags mod_name imported_modules cost_centre_info fe_binders
  72         tycons stg_binds
  73   = do  { showPass dflags "CodeGen"
  74
  75         ; fl_uniqs <- mkSplitUniqSupply 'f'
  76         ; let
  77             datatype_stuff = genStaticConBits cinfo data_tycons
  78             code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)
  79             init_stuff     = mkModuleInit fe_binders mod_name imported_modules
  80                                           cost_centre_info
  81
  82             abstractC = mkAbstractCs [ maybeSplitCode,
  83                                        init_stuff,
  84                                        code_stuff,
  85                                        datatype_stuff]
  86                 -- Put datatype_stuff after code_stuff, because the
  87                 -- datatype closure table (for enumeration types)
  88                 -- to (say) PrelBase_True_closure, which is defined in code_stuff
  89
  90             flat_abstractC = flattenAbsC fl_uniqs abstractC
  91
  92         ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
  93         ; return flat_abstractC
  94         }
  95   where
  96     data_tycons = filter isDataTyCon tycons
  97
  98     cinfo       = MkCompInfo mod_name
  99 \end{code}
 100
 101 %************************************************************************
 102 %*                                                                      *
 103 \subsection[codegen-init]{Module initialisation code}
 104 %*                                                                      *
 105 %************************************************************************
 106
 107 \begin{code}
 108 mkModuleInit
 109         :: [Id]                 -- foreign exported functions
 110         -> Module               -- module name
 111         -> [Module]             -- import names
 112         -> ([CostCentre],       -- cost centre info
 113             [CostCentre],
 114             [CostCentreStack])
 115         -> AbstractC
 116 mkModuleInit fe_binders mod imps cost_centre_info
 117   = let
 118         register_fes =
 119            map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
 120
 121         fe_labels =
 122            map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
 123
 124         (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
 125
 126         mk_import_register imp =
 127             CMacroStmt REGISTER_IMPORT [
 128                 CLbl (mkModuleInitLabel imp) AddrRep
 129             ]
 130
 131         register_imports = map mk_import_register imps
 132     in
 133     mkAbstractCs [
 134         cc_decls,
 135         CModuleInitBlock (mkModuleInitLabel mod)
 136                          (mkAbstractCs (register_fes ++
 137                                         cc_regs :
 138                                         register_imports))
 139     ]
 140 \end{code}
 141
 142 Cost-centre profiling: Besides the usual stuff, we must produce
 143 declarations for the cost-centres defined in this module;
 144
 145 (The local cost-centres involved in this are passed into the
 146 code-generator.)
 147
 148 \begin{code}
 149 mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
 150   | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
 151   | otherwise =
 152         ( mkAbstractCs (
 153                 map (CCostCentreDecl True)   local_CCs ++
 154                 map (CCostCentreDecl False)  extern_CCs ++
 155                 map CCostCentreStackDecl     singleton_CCSs),
 156           mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
 157         )
 158   where
 159     mkCcRegister ccs cc_stacks
 160       = let
 161             register_ccs       = mkAbstractCs (map mk_register ccs)
 162             register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
 163         in
 164         [ register_ccs, register_cc_stacks ]
 165       where
 166         mk_register cc
 167           = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
 168
 169         mk_register_ccs ccs
 170           = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
 171 \end{code}
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection[codegen-top-bindings]{Converting top-level STG bindings}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 @cgTopBinding@ is only used for top-level bindings, since they need
 180 to be allocated statically (not in the heap) and need to be labelled.
 181 No unboxed bindings can happen at top level.
 182
 183 In the code below, the static bindings are accumulated in the
 184 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 185 This is so that we can write the top level processing in a compositional
 186 style, with the increasing static environment being plumbed as a state
 187 variable.
 188
 189 \begin{code}
 190 cgTopBinding :: (StgBinding,[Id]) -> Code
 191 cgTopBinding (StgNonRec id rhs, srt)
 192   = absC maybeSplitCode         `thenC`
 193     maybeGlobaliseId id         `thenFC` \ id' ->
 194     let
 195         srt_label = mkSRTLabel (idName id')
 196     in
 197     mkSRT srt_label srt []      `thenC`
 198     setSRTLabel srt_label (
 199     cgTopRhs id' rhs            `thenFC` \ (id, info) ->
 200     addBindC id info
 201     )
 202
 203 cgTopBinding (StgRec pairs, srt)
 204   = absC maybeSplitCode                 `thenC`
 205     let
 206         (bndrs, rhss) = unzip pairs
 207     in
 208     mapFCs maybeGlobaliseId bndrs       `thenFC` \ bndrs'@(id:_) ->
 209     let
 210         srt_label = mkSRTLabel (idName id)
 211         pairs'    = zip bndrs' rhss
 212     in
 213     mkSRT srt_label srt bndrs'          `thenC`
 214     setSRTLabel srt_label (
 215        fixC (\ new_binds ->
 216                 addBindsC new_binds             `thenC`
 217                 mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
 218        )  `thenFC` \ new_binds -> nopC
 219     )
 220
 221 mkSRT :: CLabel -> [Id] -> [Id] -> Code
 222 mkSRT lbl []  these = nopC
 223 mkSRT lbl ids these
 224   = mapFCs remap ids `thenFC` \ ids ->
 225     absC (CSRT lbl (map (mkClosureLabel . idName) ids))
 226   where
 227         -- sigh, better map all the ids against the environment in case they've
 228         -- been globalised (see maybeGlobaliseId below).
 229     remap id = case filter (==id) these of
 230                 [] ->  getCAddrModeAndInfo id
 231                                 `thenFC` \ (id, _, _) -> returnFC id
 232                 (id':_) -> returnFC id'
 233
 234 -- if we're splitting the object, we need to globalise all the top-level names
 235 -- (and then make sure we only use the globalised one in any C label we use
 236 -- which refers to this name).
 237 maybeGlobaliseId :: Id -> FCode Id
 238 maybeGlobaliseId id
 239   = moduleName `thenFC` \ mod ->
 240     let
 241         name = idName id
 242
 243         -- globalise the name for -split-objs, if necessary
 244         real_name | opt_EnsureSplittableC = globaliseName name mod
 245                   | otherwise             = name
 246
 247         id' = setIdName id real_name
 248     in
 249     returnFC id'
 250
 251 maybeSplitCode
 252   | opt_EnsureSplittableC = CSplitMarker
 253   | otherwise             = AbsCNop
 254
 255 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 256 -- to enclose the listFCs in cgTopBinding, but that tickled the
 257 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 258
 259 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
 260         -- the Id is passed along for setting up a binding...
 261
 262 cgTopRhs bndr (StgRhsCon cc con args)
 263   = maybeGlobaliseId bndr `thenFC` \ bndr' ->
 264     forkStatics (cgTopRhsCon bndr con args)
 265
 266 cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
 267   =     -- There should be no free variables
 268     ASSERT(null fvs)
 269         -- If the closure is a thunk, then the binder must be recorded as such.
 270     ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
 271
 272     getSRTLabel `thenFC` \srt_label ->
 273     let lf_info =
 274           mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
 275     in
 276     maybeGlobaliseId bndr `thenFC` \ bndr' ->
 277     forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info)
 278 \end{code}