[project @ 2005-10-17 11:09:51 by simonpj]

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

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index a537e59..121e9b5 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -40,10 +40,10 @@ import DataCon              ( dataConTyCon, dataConRepStrictness, isVanillaDataCon )
 import TyCon           ( tyConArity )
 import CoreSyn
 import PprCore         ( pprParendExpr, pprCoreExpr )
-import CoreUnfold      ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline )
+import CoreUnfold      ( mkUnfolding, callSiteInline )
 import CoreUtils       ( exprIsDupable, exprIsTrivial, needsCaseBinding,
                          exprIsConApp_maybe, mkPiTypes, findAlt, 
-                         exprType, exprIsValue, 
+                         exprType, exprIsHNF, 
                          exprOkForSpeculation, exprArity, 
                          mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
                        )
@@ -60,7 +60,6 @@ import BasicTypes     ( TopLevelFlag(..), isTopLevel,
                          RecFlag(..), isNonRec
                        )
 import OrdList
-import Maybe           ( Maybe )
 import Maybes          ( orElse )
 import Outputable
 import Util             ( notNull )
@@ -524,24 +523,24 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
     if isEmptyFloats floats && isNilOL aux_binds then  -- Shortcut a common case
        completeLazyBind env1 top_lvl bndr bndr2 rhs2
 
-    else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then
+    else if is_top_level || exprIsTrivial rhs2 || exprIsHNF rhs2 then
        --      WARNING: long dodgy argument coming up
        --      WANTED: a better way to do this
        --              
-       -- We can't use "exprIsCheap" instead of exprIsValue, 
+       -- We can't use "exprIsCheap" instead of exprIsHNF, 
        -- because that causes a strictness bug.
        --         x = let y* = E in case (scc y) of { T -> F; F -> T}
        -- The case expression is 'cheap', but it's wrong to transform to
        --         y* = E; x = case (scc y) of {...}
        -- Either we must be careful not to float demanded non-values, or
-       -- we must use exprIsValue for the test, which ensures that the
-       -- thing is non-strict.  So exprIsValue => bindings are non-strict
+       -- we must use exprIsHNF for the test, which ensures that the
+       -- thing is non-strict.  So exprIsHNF => bindings are non-strict
        -- I think.  The WARN below tests for this.
        --
        -- We use exprIsTrivial here because we want to reveal lone variables.  
        -- E.g.  let { x = letrec { y = E } in y } in ...
        -- Here we definitely want to float the y=E defn. 
-       -- exprIsValue definitely isn't right for that.
+       -- exprIsHNF definitely isn't right for that.
        --
        -- Again, the floated binding can't be strict; if it's recursive it'll
        -- be non-strict; if it's non-recursive it'd be inlined.
@@ -615,7 +614,7 @@ completeLazyBind :: SimplEnv
 --     (as usual) use the in-scope-env from the floats
 
 completeLazyBind env top_lvl old_bndr new_bndr new_rhs
-  | postInlineUnconditionally env new_bndr occ_info new_rhs
+  | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
   =            -- Drop the binding
     tick (PostInlineUnconditionally old_bndr)  `thenSmpl_`
     returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
@@ -844,6 +843,11 @@ mkLamBndrZapper fun n_args
 \begin{code}
 simplNote env (Coerce to from) body cont
   = let
+       addCoerce s1 k1 cont    -- Drop redundant coerces.  This can happen if a polymoprhic
+                               -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the
+                               -- two are the same. This happens a lot in Happy-generated parsers
+         | s1 `coreEqType` k1 = cont
+
        addCoerce s1 k1 (CoerceIt t1 cont)
                --      coerce T1 S1 (coerce S1 K1 e)
                -- ==>
@@ -854,9 +858,9 @@ simplNote env (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 `coreEqType` k1  = cont          -- The coerces cancel out
-         | otherwise       = CoerceIt t1 cont  -- They don't cancel, but 
-                                               -- the inner one is redundant
+         | t1 `coreEqType` 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)
          | not (isTypeArg arg),        -- This whole case only works for value args
@@ -1321,9 +1325,10 @@ rebuildCase env scrut case_bndr alts cont
   = knownCon env (LitAlt lit) [] case_bndr alts cont
 
   | otherwise
-  = prepareAlts scrut case_bndr alts           `thenSmpl` \ (better_alts, handled_cons) -> 
+  =    -- Prepare the alternatives.
+    prepareAlts scrut case_bndr alts           `thenSmpl` \ (better_alts, handled_cons) -> 
        
-       -- Deal with the case binder, and prepare the continuation;
+       -- Prepare the continuation;
        -- The new subst_env is in place
     prepareCaseCont env better_alts cont       `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
     addFloats env floats                       $ \ env ->      
@@ -1340,7 +1345,7 @@ rebuildCase env scrut case_bndr alts cont
        res_ty' = contResultType dup_cont
     in
 
-       -- Deal with variable scrutinee
+       -- Deal with case binder
     simplCaseBinder env scrut case_bndr        `thenSmpl` \ (alt_env, case_bndr') ->
 
        -- Deal with the case alternatives