ghc/compiler/simplCore/SimplPgm.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SimplPgm]{Interface to the simplifier}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplPgm ( simplifyPgm ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12
  13 import CmdLineOpts      ( opt_D_verbose_core2core,
  14                           switchIsOn, intSwitchSet, SimplifierSwitch(..)
  15                         )
  16 import CoreSyn
  17 import CoreUtils        ( substCoreExpr )
  18 import Id               ( externallyVisibleId,
  19                           mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
  20                           GenId{-instance Ord3-}
  21                         )
  22 import Maybes           ( catMaybes )
  23 import OccurAnal        ( occurAnalyseBinds )
  24 import Pretty           ( ppAboves, ppBesides, ppInt, ppChar, ppStr )
  25 import SimplEnv
  26 import SimplMonad
  27 import Simplify         ( simplTopBinds )
  28 import TyVar            ( nullTyVarEnv, SYN_IE(TyVarEnv) )
  29 import UniqSupply       ( thenUs, returnUs, mapUs, splitUniqSupply, SYN_IE(UniqSM) )
  30 import Util             ( isIn, isn'tIn, removeDups, pprTrace )
  31 \end{code}
  32
  33 \begin{code}
  34 simplifyPgm :: [CoreBinding]    -- input
  35             -> (SimplifierSwitch->SwitchResult)
  36             -> SimplCount       -- info about how many times
  37                                 -- each transformation has occurred
  38             -> UniqSupply
  39             -> ([CoreBinding],  -- output
  40                  Int,           -- info about how much happened
  41                  SimplCount)    -- accumulated simpl stats
  42
  43 simplifyPgm binds s_sw_chkr simpl_stats us
  44   = case (splitUniqSupply us)                of { (s1, s2) ->
  45     case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
  46     case (tidy_top pgm2 s2)                  of { pgm3 ->
  47     (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
  48   where
  49     simpl_switch_is_on  = switchIsOn s_sw_chkr
  50
  51     occur_anal = occurAnalyseBinds
  52
  53     max_simpl_iterations
  54       = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
  55           Nothing  -> 1    -- default
  56           Just max -> max
  57
  58     simpl_pgm :: Int -> Int -> [CoreBinding] -> SmplM ([CoreBinding], Int, SimplCount)
  59
  60     simpl_pgm n iterations pgm
  61       = -- find out what top-level binders are used,
  62         -- and prepare to unfold all the "simple" bindings
  63         let
  64             tagged_pgm = occur_anal pgm simpl_switch_is_on
  65         in
  66               -- do the business
  67         simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm ->
  68
  69               -- Quit if we didn't actually do anything; otherwise,
  70               -- try again (if suitable flags)
  71
  72         simplCount                              `thenSmpl` \ r ->
  73         detailedSimplCount                      `thenSmpl` \ dr ->
  74         let
  75             show_status = pprTrace "NewSimpl: " (ppAboves [
  76                 ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations],
  77                 ppStr (showSimplCount dr)
  78 --DEBUG:        , ppAboves (map (pprCoreBinding PprDebug) new_pgm)
  79                 ])
  80         in
  81
  82         (if opt_D_verbose_core2core
  83          || simpl_switch_is_on  ShowSimplifierProgress
  84          then show_status
  85          else id)
  86
  87         (let stop_now = r == n {-nothing happened-}
  88                      || (if iterations > max_simpl_iterations then
  89                             (if max_simpl_iterations > 1 {-otherwise too boring-} then
  90                                 trace
  91                                 ("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.")
  92                              else id)
  93                             True
  94                          else
  95                             False)
  96         in
  97         if stop_now then
  98             returnSmpl (new_pgm, iterations, dr)
  99         else
 100             simpl_pgm r (iterations + 1) new_pgm
 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         mapUs blast binds_in    `thenUs` \ binds_maybe ->
 135         returnUs (catMaybes binds_maybe)
 136   where
 137     blast_alist  = undup (foldl find_cand [] binds_in)
 138     blast_id_env = mkIdEnv blast_alist
 139     blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
 140     blast_all_exps = map snd blast_alist
 141
 142     ---------
 143     find_cand blast_list (Rec _) = blast_list   -- recursively paranoid, as usual
 144
 145     find_cand blast_list (NonRec binder rhs)
 146       = if not (externallyVisibleId binder) then
 147            blast_list
 148         else
 149            case rhs_equiv_to_local_var rhs of
 150              Nothing    -> blast_list
 151              Just local -> (local, binder) : blast_list -- tag it on
 152
 153     ------------------------------------------
 154     -- if an Id appears >1 time in the domain,
 155     -- *all* occurrences must be expunged.
 156     undup :: [(Id, Id)] -> [(Id, Id)]
 157
 158     undup blast_list
 159       = let
 160             (singles, dups) = removeDups compare blast_list
 161             list_of_dups    = concat dups
 162         in
 163         [ s | s <- singles, s `not_elem` list_of_dups ]
 164       where
 165         compare (x,_) (y,_) = x `cmp` y
 166
 167     ------------------------------------------
 168     rhs_equiv_to_local_var (Var x)
 169       = if externallyVisibleId x then Nothing else Just x
 170
 171     rhs_equiv_to_local_var expr = Nothing
 172
 173     ------------------------------------------
 174     -- "blast" does the substitution:
 175     -- returns Nothing  if a binding goes away
 176     -- returns "Just b" to give back a fixed-up binding
 177
 178     blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
 179
 180     blast (Rec pairs)
 181       = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
 182         returnUs (Just (Rec blasted_pairs))
 183       where
 184         blast_pr (binder, rhs)
 185           = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
 186             returnUs (
 187             case (lookupIdEnv blast_id_env binder) of
 188               Just exportee -> (exportee, new_rhs)
 189               Nothing       -> (binder,   new_rhs)
 190             )
 191
 192     blast (NonRec binder rhs)
 193       = if binder `is_elem` blast_all_exps then
 194            returnUs Nothing -- this binding dies!
 195         else
 196            substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
 197            returnUs (Just (
 198            case (lookupIdEnv blast_id_env binder) of
 199              Just exportee -> NonRec exportee new_rhs
 200              Nothing       -> NonRec binder   new_rhs
 201            ))
 202       where
 203         is_elem = isIn "blast"
 204 \end{code}