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 MkGraph
  27 import CmmExpr
  28 import CLabel
  29 import PprCmm
  30
  31 import StgSyn
  32 import DynFlags
  33
  34 import HscTypes
  35 import CostCentre
  36 import Id
  37 import IdInfo
  38 import Type
  39 import DataCon
  40 import Name
  41 import TyCon
  42 import Module
  43 import ErrUtils
  44 import Outputable
  45
  46 codeGen :: DynFlags
  47          -> Module
  48          -> [TyCon]
  49          -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
  50          -> [(StgBinding,[(Id,[Id])])]  -- Bindings to convert, with SRTs
  51          -> HpcInfo
  52          -> IO [Cmm]            -- Output
  53
  54 codeGen dflags this_mod data_tycons
  55         cost_centre_info stg_binds hpc_info
  56   = do  { showPass dflags "New CodeGen"
  57
  58 -- Why?
  59 --   ; mapM_ (\x -> seq x (return ())) data_tycons
  60
  61         ; code_stuff <- initC dflags this_mod $ do
  62                 { cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
  63                 ; cmm_tycons <- mapM cgTyCon data_tycons
  64                 ; cmm_init   <- getCmm (mkModuleInit cost_centre_info
  65                                              this_mod hpc_info)
  66                 ; return (cmm_init : cmm_binds ++ concat cmm_tycons)
  67                 }
  68                 -- Put datatype_stuff after code_stuff, because the
  69                 -- datatype closure table (for enumeration types) to
  70                 -- (say) PrelBase_True_closure, which is defined in
  71                 -- code_stuff
  72
  73                 -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
  74                 -- possible for object splitting to split up the
  75                 -- pieces later.
  76
  77                 -- Note [codegen-split-init] the cmm_init block must
  78                 -- come FIRST.  This is because when -split-objs is on
  79                 -- we need to combine this block with its
  80                 -- initialisation routines; see Note
  81                 -- [pipeline-split-init].
  82
  83         ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
  84
  85         ; return code_stuff }
  86
  87
  88 ---------------------------------------------------------------
  89 --      Top-level bindings
  90 ---------------------------------------------------------------
  91
  92 {- 'cgTopBinding' is only used for top-level bindings, since they need
  93 to be allocated statically (not in the heap) and need to be labelled.
  94 No unboxed bindings can happen at top level.
  95
  96 In the code below, the static bindings are accumulated in the
  97 @MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
  98 This is so that we can write the top level processing in a compositional
  99 style, with the increasing static environment being plumbed as a state
 100 variable. -}
 101
 102 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
 103 cgTopBinding dflags (StgNonRec id rhs, _srts)
 104   = do  { id' <- maybeExternaliseId dflags id
 105         ; info <- cgTopRhs id' rhs
 106         ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
 107                                      -- so we find it when we look up occurrences
 108         }
 109
 110 cgTopBinding dflags (StgRec pairs, _srts)
 111   = do  { let (bndrs, rhss) = unzip pairs
 112         ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
 113         ; let pairs' = zip bndrs' rhss
 114         ; fixC_(\ new_binds -> do
 115                 { addBindsC new_binds
 116                 ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
 117         ; return () }
 118
 119 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 120 -- to enclose the listFCs in cgTopBinding, but that tickled the
 121 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 122
 123 cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
 124         -- The Id is passed along for setting up a binding...
 125         -- It's already been externalised if necessary
 126
 127 cgTopRhs bndr (StgRhsCon _cc con args)
 128   = forkStatics (cgTopRhsCon bndr con args)
 129
 130 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
 131   = ASSERT(null fvs)    -- There should be no free variables
 132     setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
 133     forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
 134
 135
 136 ---------------------------------------------------------------
 137 --      Module initialisation code
 138 ---------------------------------------------------------------
 139
 140 {- The module initialisation code looks like this, roughly:
 141
 142         FN(__stginit_Foo) {
 143           JMP_(__stginit_Foo_1_p)
 144         }
 145
 146         FN(__stginit_Foo_1_p) {
 147         ...
 148         }
 149
 150    We have one version of the init code with a module version and the
 151    'way' attached to it.  The version number helps to catch cases
 152    where modules are not compiled in dependency order before being
 153    linked: if a module has been compiled since any modules which depend on
 154    it, then the latter modules will refer to a different version in their
 155    init blocks and a link error will ensue.
 156
 157    The 'way' suffix helps to catch cases where modules compiled in different
 158    ways are linked together (eg. profiled and non-profiled).
 159
 160    We provide a plain, unadorned, version of the module init code
 161    which just jumps to the version with the label and way attached.  The
 162    reason for this is that when using foreign exports, the caller of
 163    startupHaskell() must supply the name of the init function for the "top"
 164    module in the program, and we don't want to require that this name
 165    has the version and way info appended to it.
 166
 167 We initialise the module tree by keeping a work-stack,
 168         * pointed to by Sp
 169         * that grows downward
 170         * Sp points to the last occupied slot
 171 -}
 172
 173 mkModuleInit
 174         :: CollectedCCs         -- cost centre info
 175         -> Module
 176         -> HpcInfo
 177         -> FCode ()
 178
 179 mkModuleInit cost_centre_info this_mod hpc_info
 180   = do  { initHpc this_mod hpc_info
 181         ; initCostCentres cost_centre_info
 182             -- For backwards compatibility: user code may refer to this
 183             -- label for calling hs_add_root().
 184         ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ emptyAGraph
 185         }
 186
 187 ---------------------------------------------------------------
 188 --      Generating static stuff for algebraic data types
 189 ---------------------------------------------------------------
 190
 191 {-      [These comments are rather out of date]
 192
 193 Macro                        Kind of constructor
 194 CONST_INFO_TABLE@       Zero arity (no info -- compiler uses static closure)
 195 CHARLIKE_INFO_TABLE     Charlike   (no info -- compiler indexes fixed array)
 196 INTLIKE_INFO_TABLE      Intlike; the one macro generates both info tbls
 197 SPEC_INFO_TABLE         SPECish, and bigger than or equal to MIN_UPD_SIZE
 198 GEN_INFO_TABLE          GENish (hence bigger than or equal to MIN_UPD_SIZE@)
 199
 200 Possible info tables for constructor con:
 201
 202 * _con_info:
 203   Used for dynamically let(rec)-bound occurrences of
 204   the constructor, and for updates.  For constructors
 205   which are int-like, char-like or nullary, when GC occurs,
 206   the closure tries to get rid of itself.
 207
 208 * _static_info:
 209   Static occurrences of the constructor macro: STATIC_INFO_TABLE.
 210
 211 For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
 212 it's place is taken by the top level defn of the constructor.
 213
 214 For charlike and intlike closures there is a fixed array of static
 215 closures predeclared.
 216 -}
 217
 218 cgTyCon :: TyCon -> FCode [Cmm]  -- All constructors merged together
 219 cgTyCon tycon
 220   = do  { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
 221
 222             -- Generate a table of static closures for an enumeration type
 223             -- Put the table after the data constructor decls, because the
 224             -- datatype closure table (for enumeration types)
 225             -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
 226             -- Note that the closure pointers are tagged.
 227
 228             -- N.B. comment says to put table after constructor decls, but
 229             -- code puts it before --- NR 16 Aug 2007
 230         ; extra <- cgEnumerationTyCon tycon
 231
 232         ; return (extra ++ constrs)
 233         }
 234
 235 cgEnumerationTyCon :: TyCon -> FCode [Cmm]
 236 cgEnumerationTyCon tycon
 237   | isEnumerationTyCon tycon
 238   = do  { tbl <- getCmm $
 239                  emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
 240                    [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
 241                                  (tagForCon con)
 242                    | con <- tyConDataCons tycon]
 243         ; return [tbl] }
 244   | otherwise
 245   = return []
 246
 247 cgDataCon :: DataCon -> FCode ()
 248 -- Generate the entry code, info tables, and (for niladic constructor)
 249 -- the static closure, for a constructor.
 250 cgDataCon data_con
 251   = do  { let
 252             -- To allow the debuggers, interpreters, etc to cope with
 253             -- static data structures (ie those built at compile
 254             -- time), we take care that info-table contains the
 255             -- information we need.
 256             (static_cl_info, _) = layOutStaticConstr data_con arg_reps
 257             (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
 258
 259             emit_info cl_info ticky_code
 260                 = emitClosureAndInfoTable cl_info NativeDirectCall []
 261                                         $ mk_code ticky_code
 262
 263             mk_code ticky_code
 264               =         -- NB: We don't set CC when entering data (WDP 94/06)
 265                 do { _ <- ticky_code
 266                    ; ldvEnter (CmmReg nodeReg)
 267                    ; tickyReturnOldCon (length arg_things)
 268                    ; emitReturn [cmmOffsetB (CmmReg nodeReg)
 269                                             (tagForCon data_con)] }
 270                         -- The case continuation code expects a tagged pointer
 271
 272             arg_reps :: [(PrimRep, Type)]
 273             arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con]
 274
 275             -- Dynamic closure code for non-nullary constructors only
 276         ; whenC (not (isNullaryRepDataCon data_con))
 277                 (emit_info dyn_cl_info tickyEnterDynCon)
 278
 279                 -- Dynamic-Closure first, to reduce forward references
 280         ; emit_info static_cl_info tickyEnterStaticCon }
 281
 282
 283 ---------------------------------------------------------------
 284 --      Stuff to support splitting
 285 ---------------------------------------------------------------
 286
 287 -- If we're splitting the object, we need to externalise all the
 288 -- top-level names (and then make sure we only use the externalised
 289 -- one in any C label we use which refers to this name).
 290
 291 maybeExternaliseId :: DynFlags -> Id -> FCode Id
 292 maybeExternaliseId dflags id
 293   | dopt Opt_SplitObjs dflags,  -- Externalise the name for -split-objs
 294     isInternalName name = do { mod <- getModuleName
 295                              ; returnFC (setIdName id (externalise mod)) }
 296   | otherwise           = returnFC id
 297   where
 298     externalise mod = mkExternalName uniq mod new_occ loc
 299     name    = idName id
 300     uniq    = nameUnique name
 301     new_occ = mkLocalOcc uniq (nameOccName name)
 302     loc     = nameSrcSpan name
 303         -- We want to conjure up a name that can't clash with any
 304         -- existing name.  So we generate
 305         --      Mod_$L243foo
 306         -- where 243 is the unique.