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