ghc/compiler/profiling/SCCfinal.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[SCCfinal]{Modify and collect code generation for final STG program}
   5
   6 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
   7
   8 * Traverses the STG program collecting the cost centres. These are
   9   required to declare the cost centres at the start of code
  10   generation.
  11
  12   Note: because of cross-module unfolding, some of these cost centres
  13   may be from other modules.  But will still have to give them
  14   "extern" declarations.
  15
  16 * Puts on CAF cost-centres if the user has asked for individual CAF
  17   cost-centres.
  18
  19 * Ditto for individual DICT cost-centres.
  20
  21 * Boxes top-level inherited functions passed as arguments.
  22
  23 * "Distributes" given cost-centres to all as-yet-unmarked RHSs.
  24
  25 \begin{code}
  26 #include "HsVersions.h"
  27
  28 module SCCfinal ( stgMassageForProfiling ) where
  29
  30 IMP_Ubiq(){-uitous-}
  31
  32 import StgSyn
  33
  34 import CmdLineOpts      ( opt_AutoSccsOnIndividualCafs,
  35                           opt_CompilingGhcInternals
  36                         )
  37 import CostCentre       -- lots of things
  38 import Id               ( idType, mkSysLocal, emptyIdSet )
  39 import Maybes           ( maybeToBool )
  40 import PprStyle         -- ToDo: rm
  41 import SrcLoc           ( noSrcLoc )
  42 import Type             ( splitSigmaTy, getFunTy_maybe )
  43 import UniqSupply       ( getUnique, splitUniqSupply )
  44 import Util             ( removeDups, assertPanic )
  45
  46 infixr 9 `thenMM`, `thenMM_`
  47 \end{code}
  48
  49 \begin{code}
  50 type CollectedCCs = ([CostCentre],      -- locally defined ones
  51                      [CostCentre])      -- ones needing "extern" decls
  52
  53 stgMassageForProfiling
  54         :: FAST_STRING -> FAST_STRING   -- module name, group name
  55         -> UniqSupply                   -- unique supply
  56         -> [StgBinding]                 -- input
  57         -> (CollectedCCs, [StgBinding])
  58
  59 stgMassageForProfiling mod_name grp_name us stg_binds
  60   = let
  61         ((local_ccs, extern_ccs),
  62          stg_binds2)
  63           = initMM mod_name us (mapMM do_top_binding stg_binds)
  64
  65         fixed_ccs
  66           = if do_auto_sccs_on_cafs || doing_prelude
  67             then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
  68             else [all_cafs_cc]
  69
  70         local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
  71         extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
  72     in
  73     ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
  74   where
  75     do_auto_sccs_on_cafs  = opt_AutoSccsOnIndividualCafs  -- only use!
  76     doing_prelude         = opt_CompilingGhcInternals
  77
  78     all_cafs_cc = if doing_prelude
  79                   then preludeCafsCostCentre
  80                   else mkAllCafsCC mod_name grp_name
  81
  82     ----------
  83     do_top_binding :: StgBinding -> MassageM StgBinding
  84
  85     do_top_binding (StgNonRec b rhs)
  86       = do_top_rhs b rhs                `thenMM` \ rhs' ->
  87         returnMM (StgNonRec b rhs')
  88
  89     do_top_binding (StgRec pairs)
  90       = mapMM do_pair pairs             `thenMM` \ pairs2 ->
  91         returnMM (StgRec pairs2)
  92       where
  93         do_pair (b, rhs)
  94            = do_top_rhs b rhs   `thenMM` \ rhs2 ->
  95              returnMM (b, rhs2)
  96
  97     ----------
  98     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
  99
 100     do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
 101       | not (isSccCountCostCentre cc)
 102         -- Trivial _scc_ around nothing but static data
 103         -- Eliminate _scc_ ... and turn into StgRhsCon
 104       = returnMM (StgRhsCon dontCareCostCentre con args)
 105
 106     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
 107       | (noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc)
 108         && not (isSccCountCostCentre cc)
 109         -- Top level CAF without a cost centre attached
 110         -- Attach and collect cc of trivial _scc_ in body
 111       = collectCC cc                                    `thenMM_`
 112         set_prevailing_cc cc (do_expr expr)             `thenMM`  \ expr' ->
 113         returnMM (StgRhsClosure cc bi fv u [] expr')
 114
 115     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body)
 116       | noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc
 117         -- Top level CAF without a cost centre attached
 118         -- Attach CAF cc (collect if individual CAF ccs)
 119       = let
 120             (collect, caf_cc)
 121               = if do_auto_sccs_on_cafs then
 122                    (True, mkAutoCC binder mod_name grp_name IsCafCC)
 123                 else
 124                    (False, all_cafs_cc)
 125         in
 126         (if collect then collectCC caf_cc else nopMM)   `thenMM_`
 127         set_prevailing_cc caf_cc (do_expr body)         `thenMM`  \ body' ->
 128         returnMM (StgRhsClosure caf_cc bi fv u [] body')
 129
 130     do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
 131         -- Top level CAF with cost centre attached
 132         -- Should this be a CAF cc ??? Does this ever occur ???
 133       = trace ("SCCfinal: CAF with cc: " ++ showCostCentre PprDebug False cc) $
 134         collectCC cc                                    `thenMM_`
 135         set_prevailing_cc cc (do_expr body)             `thenMM` \ body' ->
 136         returnMM (StgRhsClosure cc bi fv u [] body')
 137
 138     do_top_rhs binder (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
 139       | not (isSccCountCostCentre cc)
 140         -- Top level function with trivial _scc_ in body
 141         -- Attach and collect cc of trivial _scc_
 142       = collectCC cc                                    `thenMM_`
 143         set_prevailing_cc cc (do_expr expr)             `thenMM` \ expr' ->
 144         returnMM (StgRhsClosure cc bi fv u args expr')
 145
 146     do_top_rhs binder (StgRhsClosure cc bi fv u args body)
 147         -- Top level function, probably subsumed
 148       = let
 149             (cc_closure, cc_body)
 150               = if noCostCentreAttached cc
 151                 then (subsumedCosts, useCurrentCostCentre)
 152                 else (cc, cc)
 153         in
 154         set_prevailing_cc cc_body (do_expr body)        `thenMM` \ body' ->
 155         returnMM (StgRhsClosure cc_closure bi fv u args body')
 156
 157     do_top_rhs binder (StgRhsCon cc con args)
 158         -- Top-level (static) data is not counted in heap
 159         -- profiles; nor do we set CCC from it; so we
 160         -- just slam in dontCareCostCentre
 161       = returnMM (StgRhsCon dontCareCostCentre con args)
 162
 163     ------
 164     do_expr :: StgExpr -> MassageM StgExpr
 165
 166     do_expr (StgApp fn args lvs)
 167       = boxHigherOrderArgs (StgApp fn) args lvs
 168
 169     do_expr (StgCon con args lvs)
 170       = boxHigherOrderArgs (StgCon con) args lvs
 171
 172     do_expr (StgPrim op args lvs)
 173       = boxHigherOrderArgs (StgPrim op) args lvs
 174
 175     do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
 176       = collectCC cc                            `thenMM_`
 177         set_prevailing_cc cc (do_expr expr)     `thenMM`  \ expr' ->
 178         returnMM (StgSCC ty cc expr')
 179
 180     do_expr (StgCase expr fv1 fv2 uniq alts)
 181       = do_expr expr            `thenMM` \ expr' ->
 182         do_alts alts            `thenMM` \ alts' ->
 183         returnMM (StgCase expr' fv1 fv2 uniq alts')
 184       where
 185         do_alts (StgAlgAlts ty alts def)
 186           = mapMM do_alt alts   `thenMM` \ alts' ->
 187             do_deflt def        `thenMM` \ def' ->
 188             returnMM (StgAlgAlts ty alts' def')
 189           where
 190             do_alt (id, bs, use_mask, e)
 191               = do_expr e `thenMM` \ e' ->
 192                 returnMM (id, bs, use_mask, e')
 193
 194         do_alts (StgPrimAlts ty alts def)
 195           = mapMM do_alt alts   `thenMM` \ alts' ->
 196             do_deflt def        `thenMM` \ def' ->
 197             returnMM (StgPrimAlts ty alts' def')
 198           where
 199             do_alt (l,e)
 200               = do_expr e `thenMM` \ e' ->
 201                 returnMM (l,e')
 202
 203         do_deflt StgNoDefault = returnMM StgNoDefault
 204         do_deflt (StgBindDefault b is_used e)
 205           = do_expr e                   `thenMM` \ e' ->
 206             returnMM (StgBindDefault b is_used e')
 207
 208     do_expr (StgLet b e)
 209       = do_binding b                    `thenMM` \ b' ->
 210         do_expr e                       `thenMM` \ e' ->
 211         returnMM (StgLet b' e')
 212
 213     do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
 214       = do_binding rhs                  `thenMM` \ rhs' ->
 215         do_expr body                    `thenMM` \ body' ->
 216         returnMM (StgLetNoEscape lvs1 lvs2 rhs' body')
 217
 218     ----------
 219     do_binding :: StgBinding -> MassageM StgBinding
 220
 221     do_binding (StgNonRec b rhs)
 222       = do_rhs rhs                      `thenMM` \ rhs' ->
 223         returnMM (StgNonRec b rhs')
 224
 225     do_binding (StgRec pairs)
 226       = mapMM do_pair pairs `thenMM` \ new_pairs ->
 227         returnMM (StgRec new_pairs)
 228       where
 229         do_pair (b, rhs)
 230           = do_rhs rhs  `thenMM` \ rhs' ->
 231             returnMM (b, rhs')
 232
 233     do_rhs :: StgRhs -> MassageM StgRhs
 234         -- We play much the same game as we did in do_top_rhs above;
 235         -- but we don't have to worry about cafs etc.
 236
 237     do_rhs (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
 238       | not (isSccCountCostCentre cc)
 239       = collectCC cc `thenMM_`
 240         returnMM (StgRhsCon cc con args)
 241
 242     do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
 243       | not (isSccCountCostCentre cc)
 244       = collectCC cc                            `thenMM_`
 245         set_prevailing_cc cc (do_expr expr)     `thenMM` \ expr' ->
 246         returnMM (StgRhsClosure cc bi fv u args expr')
 247
 248     do_rhs (StgRhsClosure cc bi fv u args body)
 249       = set_prevailing_cc_maybe cc              $ \ cc' ->
 250         set_lambda_cc (do_expr body)            `thenMM` \ body' ->
 251         returnMM (StgRhsClosure cc' bi fv u args body')
 252
 253     do_rhs (StgRhsCon cc con args)
 254       = set_prevailing_cc_maybe cc              $ \ cc' ->
 255         returnMM (StgRhsCon cc' con args)
 256
 257         -- ToDo: Box args and sort out any let bindings ???
 258         -- Nope: maybe later? WDP 94/06
 259 \end{code}
 260
 261 %************************************************************************
 262 %*                                                                      *
 263 \subsection{Boxing higher-order args}
 264 %*                                                                      *
 265 %************************************************************************
 266
 267 \begin{code}
 268 boxHigherOrderArgs
 269     :: ([StgArg] -> StgLiveVars -> StgExpr)
 270                         -- An application lacking its arguments and live-var info
 271     -> [StgArg]         -- arguments which we might box
 272     -> StgLiveVars      -- live var info, which we do *not* try
 273                         -- to maintain/update (setStgVarInfo will
 274                         -- do that)
 275     -> MassageM StgExpr
 276
 277 boxHigherOrderArgs almost_expr args live_vars
 278   = returnMM (almost_expr args live_vars)
 279
 280 {- No boxing for now ... should be moved to desugarer and preserved ...
 281
 282 boxHigherOrderArgs almost_expr args live_vars
 283   = get_prevailing_cc                   `thenMM` \ cc ->
 284     if (isCafCC cc || isDictCC cc) then
 285         -- no boxing required inside CAF/DICT cc
 286         -- since CAF/DICT functions are subsumed anyway
 287         returnMM (almost_expr args live_vars)
 288     else
 289         mapAccumMM do_arg [] args       `thenMM` \ (let_bindings, new_args) ->
 290         returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
 291   where
 292     ---------------
 293     do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
 294
 295     do_arg bindings atom@(StgVarAtom old_var)
 296       = let
 297             var_type = getIdUniType old_var
 298         in
 299         if toplevelishId old_var && isFunType (getTauType var_type)
 300         then
 301             -- make a trivial let-binding for the top-level function
 302             getUniqueMM         `thenMM` \ uniq ->
 303             let
 304                 new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc
 305             in
 306             returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
 307         else
 308             returnMM (bindings, atom)
 309
 310     ---------------
 311     mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
 312
 313     mk_stg_let cc (new_var, old_var) body
 314       = let
 315             rhs_body    = StgApp (StgVarAtom old_var) [{-args-}] bOGUS_LVs
 316             rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body
 317         in
 318         StgLet (StgNonRec new_var rhs_closure) body
 319       where
 320         bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
 321 -}
 322 \end{code}
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection{Boring monad stuff for this}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 \begin{code}
 331 type MassageM result
 332   =  FAST_STRING        -- module name
 333   -> CostCentre         -- prevailing CostCentre
 334                         -- if none, subsumedCosts at top-level
 335                         -- useCurrentCostCentre at nested levels
 336   -> UniqSupply
 337   -> CollectedCCs
 338   -> (CollectedCCs, result)
 339
 340 -- the initUs function also returns the final UniqueSupply and CollectedCCs
 341
 342 initMM :: FAST_STRING   -- module name, which we may consult
 343        -> UniqSupply
 344        -> MassageM a
 345        -> (CollectedCCs, a)
 346
 347 initMM mod_name init_us m = m mod_name noCostCentre init_us ([],[])
 348
 349 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
 350 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
 351
 352 thenMM expr cont mod scope_cc us ccs
 353   = case splitUniqSupply us     of { (s1, s2) ->
 354     case (expr mod scope_cc s1 ccs)     of { (ccs2, result) ->
 355     cont result mod scope_cc s2 ccs2 }}
 356
 357 thenMM_ expr cont mod scope_cc us ccs
 358   = case splitUniqSupply us     of { (s1, s2) ->
 359     case (expr mod scope_cc s1 ccs)     of { (ccs2, _) ->
 360     cont mod scope_cc s2 ccs2 }}
 361
 362 returnMM :: a -> MassageM a
 363 returnMM result mod scope_cc us ccs = (ccs, result)
 364
 365 nopMM :: MassageM ()
 366 nopMM mod scope_cc us ccs = (ccs, ())
 367
 368 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
 369
 370 mapMM f [] = returnMM []
 371 mapMM f (m:ms)
 372   = f m         `thenMM` \ r  ->
 373     mapMM f ms  `thenMM` \ rs ->
 374     returnMM (r:rs)
 375
 376 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
 377
 378 mapAccumMM f b [] = returnMM (b, [])
 379 mapAccumMM f b (m:ms)
 380   = f b m               `thenMM` \ (b2, r)  ->
 381     mapAccumMM f b2 ms  `thenMM` \ (b3, rs) ->
 382     returnMM (b3, r:rs)
 383
 384 getUniqueMM :: MassageM Unique
 385 getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
 386 \end{code}
 387
 388 \begin{code}
 389 set_prevailing_cc :: CostCentre -> MassageM a -> MassageM a
 390 set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
 391         -- set unconditionally
 392   = action mod cc_to_set_to us ccs
 393
 394 set_prevailing_cc_maybe :: CostCentre -> (CostCentre -> MassageM a) -> MassageM a
 395 set_prevailing_cc_maybe cc_to_try action mod scope_cc us ccs
 396         -- set only if a real cost centre
 397   = let
 398         cc_to_use
 399           = if noCostCentreAttached cc_to_try || currentOrSubsumedCosts cc_to_try
 400             then scope_cc    -- carry on as before
 401             else cc_to_try   -- use new cost centre
 402     in
 403     action cc_to_use mod cc_to_use us ccs
 404
 405 set_lambda_cc :: MassageM a -> MassageM a
 406 set_lambda_cc action mod scope_cc us ccs
 407         -- used when moving inside a lambda;
 408         -- if we were chugging along as "caf/dict" we change to "ccc"
 409   = let
 410         cc_to_use
 411           = if isCafCC scope_cc || isDictCC scope_cc
 412             then useCurrentCostCentre
 413             else scope_cc
 414     in
 415     action mod cc_to_use us ccs
 416
 417
 418 get_prevailing_cc :: MassageM CostCentre
 419 get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
 420
 421 \end{code}
 422
 423 \begin{code}
 424 collectCC :: CostCentre -> MassageM ()
 425
 426 collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
 427   = ASSERT(not (noCostCentreAttached cc))
 428     ASSERT(not (currentOrSubsumedCosts cc))
 429     if (cc `ccFromThisModule` mod_name) then
 430         ((cc : local_ccs, extern_ccs), ())
 431     else -- must declare it "extern"
 432         ((local_ccs, cc : extern_ccs), ())
 433 \end{code}