X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=379fce155509bb9633067c023e9f82b7dafe7a0e;hb=a06cc26192b0df5726e7ae201e94379c734423fc;hp=fd8981a87274dd4ae6227344772d16c71fcf5446;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index fd8981a..379fce1 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -15,7 +15,8 @@ import SimplEnv
 import SimplUtils
 import FamInstEnv	( FamInstEnv )
 import Id
-import MkId		( mkImpossibleExpr, seqId )
+import MkId		( seqId, realWorldPrimId )
+import MkCore		( mkImpossibleExpr )
 import Var
 import IdInfo
 import Name		( mkSystemVarName, isExternalName )
@@ -27,8 +28,9 @@ import CoreMonad	( SimplifierSwitch(..), Tick(..) )
 import CoreSyn
 import Demand           ( isStrictDmd, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
-import CoreUnfold       ( mkUnfolding, mkCoreUnfolding, mkInlineRule, 
-                          exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
+import CoreUnfold       ( mkUnfolding, mkCoreUnfolding
+                        , mkInlineUnfolding, mkSimpleUnfolding
+                        , exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
 import CoreUtils
 import qualified CoreSubst
 import CoreArity	( exprArity )
@@ -36,7 +38,6 @@ import Rules            ( lookupRule, getRules )
 import BasicTypes       ( isMarkedStrict, Arity )
 import CostCentre       ( currentCCS, pushCCisNop )
 import TysPrim          ( realWorldStatePrimTy )
-import PrelInfo         ( realWorldPrimId )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
 import MonadUtils	( foldlM, mapAccumLM )
 import Maybes           ( orElse )
@@ -713,7 +714,7 @@ simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops)
 simplUnfolding env top_lvl id _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_src = src, uf_guidance = guide })
-  | isInlineRuleSource src
+  | isStableSource src
   = do { expr' <- simplExpr rule_env expr
        ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src
        ; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
@@ -724,7 +725,7 @@ simplUnfolding env top_lvl id _ _
        	       -- See Note [Simplifying gently inside InlineRules] in SimplUtils
 
 simplUnfolding _ top_lvl id _occ_info new_rhs _
-  = return (mkUnfolding (isTopLevel top_lvl) (isBottomingId id) new_rhs)
+  = return (mkUnfolding InlineRhs (isTopLevel top_lvl) (isBottomingId id) new_rhs)
   -- We make an  unfolding *even for loop-breakers*.
   -- Reason: (a) It might be useful to know that they are WHNF
   -- 	     (b) In TidyPgm we currently assume that, if we want to
@@ -1503,7 +1504,7 @@ rebuildCase env scrut case_bndr alts cont
 
 rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
   -- See if we can get rid of the case altogether
-  -- See Note [Case eliminiation] 
+  -- See Note [Case elimination] 
   -- mkCase made sure that if all the alternatives are equal,
   -- then there is now only one (DEFAULT) rhs
  | all isDeadBinder bndrs       -- bndrs are [InId]
@@ -1789,7 +1790,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
 
 addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
 addBinderUnfolding env bndr rhs
-  = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False False rhs)
+  = modifyInScope env (bndr `setIdUnfolding` mkSimpleUnfolding rhs)
 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons
@@ -2016,7 +2017,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
 	      	      DataAlt dc -> setIdUnfolding case_bndr unf
 		      	  where
 			     	 -- See Note [Case binders and join points]
-		      	     unf = mkInlineRule rhs Nothing
+		      	     unf = mkInlineUnfolding Nothing rhs
 		      	     rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
 			     	   	        ++ varsToCoreExprs bndrs')
 
@@ -2271,10 +2272,14 @@ strict computation enclosing the orginal call to MkT.  Then, it won't
 "see" the MkT any more, because it's big and won't get duplicated.
 And, what is worse, nothing was gained by the case-of-case transform.
 
-When should use this case of mkDupableCont?
-However, matching on *any* single-alternative case is a *disaster*;
+So, in circumstances like these, we don't want to build join points
+and push the outer case into the branches of the inner one. Instead,
+don't duplicate the continuation. 
+
+When should we use this strategy?  We should not use it on *every*
+single-alternative case:
   e.g.  case (case ....) of (a,b) -> (# a,b #)
-  We must push the outer case into the inner one!
+Here we must push the outer case into the inner one!
 Other choices:
 
    * Match [(DEFAULT,_,_)], but in the common case of Int,
@@ -2296,7 +2301,7 @@ Other choices:
      the *un-simplified* rhs, which is fine.  It might get bigger or
      smaller after simplification; if it gets smaller, this case might
      fire next time round.  NB also that we must test contIsDupable
-     case_cont *btoo, because case_cont might be big!
+     case_cont *too, because case_cont might be big!
 
      HOWEVER: I found that this version doesn't work well, because
      we can get         let x = case (...) of { small } in ...case x...