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