ghc/compiler/simplCore/SimplPgm.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SimplPgm]{Interface to the ``new'' simplifier}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplPgm ( simplifyPgm ) where
  10
  11 import Type             ( getTyVarMaybe )
  12 import CmdLineOpts      ( switchIsOn, intSwitchSet,
  13                           GlobalSwitch(..), SimplifierSwitch(..)
  14                         )
  15 import Id               ( externallyVisibleId )
  16 import IdInfo
  17 import Maybes           ( catMaybes, Maybe(..) )
  18 import Outputable
  19 import SimplEnv
  20 import SimplMonad
  21 import Simplify         ( simplTopBinds )
  22 import OccurAnal        -- occurAnalyseBinds
  23 import UniqSupply
  24 import Util
  25 \end{code}
  26
  27 \begin{code}
  28 simplifyPgm :: [CoreBinding]            -- input
  29             -> (GlobalSwitch->SwitchResult)     -- switch lookup fns (global
  30             -> (SimplifierSwitch->SwitchResult) -- and this-simplification-specific)
  31             -> SimplCount                       -- info about how many times
  32                                                 -- each transformation has occurred
  33             -> UniqSupply
  34             -> ([CoreBinding],  -- output
  35                  Int,                   -- info about how much happened
  36                  SimplCount)            -- accumulated simpl stats
  37
  38 simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
  39   = case (splitUniqSupply us)                of { (s1, s2) ->
  40     case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
  41     case (tidy_top pgm2 s2)                  of { pgm3 ->
  42     (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
  43   where
  44     global_switch_is_on = switchIsOn g_sw_chkr
  45     simpl_switch_is_on  = switchIsOn s_sw_chkr
  46
  47     occur_anal = occurAnalyseBinds
  48
  49     max_simpl_iterations
  50       = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
  51           Nothing  -> 1    -- default
  52           Just max -> max
  53
  54     simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
  55
  56     simpl_pgm n iterations pgm
  57       = -- find out what top-level binders are used,
  58         -- and prepare to unfold all the "simple" bindings
  59         -- pprTrace ("\niteration "++show iterations++":\n") (ppr PprDebug pgm) (
  60         let
  61             tagged_pgm = BSCC("OccurBinds")
  62                          occur_anal pgm global_switch_is_on simpl_switch_is_on
  63                          ESCC
  64         in
  65               -- do the business
  66         simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm ->
  67
  68               -- Quit if we didn't actually do anything; otherwise,
  69               -- try again (if suitable flags)
  70
  71         simplCount                              `thenSmpl` \ r ->
  72         detailedSimplCount                      `thenSmpl` \ dr ->
  73         let
  74             show_status = pprTrace "NewSimpl: " (ppAboves [
  75                 ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations],
  76                 ppStr (showSimplCount dr)
  77 --DEBUG:        , ppAboves (map (pprPlainCoreBinding PprDebug) new_pgm)
  78                 ])
  79         in
  80
  81         (if global_switch_is_on D_verbose_core2core
  82          || simpl_switch_is_on  ShowSimplifierProgress
  83          then show_status
  84          else id)
  85
  86         (let stop_now = r == n {-nothing happened-}
  87                      || (if iterations > max_simpl_iterations then
  88                             (if max_simpl_iterations > 1 {-otherwise too boring-} then
  89                                 trace
  90                                 ("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.")
  91                              else id)
  92                             True
  93                          else
  94                             False)
  95         in
  96         if stop_now then
  97             returnSmpl (new_pgm, iterations, dr)
  98         else
  99             simpl_pgm r (iterations + 1) new_pgm
 100         )
 101         -- )
 102 \end{code}
 103
 104 In @tidy_top@, we look for things at the top-level of the form...
 105 \begin{verbatim}
 106 x_local = ....
 107
 108 x_exported = x_local    -- or perhaps...
 109
 110 x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible
 111 \end{verbatim}
 112 In cases we find like this, we go {\em backwards} and replace
 113 \tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
 114 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 115 information propagate better.
 116
 117 If more than one exported thing is equal to a local thing (i.e., the
 118 local thing really is shared), then obviously we give up.
 119
 120 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 121 Then blast the whole program (LHSs as well as RHSs) with it.
 122
 123 \begin{code}
 124 type BlastEnv = IdEnv Id  -- domain is local Ids; range is exported Ids
 125
 126 not_elem = isn'tIn "undup"
 127
 128 tidy_top :: [CoreBinding] -> UniqSM [CoreBinding]
 129
 130 tidy_top binds_in
 131   = if null blast_alist then
 132         returnUs binds_in    -- no joy there
 133     else
 134         -- pprTrace "undup output length:" (ppInt (length blast_alist)) (
 135         mapUs blast binds_in    `thenUs` \ binds_maybe ->
 136         returnUs (catMaybes binds_maybe)
 137         -- )
 138   where
 139     blast_alist  = undup (foldl find_cand [] binds_in)
 140     blast_id_env = mkIdEnv blast_alist
 141     blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
 142     blast_all_exps = map snd blast_alist
 143
 144     ---------
 145     find_cand blast_list (Rec _) = blast_list   -- recursively paranoid, as usual
 146
 147     find_cand blast_list (NonRec binder rhs)
 148       = if not (isExported binder) then
 149            blast_list
 150         else
 151            case rhs_equiv_to_local_var rhs of
 152              Nothing    -> blast_list
 153              Just local -> (local, binder) : blast_list -- tag it on
 154
 155     ------------------------------------------
 156     -- if an Id appears >1 time in the domain,
 157     -- *all* occurrences must be expunged.
 158     undup :: [(Id, Id)] -> [(Id, Id)]
 159
 160     undup blast_list
 161       = -- pprTrace "undup input length:" (ppInt (length blast_list)) (
 162         let
 163             (singles, dups) = removeDups compare blast_list
 164             list_of_dups    = concat dups
 165         in
 166         [ s | s <- singles, s `not_elem` list_of_dups ]
 167         -- )
 168       where
 169         compare (x,_) (y,_) = x `cmp` y
 170
 171     ------------------------------------------
 172     rhs_equiv_to_local_var (Var x)
 173       = if externallyVisibleId x then Nothing else Just x
 174
 175     rhs_equiv_to_local_var expr = Nothing
 176
 177     ------------------------------------------
 178     -- "blast" does the substitution:
 179     -- returns Nothing  if a binding goes away
 180     -- returns "Just b" to give back a fixed-up binding
 181
 182     blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
 183
 184     blast (Rec pairs)
 185       = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
 186         returnUs (Just (Rec blasted_pairs))
 187       where
 188         blast_pr (binder, rhs)
 189           = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
 190             returnUs (
 191             case lookupIdEnv blast_id_env binder of
 192               Just exportee -> (exportee, blasted_rhs)
 193               Nothing       -> (binder,   blasted_rhs)
 194             )
 195
 196     blast (NonRec binder rhs)
 197       = if binder `is_elem` blast_all_exps then
 198            returnUs Nothing -- this binding dies!
 199         else
 200            subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenUs` \ blasted_rhs ->
 201            returnUs (Just (
 202            case lookupIdEnv blast_id_env binder of
 203              Just exportee -> NonRec exportee blasted_rhs
 204              Nothing       -> NonRec binder   blasted_rhs
 205            ))
 206       where
 207         is_elem = isIn "blast"
 208
 209 subst_CoreExprUS e1 e2 rhs us = snd (substCoreExprUS e1 e2 rhs (mkUniqueSupplyGrimily us))
 210 \end{code}