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