ghc/compiler/profiling/SCCauto.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 that
  10 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 IMP_Ubiq(){-uitous-}
  20
  21 import CmdLineOpts      ( opt_AutoSccsOnAllToplevs,
  22                           opt_AutoSccsOnExportedToplevs,
  23                           opt_SccGroup
  24                         )
  25 import CoreSyn
  26 import CostCentre       ( mkAutoCC, IsCafCC(..) )
  27 import Id               ( isTopLevId, GenId{-instances-} )
  28 import Name             ( isExported )
  29 \end{code}
  30
  31 \begin{code}
  32 addAutoCostCentres
  33         :: FAST_STRING                          -- module name
  34         -> [CoreBinding]                        -- input
  35         -> [CoreBinding]                        -- output
  36
  37 addAutoCostCentres mod_name binds
  38   = if not doing_something then
  39         binds -- now *that* was quick...
  40     else
  41         map scc_top_bind binds
  42   where
  43     doing_something = auto_all_switch_on || auto_exported_switch_on
  44
  45     auto_all_switch_on      = opt_AutoSccsOnAllToplevs -- only use!
  46     auto_exported_switch_on = opt_AutoSccsOnExportedToplevs -- only use!
  47
  48     grp_name
  49       = case opt_SccGroup of
  50           Just xx -> _PK_ xx
  51           Nothing -> mod_name   -- default: module name
  52
  53     -----------------------------
  54     scc_top_bind (NonRec binder rhs)
  55       = NonRec binder (scc_auto binder rhs)
  56
  57     scc_top_bind (Rec pairs)
  58       = Rec (map scc_pair pairs)
  59       where
  60         scc_pair (binder, rhs) = (binder, scc_auto binder rhs)
  61
  62     -----------------------------
  63     -- Automatic scc annotation for user-defined top-level Ids
  64
  65     scc_auto binder rhs
  66       = if isTopLevId binder
  67         && (auto_all_switch_on || isExported binder)
  68         then scc_rhs rhs
  69         else rhs
  70       where
  71         -- park auto SCC inside lambdas; don't put one there
  72         -- if there already is one.
  73
  74         scc_rhs rhs
  75           = let
  76                 (usevars, tyvars, vars, body) = collectBinders rhs
  77             in
  78             case body of
  79               SCC _ _ -> rhs -- leave it
  80               Con _ _ -> rhs
  81               _ -> mkUseLam usevars (mkLam tyvars vars
  82                         (SCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body))
  83 \end{code}