ghc/compiler/profiling/SCCauto.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[SCCauto]{Automated SCC annotations}
   5
   6 Automatic insertion of \tr{_scc_} annotations for top-level bindings.
   7
   8 Automatic insertion of \tr{_scc_} annotations on CAFs is better left
   9 until STG land.  We do DICT annotations there, too, but maybe
  10 that will turn out to be a bummer...  (WDP 94/06)
  11
  12 This is a Core-to-Core pass (usually run {\em last}).
  13
  14 \begin{code}
  15 #include "HsVersions.h"
  16
  17 module SCCauto ( addAutoCostCentres ) where
  18
  19 import CmdLineOpts
  20 import Id               ( isTopLevId )
  21 import PlainCore
  22 import Outputable       ( isExported )
  23 import CostCentre       -- ( mkAutoCC )
  24 import Util             -- for pragmas only
  25 \end{code}
  26
  27 \begin{code}
  28 addAutoCostCentres
  29         :: (GlobalSwitch -> SwitchResult)       -- cmd-line switches
  30         -> FAST_STRING                          -- module name
  31         -> [PlainCoreBinding]                   -- input
  32         -> [PlainCoreBinding]                   -- output
  33
  34 addAutoCostCentres sw_chkr mod_name binds
  35   = if not doing_something then
  36         binds -- now *that* was quick...
  37     else
  38         map scc_top_bind binds
  39   where
  40     doing_something = auto_all_switch_on || auto_exported_switch_on
  41
  42     auto_all_switch_on      = switchIsOn sw_chkr AutoSccsOnAllToplevs -- only use!
  43     auto_exported_switch_on = switchIsOn sw_chkr AutoSccsOnExportedToplevs -- only use!
  44
  45     grp_name  = case (stringSwitchSet sw_chkr SccGroup) of
  46                   Just xx -> _PK_ xx
  47                   Nothing -> mod_name   -- default: module name
  48
  49     -----------------------------
  50     scc_top_bind (CoNonRec binder rhs)
  51       = CoNonRec binder (scc_auto binder rhs)
  52
  53     scc_top_bind (CoRec pairs)
  54       = CoRec (map scc_pair pairs)
  55       where
  56         scc_pair (binder, rhs) = (binder, scc_auto binder rhs)
  57
  58     -----------------------------
  59     -- Automatic scc annotation for user-defined top-level Ids
  60
  61     scc_auto binder rhs
  62       = if isTopLevId binder
  63         && (auto_all_switch_on || isExported binder)
  64         then scc_rhs rhs
  65         else rhs
  66       where
  67         -- park auto SCC inside lambdas; don't put one there
  68         -- if there already is one.
  69
  70         scc_rhs rhs
  71           = let
  72                 (tyvars, vars, body) = digForLambdas rhs
  73             in
  74             case body of
  75               CoSCC _ _ -> rhs -- leave it
  76               CoCon _ _ _ --??? | null vars
  77                 -> rhs
  78               _ -> mkFunction tyvars vars
  79                         (CoSCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body)
  80 \end{code}