X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=fc9104fb22b318b9bd0c15db78df1bae8bd7bf56;hb=4c7846e8a0336f71d5c16798e103980f83532c30;hp=d13fa3b20d3c6e0fe4b6d82d3d51a78d31cea1d6;hpb=805edf6e400001f6e11b4721b285ecd51e0c2445;p=ghc-hetmet.git

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index d13fa3b..fc9104f 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -23,14 +23,13 @@ import CoreUtils	( exprIsTrivial, isDefaultAlt )
 import Id		( isDataConWorkId, isOneShotBndr, setOneShotLambda, 
 			  idOccInfo, setIdOccInfo, isLocalId,
 			  isExportedId, idArity, idHasRules,
-			  idType, idUnique, Id
+			  idUnique, Id
 			)
 import BasicTypes	( OccInfo(..), isOneOcc, InterestingCxt )
 
 import VarSet
 import VarEnv
 
-import Type		( isFunTy, dropForAlls )
 import Maybes		( orElse )
 import Digraph		( stronglyConnCompR, SCC(..) )
 import PrelNames	( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
@@ -301,7 +300,7 @@ reOrderCycle bndrs (bind : binds)
 		-- where df is the exported dictionary. Then df makes a really
 		-- bad choice for loop breaker
 	  
-	| not_fun_ty (idType bndr) = 3	-- Data types help with cases
+	| is_con_app rhs = 3	-- Data types help with cases
 		-- This used to have a lower score than inlineCandidate, but
 		-- it's *really* helpful if dictionaries get inlined fast,
 		-- so I'm experimenting with giving higher priority to data-typed things
@@ -328,7 +327,16 @@ reOrderCycle bndrs (bind : binds)
 	-- we didn't stupidly choose d as the loop breaker.
 	-- But we won't because constructor args are marked "Many".
 
-    not_fun_ty ty = not (isFunTy (dropForAlls ty))
+	-- Cheap and cheerful; the simplifer moves casts out of the way
+	-- The lambda case is important to spot x = /\a. C (f a)
+	-- which comes up when C is a dictionary constructor and
+	-- f is a default method.  
+	-- Example: the instance for Show (ST s a) in GHC.ST
+    is_con_app (Var v)    = isDataConWorkId v
+    is_con_app (App f _)  = is_con_app f
+    is_con_app (Lam b e) | isTyVar b = is_con_app e
+    is_con_app (Note _ e) = is_con_app e
+    is_con_app other      = False
 
 makeLoopBreaker :: VarSet		-- Binders of this group
 		-> UsageDetails		-- Usage of this rhs (neglecting rules)
@@ -482,7 +490,10 @@ occAnal env (Note note body)
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->
-    (usage, Cast expr' co)
+    (markRhsUds env True usage, Cast expr' co)
+	-- If we see let x = y `cast` co
+	-- then mark y as 'Many' so that we don't
+	-- immediately inline y again. 
     }
 \end{code}
 
@@ -581,23 +592,13 @@ the "build hack" to work.
 occAnalApp env (Var fun, args) is_rhs
   = case args_stuff of { (args_uds, args') ->
     let
-	-- We mark the free vars of the argument of a constructor or PAP 
-	-- as "many", if it is the RHS of a let(rec).
-	-- This means that nothing gets inlined into a constructor argument
-	-- position, which is what we want.  Typically those constructor
-	-- arguments are just variables, or trivial expressions.
-	--
-	-- This is the *whole point* of the isRhsEnv predicate
-        final_args_uds
-		| isRhsEnv env,
-		  isDataConWorkId fun || valArgCount args < idArity fun
-		= mapVarEnv markMany args_uds
-		| otherwise = args_uds
+        final_args_uds = markRhsUds env is_pap args_uds
     in
     (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
   where
     fun_uniq = idUnique fun
     fun_uds  = mkOneOcc env fun (valArgCount args > 0)
+    is_pap = isDataConWorkId fun || valArgCount args < idArity fun
 
 		-- Hack for build, fold, runST
     args_stuff	| fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
@@ -628,6 +629,23 @@ occAnalApp env (fun, args) is_rhs
     in
     (final_uds, mkApps fun' args') }}
     
+
+markRhsUds :: OccEnv		-- Check if this is a RhsEnv
+	   -> Bool		-- and this is true
+	   -> UsageDetails	-- The do markMany on this
+	   -> UsageDetails
+-- We mark the free vars of the argument of a constructor or PAP 
+-- as "many", if it is the RHS of a let(rec).
+-- This means that nothing gets inlined into a constructor argument
+-- position, which is what we want.  Typically those constructor
+-- arguments are just variables, or trivial expressions.
+--
+-- This is the *whole point* of the isRhsEnv predicate
+markRhsUds env is_pap arg_uds
+  | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
+  | otherwise 		   = arg_uds
+
+
 appSpecial :: OccEnv 
 	   -> Int -> CtxtTy	-- Argument number, and context to use for it
 	   -> [CoreExpr]