[project @ 2001-07-19 15:32:05 by apt]

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

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index e3dcba7..638efec 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -53,7 +53,7 @@ import Rules          ( lookupRule )
 import CostCentre      ( currentCCS )
 import Type            ( mkTyVarTys, isUnLiftedType, seqType,
                          mkFunTy, splitTyConApp_maybe, tyConAppArgs,
-                         funResultTy, splitFunTy_maybe, splitFunTy
+                         funResultTy, splitFunTy_maybe, splitFunTy, eqType
                        )
 import Subst           ( mkSubst, substTy, substEnv, substExpr,
                          isInScope, lookupIdSubst, simplIdInfo
@@ -63,7 +63,6 @@ import TysPrim                ( realWorldStatePrimTy )
 import PrelInfo                ( realWorldPrimId )
 import OrdList
 import Maybes          ( maybeToBool )
-import Util            ( zipWithEqual )
 import Outputable
 \end{code}
 
@@ -360,8 +359,8 @@ simplNote (Coerce to from) body cont
                -- we may find  (coerce T (coerce S (\x.e))) y
                -- and we'd like it to simplify to e[y/x] in one round 
                -- of simplification
-         | t1 == k1  = cont                    -- The coerces cancel out
-         | otherwise = CoerceIt t1 cont        -- They don't cancel, but 
+         | t1 `eqType` k1  = cont              -- The coerces cancel out
+         | otherwise       = CoerceIt t1 cont  -- They don't cancel, but 
                                                -- the inner one is redundant
 
        addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
@@ -430,7 +429,8 @@ simplNote InlineCall e cont
 simplNote InlineMe e cont
   | keep_inline cont           -- Totally boring continuation
   =                            -- Don't inline inside an INLINE expression
-    setBlackList noInlineBlackList (simplExpr e)       `thenSmpl` \ e' ->
+    noInlineBlackList                  `thenSmpl` \ bl ->
+    setBlackList bl (simplExpr e)      `thenSmpl` \ e' ->
     rebuild (mkInlineMe e') cont
 
   | otherwise          -- Dissolve the InlineMe note if there's
@@ -948,7 +948,8 @@ simplifyArgs is_data_con args cont_ty thing_inside
                -- Even though x get's an occurrence of 'many', its RHS looks cheap,
                -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
   = getBlackList                               `thenSmpl` \ old_bl ->
-    setBlackList noInlineBlackList             $
+    noInlineBlackList                          `thenSmpl` \ ni_bl ->
+    setBlackList ni_bl                         $
     go args                                    $ \ args' ->
     setBlackList old_bl                                $
     thing_inside args'
@@ -1390,9 +1391,9 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts
                   let
                        (_,_,ex_tyvars,_,_,_) = dataConSig data_con
                   in
-                  getUniquesSmpl (length ex_tyvars)                            `thenSmpl` \ tv_uniqs ->
+                  getUniquesSmpl                       `thenSmpl` \ tv_uniqs ->
                   let
-                       ex_tyvars' = zipWithEqual "simpl_alt" mk tv_uniqs ex_tyvars
+                       ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
                        mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
                        arg_tys    = dataConArgTys data_con
                                                   (inst_tys ++ mkTyVarTys ex_tyvars')
@@ -1425,7 +1426,8 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
 
        -- handled_cons is all the constructors that are dealt
        -- with, either by being impossible, or by there being an alternative
-    handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
+    (con_alts,_) = findDefault alts
+    handled_cons = scrut_cons ++ [con | (con,_,_) <- con_alts]
 
     simpl_alt (DEFAULT, _, rhs)
        =       -- In the default case we record the constructors that the
@@ -1626,13 +1628,20 @@ mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs) thing_inside
        -- Consider:    let j = if .. then I# 3 else I# 4
        --              in case .. of { A -> j; B -> j; C -> ... }
        --
-       -- Now CPR should not w/w j because it's a thunk, so
+       -- Now CPR doesn't w/w j because it's a thunk, so
        -- that means that the enclosing function can't w/w either,
        -- which is a lose.  Here's the example that happened in practice:
        --      kgmod :: Int -> Int -> Int
        --      kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
        --                  then 78
        --                  else 5
+       --
+       -- I have seen a case alternative like this:
+       --      True -> \v -> ...
+       -- It's a bit silly to add the realWorld dummy arg in this case, making
+       --      $j = \s v -> ...
+       --         True -> $j s
+       -- (the \v alone is enough to make CPR happy) but I think it's rare
 
        then newId SLIT("w") realWorldStatePrimTy  $ \ rw_id ->
             returnSmpl ([rw_id], [Var realWorldPrimId])