[project @ 1996-12-19 09:10:02 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplPgm.lhs

diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index a2d2797..edfe71a 100644 (file)
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -16,8 +16,7 @@ import CmdLineOpts    ( opt_D_verbose_core2core,
 import CoreSyn
 import CoreUnfold      ( SimpleUnfolding )
 import CoreUtils       ( substCoreExpr )
-import Id              ( externallyVisibleId,
-                         mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
+import Id              ( mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
                          GenId{-instance Ord3-}
                        )
 import Maybes          ( catMaybes )
@@ -44,8 +43,7 @@ simplifyPgm :: [CoreBinding]  -- input
 simplifyPgm binds s_sw_chkr simpl_stats us
   = case (splitUniqSupply us)               of { (s1, s2) ->
     case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
-    case (tidy_top pgm2 s2)                 of { pgm3 ->
-    (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
+    (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) }}
   where
     simpl_switch_is_on  = switchIsOn s_sw_chkr
 
@@ -99,104 +97,3 @@ simplifyPgm binds s_sw_chkr simpl_stats us
        )
 \end{code}
 
-In @tidy_top@, we look for things at the top-level of the form...
-\begin{verbatim}
-x_local = ....
-
-x_exported = x_local   -- or perhaps...
-
-x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{x_exported}.  This save a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then obviously we give up.
-
-Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
-
-\begin{code}
-type BlastEnv = IdEnv Id  -- domain is local Ids; range is exported Ids
-
-not_elem = isn'tIn "undup"
-
-tidy_top :: [CoreBinding] -> UniqSM [CoreBinding]
-
-tidy_top binds_in
-  = if null blast_alist then
-       returnUs binds_in    -- no joy there
-    else
-       mapUs blast binds_in    `thenUs` \ binds_maybe ->
-       returnUs (catMaybes binds_maybe)
-  where
-    blast_alist  = undup (foldl find_cand [] binds_in)
-    blast_id_env = mkIdEnv blast_alist
-    blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
-    blast_all_exps = map snd blast_alist
-
-    ---------
-    find_cand blast_list (Rec _) = blast_list  -- recursively paranoid, as usual
-
-    find_cand blast_list (NonRec binder rhs)
-      = if not (externallyVisibleId binder) then
-          blast_list
-       else
-          case rhs_equiv_to_local_var rhs of
-            Nothing    -> blast_list
-            Just local -> (local, binder) : blast_list -- tag it on
-
-    ------------------------------------------
-    -- if an Id appears >1 time in the domain,
-    -- *all* occurrences must be expunged.
-    undup :: [(Id, Id)] -> [(Id, Id)]
-
-    undup blast_list
-      = let
-           (singles, dups) = removeDups compare blast_list
-           list_of_dups    = concat dups
-       in
-       [ s | s <- singles, s `not_elem` list_of_dups ]
-      where
-       compare (x,_) (y,_) = x `cmp` y
-
-    ------------------------------------------
-    rhs_equiv_to_local_var (Var x)
-      = if externallyVisibleId x then Nothing else Just x
-
-    rhs_equiv_to_local_var expr = Nothing
-
-    ------------------------------------------
-    -- "blast" does the substitution:
-    -- returns Nothing  if a binding goes away
-    -- returns "Just b" to give back a fixed-up binding
-
-    blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
-
-    blast (Rec pairs)
-      = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
-       returnUs (Just (Rec blasted_pairs))
-      where
-       blast_pr (binder, rhs)
-         = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
-           returnUs (
-           case (lookupIdEnv blast_id_env binder) of
-             Just exportee -> (exportee, new_rhs)
-             Nothing       -> (binder,   new_rhs)
-           )
-
-    blast (NonRec binder rhs)
-      = if binder `is_elem` blast_all_exps then
-          returnUs Nothing -- this binding dies!
-       else
-          substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
-          returnUs (Just (
-          case (lookupIdEnv blast_id_env binder) of
-            Just exportee -> NonRec exportee new_rhs
-            Nothing       -> NonRec binder   new_rhs
-          ))
-      where
-       is_elem = isIn "blast"
-\end{code}