ghc/compiler/profiling/SCCfinal.lhs

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