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