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