Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-constraint-solverghc-constraint-solver

3 files changed, 35 insertions, 55 deletions

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 12d180642e..1081ce0752 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -191,8 +191,12 @@ getCoreToDo dflags
 
     core_todo =
      if opt_level == 0 then
-       [vectorisation,
-        simpl_phase 0 ["final"] max_iter]
+       [ vectorisation
+       , CoreDoSimplify max_iter
+             (base_mode { sm_phase = Phase 0
+                        , sm_names = ["Non-opt simplification"] }) 
+       ]
+
      else {- opt_level >= 1 -} [
 
     -- We want to do the static argument transform before full laziness as it
@@ -296,7 +300,6 @@ getCoreToDo dflags
      ]
 \end{code}
 
-
 Loading plugins
 
 \begin{code}
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index c326cbc74d..86dc88ddd1 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -43,7 +43,7 @@ import StaticFlags
 import CoreSyn
 import qualified CoreSubst
 import PprCore
-import DataCon	( dataConCannotMatch )
+import DataCon	( dataConCannotMatch, dataConWorkId )
 import CoreFVs
 import CoreUtils
 import CoreArity
@@ -1139,8 +1139,7 @@ tryEtaExpand env bndr rhs
       = return (exprArity rhs, rhs)
 
       | sm_eta_expand (getMode env)      -- Provided eta-expansion is on
-      , let dicts_cheap = dopt Opt_DictsCheap dflags
-            new_arity   = findArity dicts_cheap bndr rhs old_arity
+      , let new_arity = findArity dflags bndr rhs old_arity
       , new_arity > manifest_arity  	-- And the curent manifest arity isn't enough
       		    			-- See Note [Eta expansion to manifes arity]
       = do { tick (EtaExpansion bndr)
@@ -1152,16 +1151,21 @@ tryEtaExpand env bndr rhs
     old_arity  = idArity bndr
     _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
 
-findArity :: Bool -> Id -> CoreExpr -> Arity -> Arity
+findArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity
 -- This implements the fixpoint loop for arity analysis
 -- See Note [Arity analysis]
-findArity dicts_cheap bndr rhs old_arity
-  = go (exprEtaExpandArity (mk_cheap_fn dicts_cheap init_cheap_app) rhs)
+findArity dflags bndr rhs old_arity
+  = go (exprEtaExpandArity dflags init_cheap_app rhs)
        -- We always call exprEtaExpandArity once, but usually 
        -- that produces a result equal to old_arity, and then
        -- we stop right away (since arities should not decrease)
        -- Result: the common case is that there is just one iteration
   where
+    init_cheap_app :: CheapAppFun
+    init_cheap_app fn n_val_args
+      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
+      | otherwise  = isCheapApp fn n_val_args
+
     go :: Arity -> Arity
     go cur_arity
       | cur_arity <= old_arity = cur_arity	
@@ -1172,46 +1176,12 @@ findArity dicts_cheap bndr rhs old_arity
                              , ppr rhs])
                     go new_arity
       where
-        new_arity = exprEtaExpandArity (mk_cheap_fn dicts_cheap cheap_app) rhs
-      
+        new_arity = exprEtaExpandArity dflags cheap_app rhs
+
         cheap_app :: CheapAppFun
         cheap_app fn n_val_args
           | fn == bndr = n_val_args < cur_arity
           | otherwise  = isCheapApp fn n_val_args
