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 PlainCore
  12 import TaggedCore
  13
  14 import Pretty           -- ToDo: rm debugging
  15 IMPORT_Trace
  16
  17 import AbsUniType       ( getTyVarMaybe )
  18 import CmdLineOpts      ( switchIsOn, intSwitchSet,
  19                           GlobalSwitch(..), SimplifierSwitch(..)
  20                         )
  21 import Id               ( cmpId, externallyVisibleId )
  22 import IdEnv
  23 import IdInfo
  24 import Maybes           ( catMaybes, Maybe(..) )
  25 import Outputable
  26 import SimplEnv
  27 import SimplMonad
  28 import Simplify         ( simplTopBinds )
  29 import OccurAnal        -- occurAnalyseBinds
  30 #if ! OMIT_FOLDR_BUILD
  31 import NewOccurAnal     -- newOccurAnalyseBinds
  32 #endif
  33 import TyVarEnv         -- ( nullTyVarEnv )
  34 import SplitUniq
  35 import Unique
  36 import Util
  37 \end{code}
  38
  39 \begin{code}
  40 simplifyPgm :: [PlainCoreBinding]               -- input
  41             -> (GlobalSwitch->SwitchResult)     -- switch lookup fns (global
  42             -> (SimplifierSwitch->SwitchResult) -- and this-simplification-specific)
  43             -> SimplCount                       -- info about how many times
  44                                                 -- each transformation has occurred
  45             -> SplitUniqSupply
  46             -> ([PlainCoreBinding],     -- output
  47                  Int,                   -- info about how much happened
  48                  SimplCount)            -- accumulated simpl stats
  49
  50 simplifyPgm binds g_sw_chkr s_sw_chkr simpl_stats us
  51   = case (splitUniqSupply us)                of { (s1, s2) ->
  52     case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
  53     case (tidy_top pgm2 s2)                  of { pgm3 ->
  54     (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
  55   where
  56     global_switch_is_on = switchIsOn g_sw_chkr
  57     simpl_switch_is_on  = switchIsOn s_sw_chkr
  58
  59 #if OMIT_FOLDR_BUILD
  60     occur_anal = occurAnalyseBinds
  61 #else
  62     occur_anal = if simpl_switch_is_on SimplDoNewOccurAnal
  63                  then newOccurAnalyseBinds
  64                  else occurAnalyseBinds
  65 #endif
  66
  67     max_simpl_iterations
  68       = case (intSwitchSet s_sw_chkr MaxSimplifierIterations) of
  69           Nothing  -> 1    -- default
  70           Just max -> max
  71
  72     simpl_pgm :: Int -> Int -> [PlainCoreBinding] -> SmplM ([PlainCoreBinding], Int, SimplCount)
  73
  74     simpl_pgm n iterations pgm
  75       = -- find out what top-level binders are used,
  76         -- and prepare to unfold all the "simple" bindings
  77         -- pprTrace ("\niteration "++show iterations++":\n") (ppr PprDebug pgm) (
  78         let
  79             tagged_pgm = BSCC("OccurBinds")
  80                          occur_anal pgm global_switch_is_on simpl_switch_is_on
  81                          ESCC
  82         in
  83               -- do the business
  84         simplTopBinds (nullSimplEnv s_sw_chkr) tagged_pgm `thenSmpl` \ new_pgm ->
  85
  86               -- Quit if we didn't actually do anything; otherwise,
  87               -- try again (if suitable flags)
  88
  89         simplCount                              `thenSmpl` \ r ->
  90         detailedSimplCount                      `thenSmpl` \ dr ->
  91         let
  92             show_status = pprTrace "NewSimpl: " (ppAboves [
  93                 ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations],
  94                 ppStr (showSimplCount dr)
  95 --DEBUG:        , ppAboves (map (pprPlainCoreBinding PprDebug) new_pgm)
  96                 ])
  97         in
  98
  99         (if global_switch_is_on D_verbose_core2core
 100          || simpl_switch_is_on  ShowSimplifierProgress
 101          then show_status
 102          else id)
 103
 104         (let stop_now = r == n {-nothing happened-}
 105                      || (if iterations > max_simpl_iterations then
 106                             (if max_simpl_iterations > 1 {-otherwise too boring-} then
 107                                 trace
 108                                 ("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.")
 109                              else id)
 110                             True
 111                          else
 112                             False)
 113         in
 114         if stop_now then
 115             returnSmpl (new_pgm, iterations, dr)
 116         else
 117             simpl_pgm r (iterations + 1) new_pgm
 118         )
 119         -- )
 120 \end{code}
 121
 122 In @tidy_top@, we look for things at the top-level of the form...
 123 \begin{verbatim}
 124 x_local = ....
 125
 126 x_exported = x_local    -- or perhaps...
 127
 128 x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible
 129 \end{verbatim}
 130 In cases we find like this, we go {\em backwards} and replace
 131 \tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
 132 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 133 information propagate better.
 134
 135 If more than one exported thing is equal to a local thing (i.e., the
 136 local thing really is shared), then obviously we give up.
 137
 138 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 139 Then blast the whole program (LHSs as well as RHSs) with it.
 140
 141 \begin{code}
 142 type BlastEnv = IdEnv Id  -- domain is local Ids; range is exported Ids
 143
 144 not_elem = isn'tIn "undup"
 145
 146 tidy_top :: [PlainCoreBinding] -> SUniqSM [PlainCoreBinding]
 147
 148 tidy_top binds_in
 149   = if null blast_alist then
 150         returnSUs binds_in    -- no joy there
 151     else
 152         -- pprTrace "undup output length:" (ppInt (length blast_alist)) (
 153         mapSUs blast binds_in   `thenSUs` \ binds_maybe ->
 154         returnSUs (catMaybes binds_maybe)
 155         -- )
 156   where
 157     blast_alist  = undup (foldl find_cand [] binds_in)
 158     blast_id_env = mkIdEnv blast_alist
 159     blast_val_env= mkIdEnv [ (l, CoVar e) | (l,e) <- blast_alist ]
 160     blast_all_exps = map snd blast_alist
 161
 162     ---------
 163     find_cand blast_list (CoRec _) = blast_list -- recursively paranoid, as usual
 164
 165     find_cand blast_list (CoNonRec binder rhs)
 166       = if not (isExported binder) then
 167            blast_list
 168         else
 169            case rhs_equiv_to_local_var rhs of
 170              Nothing    -> blast_list
 171              Just local -> (local, binder) : blast_list -- tag it on
 172
 173     ------------------------------------------
 174     -- if an Id appears >1 time in the domain,
 175     -- *all* occurrences must be expunged.
 176     undup :: [(Id, Id)] -> [(Id, Id)]
 177
 178     undup blast_list
 179       = -- pprTrace "undup input length:" (ppInt (length blast_list)) (
 180         let
 181             (singles, dups) = removeDups cmp blast_list
 182             list_of_dups    = concat dups
 183         in
 184         [ s | s <- singles, s `not_elem` list_of_dups ]
 185         -- )
 186       where
 187         cmp (x,_) (y,_) = x `cmpId` y
 188
 189     ------------------------------------------
 190     rhs_equiv_to_local_var (CoVar x)
 191       = if externallyVisibleId x then Nothing else Just x
 192
 193     rhs_equiv_to_local_var expr = Nothing
 194 {- MAYBE NOT:
 195       = case (digForLambdas expr) of { (tyvars, binders, body) ->
 196         case (collectArgs   body) of { (fun, args) ->
 197         case fun of
 198           CoVar x -> if   null binders
 199                        && not (isExported x)
 200                        && tylams_match_tyargs tyvars args then
 201                        -- may need to chk for "tyvars" occurring in "x"'s type
 202                         Just x
 203                      else
 204                         Nothing
 205           _ -> Nothing
 206         }}
 207       where
 208         -- looking for a very restricted special case:
 209         -- /\ tv1 tv2 ... -> var tv1 tv2 ...
 210
 211         tylams_match_tyargs []       [] = True
 212         tylams_match_tyargs (tv:tvs) (TypeArg ty : args)
 213           = ASSERT(not (isPrimType ty))
 214             case (getTyVarMaybe ty) of
 215               Nothing    -> False
 216               Just tyvar -> tv == tyvar
 217         tylams_match_tyargs _ _ = False
 218 -}
 219
 220     ------------------------------------------
 221     -- "blast" does the substitution:
 222     -- returns Nothing  if a binding goes away
 223     -- returns "Just b" to give back a fixed-up binding
 224
 225     blast :: PlainCoreBinding -> SUniqSM (Maybe PlainCoreBinding)
 226
 227     blast (CoRec pairs)
 228       = mapSUs blast_pr pairs `thenSUs` \ blasted_pairs ->
 229         returnSUs (Just (CoRec blasted_pairs))
 230       where
 231         blast_pr (binder, rhs)
 232           = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
 233             returnSUs (
 234             case lookupIdEnv blast_id_env binder of
 235               Just exportee -> (exportee, blasted_rhs)
 236               Nothing       -> (binder,   blasted_rhs)
 237             )
 238
 239     blast (CoNonRec binder rhs)
 240       = if binder `is_elem` blast_all_exps then
 241            returnSUs Nothing -- this binding dies!
 242         else
 243            subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
 244            returnSUs (Just (
 245            case lookupIdEnv blast_id_env binder of
 246              Just exportee -> CoNonRec exportee blasted_rhs
 247              Nothing       -> CoNonRec binder   blasted_rhs
 248            ))
 249       where
 250         is_elem = isIn "blast"
 251
 252 subst_CoreExprUS e1 e2 rhs us = snd (substCoreExprUS e1 e2 rhs (mkUniqueSupplyGrimily us))
 253 \end{code}