[project @ 2001-10-24 13:46:58 by simonpj]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 906568b..ffeb43c 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -5,8 +5,8 @@
 
 \begin{code}
 module SimplUtils (
-       simplBinder, simplBinders, simplRecBndrs, simplLetBndr, 
-       simplLamBndrs, simplTopBndrs,
+       simplBinder, simplBinders, simplRecBndrs, 
+       simplLetBndr, simplLamBndrs, 
        newId, mkLam, mkCase,
 
        -- The continuation type
@@ -30,8 +30,8 @@ import CoreUtils      ( cheapEqExpr, exprType,
                          findDefault, exprOkForSpeculation, exprIsValue
                        )
 import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id              ( Id, idType, idInfo, isLocalId,
-                         mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
+import Id              ( Id, idType, idInfo, 
+                         mkSysLocal, isDeadBinder, idNewDemandInfo,
                          idUnfolding, idNewStrictness
                        )
 import NewDemand       ( isStrictDmd, isBotRes, splitStrictSig )
@@ -447,26 +447,11 @@ simplLetBndr env id
     seqBndr id'                `seq`
     returnSmpl (setSubst env subst', id')
 
-simplTopBndrs, simplLamBndrs, simplRecBndrs 
+simplLamBndrs, simplRecBndrs 
        :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplTopBndrs = simplBndrs simplTopBinder
 simplRecBndrs = simplBndrs Subst.simplLetId
 simplLamBndrs = simplBndrs Subst.simplLamBndr
 
--- For top-level binders, don't use simplLetId for GlobalIds. 
--- There are some of these, notably consructor wrappers, and we don't
--- want to clone them or fiddle with them at all.  
--- Rather tiresomely, the specialiser may float a use of a constructor
--- wrapper to before its definition (which shouldn't really matter)
--- because it doesn't see the constructor wrapper as free in the binding
--- it is floating (because it's a GlobalId).
--- Then the simplifier brings all top level Ids into scope at the
--- beginning, and we don't want to lose the IdInfo on the constructor
--- wrappers.  It would also be Bad to clone it!
-simplTopBinder subst bndr
-  | isLocalId bndr = Subst.simplLetId subst bndr
-  | otherwise     = (subst, bndr)
-
 simplBndrs simpl_bndr env bndrs
   = let
        (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
@@ -561,9 +546,7 @@ tryEtaReduce bndrs body
     go []       (Var fun)     | ok_fun fun   = Just (Var fun)  -- Success!
     go _        _                           = Nothing          -- Failure!
 
-    ok_fun fun   = not (fun `elem` bndrs) && not (hasNoBinding fun)
-                       -- Note the awkward "hasNoBinding" test
-                       -- Details with exprIsTrivial
+    ok_fun fun   = not (fun `elem` bndrs)
     ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
 \end{code}
 
@@ -791,10 +774,10 @@ tryRhsTyLam env tyvars body               -- Only does something if there's a let
 mkCase puts a case expression back together, trying various transformations first.
 
 \begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr
 
-mkCase scrut case_bndr alts
-  = mkAlts scrut case_bndr alts        `thenSmpl` \ better_alts ->
+mkCase scrut handled_cons case_bndr alts
+  = mkAlts scrut handled_cons case_bndr alts   `thenSmpl` \ better_alts ->
     mkCase1 scrut case_bndr better_alts
 \end{code}
 
@@ -869,7 +852,7 @@ and similarly in cascade for all the join points!
 --------------------------------------------------
 --     1. Merge identical branches
 --------------------------------------------------
-mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
   | all isDeadBinder bndrs1,                   -- Remember the default 
     length filtered_alts < length con_alts     -- alternative comes first
   = tick (AltMerge case_bndr)                  `thenSmpl_`
@@ -884,7 +867,7 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 --     2. Fill in missing constructor
 --------------------------------------------------
 
-mkAlts scrut case_bndr alts
+mkAlts scrut handled_cons case_bndr alts
   | (alts_no_deflt, Just rhs) <- findDefault alts,
                        -- There is a DEFAULT case
 
@@ -894,7 +877,8 @@ mkAlts scrut case_bndr alts
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
 
-    [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
+    [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon,
+                           not (con `elem` handled_data_cons)]
                        -- There is just one missing constructor!
 
   = tick (FillInCaseDefault case_bndr) `thenSmpl_`
@@ -910,18 +894,13 @@ mkAlts scrut case_bndr alts
     in
     returnSmpl better_alts
   where
-    impossible_cons   = case scrut of
-                           Var v -> otherCons (idUnfolding v)
-                           other -> []
-    handled_data_cons = [data_con | DataAlt data_con         <- impossible_cons] ++
-                       [data_con | (DataAlt data_con, _, _) <- alts]
-    is_missing con    = not (con `elem` handled_data_cons)
+    handled_data_cons = [data_con | DataAlt data_con <- handled_cons]
 
 --------------------------------------------------
 --     3.  Merge nested cases
 --------------------------------------------------
 
-mkAlts scrut outer_bndr outer_alts
+mkAlts scrut handled_cons outer_bndr outer_alts
   | opt_SimplCaseMerge,
     (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
     Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
@@ -965,7 +944,7 @@ mkAlts scrut outer_bndr outer_alts
 --     Catch-all
 --------------------------------------------------
 
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts
 \end{code}