-
-    init_cheap_app :: CheapAppFun
-    init_cheap_app fn n_val_args
-      | fn == bndr = True   -- On the first pass, this binder gets infinite arity
-      | otherwise  = isCheapApp fn n_val_args
- 
-mk_cheap_fn :: Bool -> CheapAppFun -> CheapFun
-mk_cheap_fn dicts_cheap cheap_app
-  | not dicts_cheap
-  = \e _     -> exprIsCheap' cheap_app e
-  | otherwise
-  = \e mb_ty -> exprIsCheap' cheap_app e
-             || case mb_ty of
-                  Nothing -> False
-                  Just ty -> isDictLikeTy ty
-	-- If the experimental -fdicts-cheap flag is on, we eta-expand through
-	-- dictionary bindings.  This improves arities. Thereby, it also
-	-- means that full laziness is less prone to floating out the
-	-- application of a function to its dictionary arguments, which
-	-- can thereby lose opportunities for fusion.  Example:
-	-- 	foo :: Ord a => a -> ...
-	--	foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
-	--		-- So foo has arity 1
-	--
-	--	f = \x. foo dInt $ bar x
-	--
-	-- The (foo DInt) is floated out, and makes ineffective a RULE 
-	--	foo (bar x) = ...
-	--
-	-- One could go further and make exprIsCheap reply True to any
-	-- dictionary-typed expression, but that's more work.
-	-- 
-	-- See Note [Dictionary-like types] in TcType.lhs for why we use
-  	-- isDictLikeTy here rather than isDictTy
 \end{code}
 
 Note [Eta-expanding at let bindings]
@@ -1747,14 +1717,15 @@ mkCase1 _dflags scrut case_bndr alts	-- Identity case
   = do { tick (CaseIdentity case_bndr)
        ; return (re_cast scrut rhs1) }
   where
-    identity_alt (con, args, rhs) = check_eq con args rhs
-
-    check_eq con           args (Cast e co) | not (any (`elemVarSet` tyCoVarsOfCo co) args)
-        {- See Note [RHS casts] -}          = check_eq con args e
-    check_eq _             _    (Var v)     = v == case_bndr
-    check_eq (LitAlt lit') _    (Lit lit)   = lit == lit'
-    check_eq (DataAlt con) args rhs         = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
-    check_eq _             _    _           = False
+    identity_alt (con, args, rhs) = check_eq rhs con args
+
+    check_eq (Cast rhs co) con args         = not (any (`elemVarSet` tyCoVarsOfCo co) args)
+        {- See Note [RHS casts] -}            && check_eq rhs con args
+    check_eq (Lit lit) (LitAlt lit') _      = lit == lit'
+    check_eq (Var v)   _ _ | v == case_bndr = True
+    check_eq (Var v)   (DataAlt con) []     = v == dataConWorkId con   -- Optimisation only
+    check_eq rhs       (DataAlt con) args   = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args)
+    check_eq _ _ _ = False
 
     arg_tys = map Type (tyConAppArgs (idType case_bndr))
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 60b6889d5c..a8f7761e61 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -21,6 +21,7 @@ import Type hiding      ( substTy, extendTvSubst, substTyVar )
 import SimplEnv
 import SimplUtils
 import FamInstEnv	( FamInstEnv )
+import Literal		( litIsLifted )
 import Id
 import MkId		( seqId, realWorldPrimId )
 import MkCore		( mkImpossibleExpr )
@@ -1629,7 +1630,7 @@ to just
 This particular example shows up in default methods for
 comparision operations (e.g. in (>=) for Int.Int32)
 
-Note [CaseElimination: lifted case]
+Note [Case elimination: lifted case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We also make sure that we deal with this very common case,
 where x has a lifted type:
@@ -1716,6 +1717,7 @@ rebuildCase, reallyRebuildCase
 rebuildCase env scrut case_bndr alts cont
   | Lit lit <- scrut    -- No need for same treatment as constructors
                         -- because literals are inlined more vigorously
+  , not (litIsLifted lit)
   = do  { tick (KnownBranch case_bndr)
         ; case findAlt (LitAlt lit) alts of
 	    Nothing           -> missingAlt env case_bndr alts cont
@@ -1751,7 +1753,11 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
  , if isUnLiftedType (idType case_bndr)
    then ok_for_spec         -- Satisfy the let-binding invariant
    else elim_lifted
-  = do  { tick (CaseElim case_bndr)
+  = do  { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut),
+          --                            ppr strict_case_bndr, ppr (scrut_is_var scrut),
+          --                            ppr ok_for_spec,
+          --                            ppr scrut]) $
+          tick (CaseElim case_bndr)
         ; env' <- simplNonRecX env case_bndr scrut
           -- If case_bndr is deads, simplNonRecX will discard
         ; simplExprF env' rhs cont }