compiler/codeGen/StgCmm.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Stg to C-- code generation
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmm ( codeGen ) where
  10
  11 #define FAST_STRING_NOT_NEEDED
  12 #include "HsVersions.h"
  13
  14 import StgCmmProf
  15 import StgCmmMonad
  16 import StgCmmEnv
  17 import StgCmmBind
  18 import StgCmmCon
  19 import StgCmmLayout
  20 import StgCmmHeap
  21 import StgCmmUtils
  22 import StgCmmClosure
  23 import StgCmmHpc
  24 import StgCmmTicky
  25
  26 import MkZipCfgCmm
  27 import Cmm
  28 import CmmUtils
  29 import CLabel
  30 import PprCmm
  31
  32 import StgSyn
  33 import PrelNames
  34 import DynFlags
  35 import StaticFlags
  36
  37 import HscTypes
  38 import CostCentre
  39 import Id
  40 import IdInfo
  41 import Type
  42 import DataCon
  43 import Name
  44 import OccName
  45 import TyCon
  46 import Module
  47 import ErrUtils
  48 import Outputable
  49
  50 codeGen :: DynFlags
  51          -> Module
  52          -> [TyCon]
  53          -> [Module]                    -- Directly-imported modules
  54          -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
  55          -> [(StgBinding,[(Id,[Id])])]  -- Bindings to convert, with SRTs
  56          -> HpcInfo
  57          -> IO [CmmZ]           -- Output
  58
  59 codeGen dflags this_mod data_tycons imported_mods
  60         cost_centre_info stg_binds hpc_info
  61   = do  { showPass dflags "New CodeGen"
  62         ; let way = buildTag dflags
  63               main_mod = mainModIs dflags
  64
  65 -- Why?
  66 --   ; mapM_ (\x -> seq x (return ())) data_tycons
  67
  68         ; code_stuff <- initC dflags this_mod $ do
  69                 { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
  70                 ; cmm_tycons <- mapM cgTyCon data_tycons
  71                 ; cmm_init   <- getCmm (mkModuleInit way cost_centre_info
  72                                              this_mod main_mod
  73                                              imported_mods hpc_info)
  74                 ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
  75                 }
  76                 -- Put datatype_stuff after code_stuff, because the
  77                 -- datatype closure table (for enumeration types) to
  78                 -- (say) PrelBase_True_closure, which is defined in
  79                 -- code_stuff
  80
  81                 -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
  82                 -- possible for object splitting to split up the
  83                 -- pieces later.
  84
  85         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
  86
  87         ; return code_stuff }
  88
  89
  90 ---------------------------------------------------------------
  91 --      Top-level bindings
  92 ---------------------------------------------------------------
  93
  94 {- 'cgTopBinding' is only used for top-level bindings, since they need
  95 to be allocated statically (not in the heap) and need to be labelled.
  96 No unboxed bindings can happen at top level.
  97
  98 In the code below, the static bindings are accumulated in the
  99 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
 100 This is so that we can write the top level processing in a compositional
 101 style, with the increasing static environment being plumbed as a state
 102 variable. -}
 103
 104 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
 105 cgTopBinding dflags (StgNonRec id rhs, _srts)
 106   = do  { id' <- maybeExternaliseId dflags id
 107         ; info <- cgTopRhs id' rhs
 108         ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
 109                                      -- so we find it when we look up occurrences
 110         }
 111
 112 cgTopBinding dflags (StgRec pairs, _srts)
 113   = do  { let (bndrs, rhss) = unzip pairs
 114         ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
 115         ; let pairs' = zip bndrs' rhss
 116         ; fixC (\ new_binds -> do
 117                 { addBindsC new_binds
 118                 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
 119         ; return () }
 120
 121 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 122 -- to enclose the listFCs in cgTopBinding, but that tickled the
 123 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 124
 125 cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
 126         -- The Id is passed along for setting up a binding...
 127         -- It's already been externalised if necessary
 128
 129 cgTopRhs bndr (StgRhsCon _cc con args)
 130   = forkStatics (cgTopRhsCon bndr con args)
 131
 132 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
 133   = ASSERT(null fvs)    -- There should be no free variables
 134     setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
 135     forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
 136
 137
 138 ---------------------------------------------------------------
 139 --      Module initialisation code
 140 ---------------------------------------------------------------
 141
 142 {- The module initialisation code looks like this, roughly:
 143
 144         FN(__stginit_Foo) {
 145           JMP_(__stginit_Foo_1_p)
 146         }
 147
 148         FN(__stginit_Foo_1_p) {
 149         ...
 150         }
 151
 152    We have one version of the init code with a module version and the
 153    'way' attached to it.  The version number helps to catch cases
 154    where modules are not compiled in dependency order before being
 155    linked: if a module has been compiled since any modules which depend on
 156    it, then the latter modules will refer to a different version in their
 157    init blocks and a link error will ensue.
 158
 159    The 'way' suffix helps to catch cases where modules compiled in different
 160    ways are linked together (eg. profiled and non-profiled).
 161
 162    We provide a plain, unadorned, version of the module init code
 163    which just jumps to the version with the label and way attached.  The
 164    reason for this is that when using foreign exports, the caller of
 165    startupHaskell() must supply the name of the init function for the "top"
 166    module in the program, and we don't want to require that this name
 167    has the version and way info appended to it.
 168
 169 We initialise the module tree by keeping a work-stack,
 170         * pointed to by Sp
 171         * that grows downward
 172         * Sp points to the last occupied slot
 173 -}
 174
 175 mkModuleInit
 176         :: String               -- the "way"
 177         -> CollectedCCs         -- cost centre info
 178         -> Module
 179         -> Module               -- name of the Main module
 180         -> [Module]
 181         -> HpcInfo
 182         -> FCode ()
 183 mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
 184   = do  { -- Allocate the static boolean that records if this
 185           -- module has been registered already
 186           emitData Data [CmmDataLabel moduleRegdLabel,
 187                          CmmStaticLit zeroCLit]
 188
 189         ; init_hpc  <- initHpc this_mod hpc_info
 190         ; init_prof <- initCostCentres cost_centre_info
 191
 192           -- We emit a recursive descent module search for all modules
 193           -- and *choose* to chase it in :Main, below.
 194           -- In this way, Hpc enabled modules can interact seamlessly with
 195           -- not Hpc enabled moduled, provided Main is compiled with Hpc.
 196
 197         ; updfr_sz <- getUpdFrameOff
 198         ; tail <- getCode (pushUpdateFrame imports
 199                        (do updfr_sz' <- getUpdFrameOff
 200                            emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
 201         ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
 202                 [ check_already_done retId updfr_sz
 203                 , init_prof
 204                 , init_hpc
 205                 , tail])
 206             -- Make the "plain" procedure jump to the "real" init procedure
 207         ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
 208
 209         -- When compiling the module in which the 'main' function lives,
 210         -- (that is, this_mod == main_mod)
 211         -- we inject an extra stg_init procedure for stg_init_ZCMain, for the
 212         -- RTS to invoke.  We must consult the -main-is flag in case the
 213         -- user specified a different function to Main.main
 214
 215         -- Notice that the recursive descent is optional, depending on what options
 216         -- are enabled.
 217
 218
 219         ; whenC (this_mod == main_mod)
 220                 (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
 221     }
 222   where
 223     plain_init_lbl = mkPlainModuleInitLabel this_mod
 224     real_init_lbl  = mkModuleInitLabel this_mod way
 225     plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
 226
 227     jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
 228
 229
 230     -- Main refers to GHC.TopHandler.runIO, so make sure we call the
 231     -- init function for GHC.TopHandler.
 232     extra_imported_mods
 233         | this_mod == main_mod = [gHC_TOP_HANDLER]
 234         | otherwise            = []
 235     all_imported_mods = imported_mods ++ extra_imported_mods
 236     imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
 237                   (filter (gHC_PRIM /=) all_imported_mods)
 238
 239     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
 240     check_already_done retId updfr_sz
 241      = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
 242                        (mkLabel retId emptyStackInfo
 243                     <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
 244         <*>     -- Set mod_reg to 1 to record that we've been here
 245             mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
 246
 247                     -- The return-code pops the work stack by
 248                     -- incrementing Sp, and then jumps to the popped item
 249     ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
 250     ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
 251       -- mkAssign spReg (cmmRegOffW spReg 1) <*>
 252       -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
 253
 254     pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
 255
 256     rec_descent_init updfr_sz =
 257       if opt_SccProfilingOn || isHpcUsed hpc_info
 258       then jump_to_init updfr_sz
 259       else ret_code updfr_sz
 260
 261 ---------------------------------------------------------------
 262 --      Generating static stuff for algebraic data types
 263 ---------------------------------------------------------------
 264
 265 {-      [These comments are rather out of date]
 266
 267 Macro                        Kind of constructor
 268 CONST_INFO_TABLE@       Zero arity (no info -- compiler uses static closure)
 269 CHARLIKE_INFO_TABLE     Charlike   (no info -- compiler indexes fixed array)
 270 INTLIKE_INFO_TABLE      Intlike; the one macro generates both info tbls
 271 SPEC_INFO_TABLE         SPECish, and bigger than or equal to MIN_UPD_SIZE
 272 GEN_INFO_TABLE          GENish (hence bigger than or equal to MIN_UPD_SIZE@)
 273
 274 Possible info tables for constructor con:
 275
 276 * _con_info:
 277   Used for dynamically let(rec)-bound occurrences of
 278   the constructor, and for updates.  For constructors
 279   which are int-like, char-like or nullary, when GC occurs,
 280   the closure tries to get rid of itself.
 281
 282 * _static_info:
 283   Static occurrences of the constructor macro: STATIC_INFO_TABLE.
 284
 285 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
 286 it's place is taken by the top level defn of the constructor.
 287
 288 For charlike and intlike closures there is a fixed array of static
 289 closures predeclared.
 290 -}
 291
 292 cgTyCon :: TyCon -> FCode [CmmZ]  -- All constructors merged together
 293 cgTyCon tycon
 294   = do  { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
 295
 296             -- Generate a table of static closures for an enumeration type
 297             -- Put the table after the data constructor decls, because the
 298             -- datatype closure table (for enumeration types)
 299             -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
 300             -- Note that the closure pointers are tagged.
 301
 302             -- N.B. comment says to put table after constructor decls, but
 303             -- code puts it before --- NR 16 Aug 2007
 304         ; extra <- cgEnumerationTyCon tycon
 305
 306         ; return (extra ++ constrs)
 307         }
 308
 309 cgEnumerationTyCon :: TyCon -> FCode [CmmZ]
 310 cgEnumerationTyCon tycon
 311   | isEnumerationTyCon tycon
 312   = do  { tbl <- getCmm $
 313                  emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
 314                    [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
 315                                  (tagForCon con)
 316                    | con <- tyConDataCons tycon]
 317         ; return [tbl] }
 318   | otherwise
 319   = return []
 320
 321 cgDataCon :: DataCon -> FCode ()
 322 -- Generate the entry code, info tables, and (for niladic constructor)
 323 -- the static closure, for a constructor.
 324 cgDataCon data_con
 325   = do  { let
 326             -- To allow the debuggers, interpreters, etc to cope with
 327             -- static data structures (ie those built at compile
 328             -- time), we take care that info-table contains the
 329             -- information we need.
 330             (static_cl_info, _) = layOutStaticConstr data_con arg_reps
 331             (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
 332
 333             emit_info cl_info ticky_code
 334                 = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code
 335
 336             mk_code ticky_code
 337               =         -- NB: We don't set CC when entering data (WDP 94/06)
 338                 do { ticky_code
 339                    ; ldvEnter (CmmReg nodeReg)
 340                    ; tickyReturnOldCon (length arg_things)
 341                    ; emitReturn [cmmOffsetB (CmmReg nodeReg)
 342                                             (tagForCon data_con)] }
 343                         -- The case continuation code expects a tagged pointer
 344
 345             arg_reps :: [(PrimRep, Type)]
 346             arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
 347
 348             -- Dynamic closure code for non-nullary constructors only
 349         ; whenC (not (isNullaryRepDataCon data_con))
 350                 (emit_info dyn_cl_info tickyEnterDynCon)
 351
 352                 -- Dynamic-Closure first, to reduce forward references
 353         ; emit_info static_cl_info tickyEnterStaticCon }
 354
 355
 356 ---------------------------------------------------------------
 357 --      Stuff to support splitting
 358 ---------------------------------------------------------------
 359
 360 -- If we're splitting the object, we need to externalise all the
 361 -- top-level names (and then make sure we only use the externalised
 362 -- one in any C label we use which refers to this name).
 363
 364 maybeExternaliseId :: DynFlags -> Id -> FCode Id
 365 maybeExternaliseId dflags id
 366   | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
 367     isInternalName name = do { mod <- getModuleName
 368                              ; returnFC (setIdName id (externalise mod)) }
 369   | otherwise           = returnFC id
 370   where
 371     externalise mod = mkExternalName uniq mod new_occ loc
 372     name    = idName id
 373     uniq    = nameUnique name
 374     new_occ = mkLocalOcc uniq (nameOccName name)
 375     loc     = nameSrcSpan name
 376         -- We want to conjure up a name that can't clash with any
 377         -- existing name.  So we generate
 378         --      Mod_$L243foo
 379         -- where 243 is the unique.