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