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