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             (if global_switch_is_on D_verbose_core2core
 116              then show_status
 117              else id)
 118             (returnSmpl (new_pgm, iterations, dr))
 119         else
 120             simpl_pgm r (iterations + 1) new_pgm
 121         )
 122         -- )
 123 \end{code}
 124
 125 In @tidy_top@, we look for things at the top-level of the form...
 126 \begin{verbatim}
 127 x_local = ....
 128
 129 x_exported = x_local    -- or perhaps...
 130
 131 x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible
 132 \end{verbatim}
 133 In cases we find like this, we go {\em backwards} and replace
 134 \tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
 135 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 136 information propagate better.
 137
 138 If more than one exported thing is equal to a local thing (i.e., the
 139 local thing really is shared), then obviously we give up.
 140
 141 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 142 Then blast the whole program (LHSs as well as RHSs) with it.
 143
 144 \begin{code}
 145 type BlastEnv = IdEnv Id  -- domain is local Ids; range is exported Ids
 146
 147 not_elem = isn'tIn "undup"
 148
 149 tidy_top :: [PlainCoreBinding] -> SUniqSM [PlainCoreBinding]
 150
 151 tidy_top binds_in
 152   = if null blast_alist then
 153         returnSUs binds_in    -- no joy there
 154     else
 155         -- pprTrace "undup output length:" (ppInt (length blast_alist)) (
 156         mapSUs blast binds_in   `thenSUs` \ binds_maybe ->
 157         returnSUs (catMaybes binds_maybe)
 158         -- )
 159   where
 160     blast_alist  = undup (foldl find_cand [] binds_in)
 161     blast_id_env = mkIdEnv blast_alist
 162     blast_val_env= mkIdEnv [ (l, CoVar e) | (l,e) <- blast_alist ]
 163     blast_all_exps = map snd blast_alist
 164
 165     ---------
 166     find_cand blast_list (CoRec _) = blast_list -- recursively paranoid, as usual
 167
 168     find_cand blast_list (CoNonRec binder rhs)
 169       = if not (isExported binder) then
 170            blast_list
 171         else
 172            case rhs_equiv_to_local_var rhs of
 173              Nothing    -> blast_list
 174              Just local -> (local, binder) : blast_list -- tag it on
 175
 176     ------------------------------------------
 177     -- if an Id appears >1 time in the domain,
 178     -- *all* occurrences must be expunged.
 179     undup :: [(Id, Id)] -> [(Id, Id)]
 180
 181     undup blast_list
 182       = -- pprTrace "undup input length:" (ppInt (length blast_list)) (
 183         let
 184             (singles, dups) = removeDups cmp blast_list
 185             list_of_dups    = concat dups
 186         in
 187         [ s | s <- singles, s `not_elem` list_of_dups ]
 188         -- )
 189       where
 190         cmp (x,_) (y,_) = x `cmpId` y
 191
 192     ------------------------------------------
 193     rhs_equiv_to_local_var (CoVar x)
 194       = if externallyVisibleId x then Nothing else Just x
 195
 196     rhs_equiv_to_local_var expr = Nothing
 197 {- MAYBE NOT:
 198       = case (digForLambdas expr) of { (tyvars, binders, body) ->
 199         case (collectArgs   body) of { (fun, args) ->
 200         case fun of
 201           CoVar x -> if   null binders
 202                        && not (isExported x)
 203                        && tylams_match_tyargs tyvars args then
 204                        -- may need to chk for "tyvars" occurring in "x"'s type
 205                         Just x
 206                      else
 207                         Nothing
 208           _ -> Nothing
 209         }}
 210       where
 211         -- looking for a very restricted special case:
 212         -- /\ tv1 tv2 ... -> var tv1 tv2 ...
 213
 214         tylams_match_tyargs []       [] = True
 215         tylams_match_tyargs (tv:tvs) (TypeArg ty : args)
 216           = ASSERT(not (isPrimType ty))
 217             case (getTyVarMaybe ty) of
 218               Nothing    -> False
 219               Just tyvar -> tv == tyvar
 220         tylams_match_tyargs _ _ = False
 221 -}
 222
 223     ------------------------------------------
 224     -- "blast" does the substitution:
 225     -- returns Nothing  if a binding goes away
 226     -- returns "Just b" to give back a fixed-up binding
 227
 228     blast :: PlainCoreBinding -> SUniqSM (Maybe PlainCoreBinding)
 229
 230     blast (CoRec pairs)
 231       = mapSUs blast_pr pairs `thenSUs` \ blasted_pairs ->
 232         returnSUs (Just (CoRec blasted_pairs))
 233       where
 234         blast_pr (binder, rhs)
 235           = subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
 236             returnSUs (
 237             case lookupIdEnv blast_id_env binder of
 238               Just exportee -> (exportee, blasted_rhs)
 239               Nothing       -> (binder,   blasted_rhs)
 240             )
 241
 242     blast (CoNonRec binder rhs)
 243       = if binder `is_elem` blast_all_exps then
 244            returnSUs Nothing -- this binding dies!
 245         else
 246            subst_CoreExprUS blast_val_env nullTyVarEnv rhs `thenSUs` \ blasted_rhs ->
 247            returnSUs (Just (
 248            case lookupIdEnv blast_id_env binder of
 249              Just exportee -> CoNonRec exportee blasted_rhs
 250              Nothing       -> CoNonRec binder   blasted_rhs
 251            ))
 252       where
 253         is_elem = isIn "blast"
 254
 255 subst_CoreExprUS e1 e2 rhs us = snd (substCoreExprUS e1 e2 rhs (mkUniqueSupplyGrimily us))
 256 \end{code}