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 -- XXX This define is a bit of a hack, and should be done more nicely
  29 #define FAST_STRING_NOT_NEEDED 1
  30 #include "HsVersions.h"
  31
  32 import StgSyn
  33
  34 import StaticFlags      ( opt_AutoSccsOnIndividualCafs )
  35 import CostCentre       -- lots of things
  36 import Id
  37 import Name
  38 import Module
  39 import UniqSupply       ( splitUniqSupply, UniqSupply )
  40 #ifdef PROF_DO_BOXING
  41 import UniqSupply       ( uniqFromSupply )
  42 #endif
  43 import VarSet
  44 import ListSetOps       ( removeDups )
  45 import Outputable
  46 \end{code}
  47
  48 \begin{code}
  49 stgMassageForProfiling
  50         :: PackageId
  51         -> Module                       -- module name
  52         -> UniqSupply                   -- unique supply
  53         -> [StgBinding]                 -- input
  54         -> (CollectedCCs, [StgBinding])
  55
  56 stgMassageForProfiling this_pkg mod_name us stg_binds
  57   = let
  58         ((local_ccs, extern_ccs, cc_stacks),
  59          stg_binds2)
  60           = initMM mod_name us (do_top_bindings stg_binds)
  61
  62         (fixed_ccs, fixed_cc_stacks)
  63           = if opt_AutoSccsOnIndividualCafs
  64             then ([],[])  -- don't need "all CAFs" CC
  65                           -- (for Prelude, we use PreludeCC)
  66             else ([all_cafs_cc], [all_cafs_ccs])
  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,
  72       extern_ccs_no_dups,
  73       fixed_cc_stacks ++ cc_stacks), stg_binds2)
  74   where
  75
  76     all_cafs_cc  = mkAllCafsCC mod_name
  77     all_cafs_ccs = mkSingletonCCS all_cafs_cc
  78
  79     ----------
  80     do_top_bindings :: [StgBinding] -> MassageM [StgBinding]
  81
  82     do_top_bindings [] = return []
  83
  84     do_top_bindings (StgNonRec b rhs : bs) = do
  85         rhs' <- do_top_rhs b rhs
  86         addTopLevelIshId b $ do
  87            bs' <- do_top_bindings bs
  88            return (StgNonRec b rhs' : bs')
  89
  90     do_top_bindings (StgRec pairs : bs)
  91       = addTopLevelIshIds binders $ do
  92            pairs2 <- mapM do_pair pairs
  93            bs' <- do_top_bindings bs
  94            return (StgRec pairs2 : bs')
  95       where
  96         binders = map fst pairs
  97         do_pair (b, rhs) = do
  98              rhs2 <- do_top_rhs b rhs
  99              return (b, rhs2)
 100
 101     ----------
 102     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 103
 104     do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC cc (StgConApp con args)))
 105       | not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args)
 106         -- Trivial _scc_ around nothing but static data
 107         -- Eliminate _scc_ ... and turn into StgRhsCon
 108
 109         -- isDllConApp checks for LitLit args too
 110       = return (StgRhsCon dontCareCCS con args)
 111
 112 {- Can't do this one with cost-centre stacks:  --SDM
 113     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
 114       | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
 115         && not (isSccCountCostCentre cc)
 116         -- Top level CAF without a cost centre attached
 117         -- Attach and collect cc of trivial _scc_ in body
 118       = do collectCC cc
 119            expr' <- set_prevailing_cc cc (do_expr expr)
 120            return (StgRhsClosure cc bi fv u [] expr')
 121 -}
 122
 123     do_top_rhs binder (StgRhsClosure no_cc bi fv u srt [] body)
 124       | noCCSAttached no_cc || currentOrSubsumedCCS no_cc = do
 125         -- Top level CAF without a cost centre attached
 126         -- Attach CAF cc (collect if individual CAF ccs)
 127         caf_ccs <- if opt_AutoSccsOnIndividualCafs
 128                    then let cc = mkAutoCC binder modl CafCC
 129                             ccs = mkSingletonCCS cc
 130                                    -- careful: the binder might be :Main.main,
 131                                    -- which doesn't belong to module mod_name.
 132                                    -- bug #249, tests prof001, prof002
 133                             modl | Just m <- nameModule_maybe (idName binder) = m
 134                                  | otherwise = mod_name
 135                         in do
 136                         collectNewCC  cc
 137                         collectCCS ccs
 138                         return ccs
 139                    else
 140                         return all_cafs_ccs
 141         body' <- set_prevailing_cc caf_ccs (do_expr body)
 142         return (StgRhsClosure caf_ccs bi fv u srt [] body')
 143
 144     do_top_rhs _ (StgRhsClosure cc _ _ _ _ [] _)
 145         -- Top level CAF with cost centre attached
 146         -- Should this be a CAF cc ??? Does this ever occur ???
 147       = pprPanic "SCCfinal: CAF with cc:" (ppr cc)
 148
 149     do_top_rhs _ (StgRhsClosure no_ccs bi fv u srt args body)
 150         -- Top level function, probably subsumed
 151       | noCCSAttached no_ccs
 152       = do body' <- set_lambda_cc (do_expr body)
 153            return (StgRhsClosure subsumedCCS bi fv u srt args body')
 154
 155       | otherwise
 156       = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
 157
 158     do_top_rhs _ (StgRhsCon _ con args)
 159         -- Top-level (static) data is not counted in heap
 160         -- profiles; nor do we set CCCS from it; so we
 161         -- just slam in dontCareCostCentre
 162       = return (StgRhsCon dontCareCCS con args)
 163
 164     ------
 165     do_expr :: StgExpr -> MassageM StgExpr
 166
 167     do_expr (StgLit l) = return (StgLit l)
 168
 169     do_expr (StgApp fn args)
 170       = boxHigherOrderArgs (StgApp fn) args
 171
 172     do_expr (StgConApp con args)
 173       = boxHigherOrderArgs (\args -> StgConApp con args) args
 174
 175     do_expr (StgOpApp con args res_ty)
 176       = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args
 177
 178     do_expr (StgSCC cc expr) = do -- Ha, we found a cost centre!
 179         collectCC cc
 180         expr' <- do_expr expr
 181         return (StgSCC cc expr')
 182
 183     do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
 184         expr' <- do_expr expr
 185         alts' <- mapM do_alt alts
 186         return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
 187       where
 188         do_alt (id, bs, use_mask, e) = do
 189             e' <- do_expr e
 190             return (id, bs, use_mask, e')
 191
 192     do_expr (StgLet b e) = do
 193           (b,e) <- do_let b e
 194           return (StgLet b e)
 195
 196     do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
 197           (b,e) <- do_let b e
 198           return (StgLetNoEscape lvs1 lvs2 b e)
 199
 200     do_expr (StgTick m n expr) = do
 201           expr' <- do_expr expr
 202           return (StgTick m n expr')
 203
 204     do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
 205
 206     ----------------------------------
 207
 208     do_let (StgNonRec b rhs) e = do
 209         rhs' <- do_rhs rhs
 210         addTopLevelIshId b $ do
 211           e' <- do_expr e
 212           return (StgNonRec b rhs',e')
 213
 214     do_let (StgRec pairs) e
 215       = addTopLevelIshIds binders $ do
 216            pairs' <- mapM do_pair pairs
 217            e' <- do_expr e
 218            return (StgRec pairs', e')
 219       where
 220         binders = map fst pairs
 221         do_pair (b, rhs) = do
 222              rhs2 <- do_rhs rhs
 223              return (b, rhs2)
 224
 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 fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
 232       | not (isSccCountCostCentre cc)
 233       = do collectCC cc
 234            return (StgRhsCon cc con args)
 235 -}
 236
 237     do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
 238         (expr', ccs) <- slurpSCCs currentCCS expr
 239         expr'' <- do_expr expr'
 240         return (StgRhsClosure ccs bi fv u srt args expr'')
 241       where
 242         slurpSCCs ccs (StgSCC cc e)
 243              = do collectCC cc
 244                   slurpSCCs (cc `pushCCOnCCS` ccs) e
 245         slurpSCCs ccs e
 246              = return (e, ccs)
 247
 248     do_rhs (StgRhsCon _ con args)
 249       = return (StgRhsCon currentCCS con args)
 250 \end{code}
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 \subsection{Boxing higher-order args}
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 Boxing is *turned off* at the moment, until we can figure out how to
 259 do it properly in general.
 260
 261 \begin{code}
 262 boxHigherOrderArgs
 263     :: ([StgArg] -> StgExpr)
 264                         -- An application lacking its arguments
 265     -> [StgArg]         -- arguments which we might box
 266     -> MassageM StgExpr
 267
 268 #ifndef PROF_DO_BOXING
 269 boxHigherOrderArgs almost_expr args
 270    = return (almost_expr args)
 271 #else
 272 boxHigherOrderArgs almost_expr args = do
 273     ids <- getTopLevelIshIds
 274     (let_bindings, new_args) <- mapAccumLM (do_arg ids) [] args
 275     return (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings)
 276   where
 277     ---------------
 278
 279     do_arg ids bindings arg@(StgVarArg old_var)
 280         |  (not (isLocalVar old_var) || elemVarSet old_var ids)
 281         && isFunTy (dropForAlls var_type)
 282       = do    -- make a trivial let-binding for the top-level function
 283         uniq <- getUniqueMM
 284         let
 285             new_var = mkSysLocal FSLIT("sf") uniq var_type
 286         return ( (new_var, old_var) : bindings, StgVarArg new_var )
 287       where
 288         var_type = idType old_var
 289
 290     do_arg ids bindings arg = return (bindings, arg)
 291
 292     ---------------
 293     mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr
 294
 295     mk_stg_let cc (new_var, old_var) body
 296       = let
 297             rhs_body    = StgApp old_var [{-args-}]
 298             rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body
 299         in
 300         StgLet (StgNonRec new_var rhs_closure) body
 301       where
 302         bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
 303 #endif
 304 \end{code}
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection{Boring monad stuff for this}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 \begin{code}
 313 newtype MassageM result
 314   = MassageM {
 315       unMassageM :: Module              -- module name
 316                  -> CostCentreStack     -- prevailing CostCentre
 317                                         -- if none, subsumedCosts at top-level
 318                                         -- currentCostCentre at nested levels
 319                  -> UniqSupply
 320                  -> VarSet              -- toplevel-ish Ids for boxing
 321                  -> CollectedCCs
 322                  -> (CollectedCCs, result)
 323     }
 324
 325 instance Monad MassageM where
 326     return x = MassageM (\_ _ _ _ ccs -> (ccs, x))
 327     (>>=) = thenMM
 328     (>>)  = thenMM_
 329
 330 -- the initMM function also returns the final CollectedCCs
 331
 332 initMM :: Module        -- module name, which we may consult
 333        -> UniqSupply
 334        -> MassageM a
 335        -> (CollectedCCs, a)
 336
 337 initMM mod_name init_us (MassageM m) = m mod_name noCCS init_us emptyVarSet ([],[],[])
 338
 339 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
 340 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
 341
 342 thenMM expr cont = MassageM $ \mod scope_cc us ids ccs ->
 343     case splitUniqSupply us of { (s1, s2) ->
 344     case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, result) ->
 345     unMassageM (cont result) mod scope_cc s2 ids ccs2 }}
 346
 347 thenMM_ expr cont = MassageM $ \mod scope_cc us ids ccs ->
 348     case splitUniqSupply us of { (s1, s2) ->
 349     case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, _) ->
 350     unMassageM cont mod scope_cc s2 ids ccs2 }}
 351
 352 #ifdef PROF_DO_BOXING
 353 getUniqueMM :: MassageM Unique
 354 getUniqueMM = MassageM \mod scope_cc us ids ccs -> (ccs, uniqFromSupply us)
 355 #endif
 356
 357 addTopLevelIshId :: Id -> MassageM a -> MassageM a
 358 addTopLevelIshId id scope
 359    = MassageM $ \mod scope_cc us ids ccs ->
 360       if isCurrentCCS scope_cc then unMassageM scope mod scope_cc us ids ccs
 361                                else unMassageM scope mod scope_cc us (extendVarSet ids id) ccs
 362
 363 addTopLevelIshIds :: [Id] -> MassageM a -> MassageM a
 364 addTopLevelIshIds [] cont = cont
 365 addTopLevelIshIds (id:ids) cont
 366   = addTopLevelIshId id (addTopLevelIshIds ids cont)
 367
 368 #ifdef PROF_DO_BOXING
 369 getTopLevelIshIds :: MassageM VarSet
 370 getTopLevelIshIds = MassageM $ \_mod _scope_cc _us ids ccs -> (ccs, ids)
 371 #endif
 372 \end{code}
 373
 374 The prevailing CCS is used to tell whether we're in a top-levelish
 375 position, where top-levelish is defined as "not inside a lambda".
 376 Prevailing CCs used to be used for something much more complicated,
 377 I'm sure --SDM
 378
 379 \begin{code}
 380 set_lambda_cc :: MassageM a -> MassageM a
 381 set_lambda_cc action
 382    =    MassageM $     \mod _scope_cc  us ids ccs
 383    -> unMassageM action mod currentCCS us ids ccs
 384
 385 set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a
 386 set_prevailing_cc cc_to_set_to action
 387    =    MassageM $     \mod _scope_cc    us ids ccs
 388    -> unMassageM action mod cc_to_set_to us ids ccs
 389 \end{code}
 390
 391 \begin{code}
 392 collectCC :: CostCentre -> MassageM ()
 393 collectCC cc
 394  = MassageM $ \mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
 395   -> ASSERT(not (noCCAttached cc))
 396      if (cc `ccFromThisModule` mod_name) then
 397         ((cc : local_ccs, extern_ccs, ccss), ())
 398      else -- must declare it "extern"
 399         ((local_ccs, cc : extern_ccs, ccss), ())
 400
 401 -- Version of collectCC used when we definitely want to declare this
 402 -- CC as local, even if its module name is not the same as the current
 403 -- module name (eg. the special :Main module) see bug #249, #1472,
 404 -- test prof001,prof002.
 405 collectNewCC :: CostCentre -> MassageM ()
 406 collectNewCC cc
 407  = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
 408               -> ((cc : local_ccs, extern_ccs, ccss), ())
 409
 410 collectCCS :: CostCentreStack -> MassageM ()
 411
 412 collectCCS ccs
 413  = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
 414               -> ASSERT(not (noCCSAttached ccs))
 415                        ((local_ccs, extern_ccs, ccs : ccss), ())
 416 \end{code}