X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=eee357cb7c94d36aa6d0b1867aa52b9d60065a9b;hb=c55001c567b4f6e17f7a0c174c003318aac6a8ed;hp=90a565f4ddd0782795ac95badfa4a84172cd0daa;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 90a565f..eee357c 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -22,10 +22,9 @@ import CoreFVs		( idRuleVars )
 import CoreUtils	( exprIsTrivial, isDefaultAlt )
 import Id		( isDataConWorkId, isOneShotBndr, setOneShotLambda, 
 			  idOccInfo, setIdOccInfo, isLocalId,
-			  isExportedId, idArity, idSpecialisation,
+			  isExportedId, idArity, idHasRules,
 			  idType, idUnique, Id
 			)
-import IdInfo		( isEmptySpecInfo )
 import BasicTypes	( OccInfo(..), isOneOcc, InterestingCxt )
 
 import VarSet
@@ -320,7 +319,7 @@ reOrderRec env (CyclicSCC (bind : binds))
 
 	| inlineCandidate bndr rhs = 2	-- Likely to be inlined
 
-	| not (isEmptySpecInfo (idSpecialisation bndr)) = 1
+	| idHasRules bndr = 1
 		-- Avoid things with specialisations; we'd like
 		-- to take advantage of them in the subsequent bindings
 
@@ -503,8 +502,8 @@ occAnal env expr@(Lam _ _)
     is_one_shot b   = isId b && isOneShotBndr b
 
 occAnal env (Case scrut bndr ty alts)
-  = case occ_anal_scrut scrut alts		of { (scrut_usage, scrut') ->
-    case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts')   -> 
+  = case occ_anal_scrut scrut alts		    of { (scrut_usage, scrut') ->
+    case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts')   -> 
     let
 	alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
 	alts_usage' = addCaseBndrUsage alts_usage
@@ -524,6 +523,10 @@ occAnal env (Case scrut bndr ty alts)
 				Nothing  -> usage
 				Just occ -> extendVarEnv usage bndr (markMany occ)
 
+    alt_env = setVanillaCtxt env
+	-- Consider 	x = case v of { True -> (p,q); ... }
+	-- Then it's fine to inline p and q
+
     occ_anal_scrut (Var v) (alt1 : other_alts)
 				| not (null other_alts) || not (isDefaultAlt alt1)
 			        = (mkOneOcc env v True, Var v)
@@ -546,7 +549,6 @@ Applications are dealt with specially because we want
 the "build hack" to work.
 
 \begin{code}
--- Hack for build, fold, runST
 occAnalApp env (Var fun, args) is_rhs
   = case args_stuff of { (args_uds, args') ->
     let
@@ -567,6 +569,8 @@ occAnalApp env (Var fun, args) is_rhs
   where
     fun_uniq = idUnique fun
     fun_uds  = mkOneOcc env fun (valArgCount args > 0)
+
+		-- Hack for build, fold, runST
     args_stuff	| fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
 		| fun_uniq == augmentIdKey  = appSpecial env 2 [True,True]  args
 		| fun_uniq == foldrIdKey    = appSpecial env 3 [False,True] args
@@ -628,15 +632,22 @@ is rather like
 If e turns out to be (e1,e2) we indeed get something like
 	let a = e1; b = e2; x = (a,b) in rhs
 
+Note [Aug 06]: I don't think this is necessary any more, and it helpe
+	       to know when binders are unused.  See esp the call to
+	       isDeadBinder in Simplify.mkDupableAlt
+
 \begin{code}
 occAnalAlt env case_bndr (con, bndrs, rhs)
   = case occAnal env rhs of { (rhs_usage, rhs') ->
     let
         (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
+	final_bndrs = tagged_bndrs	-- See Note [Aug06] above
+{-
 	final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
 		    | otherwise				= tagged_bndrs
 		-- Leave the binders untagged if the case 
 		-- binder occurs at all; see note above
+-}
     in
     (final_usage, (con, final_bndrs, rhs')) }
 \end{code}
@@ -686,6 +697,10 @@ rhsCtxt     = OccEnv OccRhs     []
 isRhsEnv (OccEnv OccRhs     _) = True
 isRhsEnv (OccEnv OccVanilla _) = False
 
+setVanillaCtxt :: OccEnv -> OccEnv
+setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
+setVanillaCtxt other_env	       = other_env
+
 setCtxt :: OccEnv -> CtxtTy -> OccEnv
 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt