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