X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=ad3eee0ce7345c4250a46921ac92f980649115bb;hb=2317c27bc0ca18dec43eacf87a6cf22cdf01f0f7;hp=e0c62c1bc4fad01200e5f6209d3daa6bb61ddffa;hpb=8646084688fadcc6cce0db55d268b1a7758fc274;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index e0c62c1..ad3eee0 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -12,20 +12,20 @@ core expression with (hopefully) improved usage information.
 
 \begin{code}
 module OccurAnal (
-	occurAnalysePgm, occurAnalyseGlobalExpr, occurAnalyseRule, 
+	occurAnalysePgm, occurAnalyseExpr
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
 import CoreFVs		( idRuleVars )
-import CoreUtils	( exprIsTrivial )
+import CoreUtils	( exprIsTrivial, isDefaultAlt )
 import Id		( isDataConWorkId, isOneShotBndr, setOneShotLambda, 
 			  idOccInfo, setIdOccInfo, isLocalId,
-			  isExportedId, idArity, idSpecialisation, 
+			  isExportedId, idArity, 
 			  idType, idUnique, Id
 			)
-import BasicTypes	( OccInfo(..), isOneOcc )
+import BasicTypes	( OccInfo(..), isOneOcc, InterestingCxt )
 
 import VarSet
 import VarEnv
@@ -63,20 +63,9 @@ occurAnalysePgm binds
 	   (bs_usage, binds')   = go env binds
 	   (final_usage, bind') = occAnalBind env bind bs_usage
 
-occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
-occurAnalyseGlobalExpr expr
-  = 	-- Top level expr, so no interesting free vars, and
-	-- discard occurence info returned
-    snd (occAnal initOccEnv expr)
-
-occurAnalyseRule :: CoreRule -> CoreRule
-occurAnalyseRule rule@(BuiltinRule _ _) = rule
-occurAnalyseRule (Rule str act tpl_vars tpl_args rhs)
-		-- Add occ info to tpl_vars, rhs
-  = Rule str act tpl_vars' tpl_args rhs'
-  where
-    (rhs_uds, rhs') = occAnal initOccEnv rhs
-    (_, tpl_vars')  = tagBinders rhs_uds tpl_vars
+occurAnalyseExpr :: CoreExpr -> CoreExpr
+	-- Do occurrence analysis, and discard occurence info returned
+occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
 \end{code}
 
 
@@ -156,8 +145,6 @@ It isn't easy to do a perfect job in one blow.  Consider
 occAnalBind env (Rec pairs) body_usage
   = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
   where
-    binders = map fst pairs
-
     analysed_pairs :: [Details1]
     analysed_pairs  = [ (bndr, rhs_usage, rhs')
 		      | (bndr, rhs) <- pairs,
@@ -332,9 +319,14 @@ reOrderRec env (CyclicSCC (bind : binds))
 
 	| inlineCandidate bndr rhs = 2	-- Likely to be inlined
 
-	| not (isEmptyCoreRules (idSpecialisation bndr)) = 1
-		-- Avoid things with specialisations; we'd like
-		-- to take advantage of them in the subsequent bindings
+-- NOT NEEDED ANY MORE [Feb06]
+-- We make all rules available in all bindings, by substituting
+-- the IdInfo before looking at any RHSs.  I'm just leaving this
+-- snippet in as a commment so we can find it again if necessary.
+--
+--	| not (isEmptySpecInfo (idSpecialisation bndr)) = 1
+--		-- Avoid things with specialisations; we'd like
+--		-- to take advantage of them in the subsequent bindings
 
 	| otherwise = 0
 
@@ -395,8 +387,8 @@ occAnalRhs env id rhs
 	-- Crude solution: use rhsCtxt for things that occur just once...
 
     certainly_inline id = case idOccInfo id of
-			    OneOcc in_lam one_br -> not in_lam && one_br
-			    other		 -> False
+			    OneOcc in_lam one_br _ -> not in_lam && one_br
+			    other		   -> False
 
 	-- [March 98] A new wrinkle is that if the binder has specialisations inside
 	-- it then we count the specialised Ids as "extra rhs's".  That way
@@ -425,16 +417,10 @@ occAnal :: OccEnv
 	    CoreExpr)
 
 occAnal env (Type t)  = (emptyDetails, Type t)
-
-occAnal env (Var v) 
-  = (var_uds, Var v)
-  where
-    var_uds | isLocalId v = unitVarEnv v oneOcc
-	    | otherwise	 = emptyDetails
-
+occAnal env (Var v)   = (mkOneOcc env v False, Var v)
     -- At one stage, I gathered the idRuleVars for v here too,
     -- which in a way is the right thing to do.
-    -- But that went wrong right after specialisation, when
+    -- Btu that went wrong right after specialisation, when
     -- the *occurrences* of the overloaded function didn't have any
     -- rules in them, so the *specialised* versions looked as if they
     -- weren't used at all.
@@ -521,9 +507,8 @@ occAnal env expr@(Lam _ _)
     is_one_shot b   = isId b && isOneShotBndr b
 
 occAnal env (Case scrut bndr ty alts)
-  = case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts')   -> 
-    case occAnal vanillaCtxt scrut		    of { (scrut_usage, scrut') ->
-	-- No need for rhsCtxt
+  = case occ_anal_scrut scrut alts		of { (scrut_usage, scrut') ->
+    case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts')   -> 
     let
 	alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
 	alts_usage' = addCaseBndrUsage alts_usage
@@ -543,6 +528,12 @@ occAnal env (Case scrut bndr ty alts)
 				Nothing  -> usage
 				Just occ -> extendVarEnv usage bndr (markMany occ)
 
+    occ_anal_scrut (Var v) (alt1 : other_alts)
+				| not (null other_alts) || not (isDefaultAlt alt1)
+			        = (mkOneOcc env v True, Var v)
+    occ_anal_scrut scrut alts   = occAnal vanillaCtxt scrut
+					-- No need for rhsCtxt
+
 occAnal env (Let bind body)
   = case occAnal env body     	         of { (body_usage, body') ->
     case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
@@ -579,10 +570,7 @@ occAnalApp env (Var fun, args) is_rhs
     (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
   where
     fun_uniq = idUnique fun
-
-    fun_uds | isLocalId fun = unitVarEnv fun oneOcc
-	    | otherwise	    = emptyDetails
-
+    fun_uds  = mkOneOcc env fun (valArgCount args > 0)
     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
@@ -803,8 +791,10 @@ setBinderOcc usage bndr
 %************************************************************************
 
 \begin{code}
-oneOcc :: OccInfo
-oneOcc = OneOcc False True
+mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
+mkOneOcc env id int_cxt
+  | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
+  | otherwise    = emptyDetails
 
 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
 
@@ -813,8 +803,8 @@ markMany other   = NoOccInfo
 
 markInsideSCC occ = markMany occ
 
-markInsideLam (OneOcc _ one_br) = OneOcc True one_br
-markInsideLam occ		= occ
+markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
+markInsideLam occ		 	= occ
 
 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
 
@@ -827,10 +817,11 @@ addOccInfo info1 info2   = NoOccInfo
 
 orOccInfo IAmDead info2 = info2
 orOccInfo info1 IAmDead = info1
-orOccInfo (OneOcc in_lam1 one_branch1)
-	  (OneOcc in_lam2 one_branch2)
+orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
+	  (OneOcc in_lam2 one_branch2 int_cxt2)
   = OneOcc (in_lam1 || in_lam2)
 	   False	-- False, because it occurs in both branches
+	   (int_cxt1 && int_cxt2)
 
 orOccInfo info1 info2 = NoOccInfo
 \end{code}