X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=7ac45ccda0e6562252120cd0ec9720f713329a47;hb=bd8a952b1ec55c1c8fe6db968f8f0cc08596a550;hp=53a89d58972960fdfb7975a25f3b71cdc61fd84d;hpb=c93e8323ab49dd369e8b5f04027462a6fc1b8249;p=ghc-hetmet.git

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 53a89d5..7ac45cc 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -20,7 +20,7 @@ module OccurAnal (
 import CoreSyn
 import CoreFVs
 import Type		( tyVarsOfType )
-import CoreUtils        ( exprIsTrivial, isDefaultAlt, mkCoerceI )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
 import Coercion		( CoercionI(..), mkSymCoI )
 import Id
 import Name		( localiseName )
@@ -532,11 +532,11 @@ reOrderCycle depth (bind : binds) pairs
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
 	   	     	      -- Note [DFuns should not be loop breakers]
 
-        | Just (inl_rule_info, _) <- isInlineRule_maybe (idUnfolding bndr)
-	= case inl_rule_info of
-	     InlWrapper {} -> 10  -- Note [INLINE pragmas]
-	     _other	   ->  3  -- Data structures are more important than this
-	     		          -- so that dictionary/method recursion unravels
+        | Just (inl_source, _) <- isInlineRule_maybe (idUnfolding bndr)
+	= case inl_source of
+	     InlineWrapper {} -> 10  -- Note [INLINE pragmas]
+	     _other	      ->  3  -- Data structures are more important than this
+	     		             -- so that dictionary/method recursion unravels
 		-- Note that this case hits all InlineRule things, so we
 		-- never look at 'rhs for InlineRule stuff. That's right, because
 		-- 'rhs' is irrelevant for inlining things with an InlineRule
@@ -559,8 +559,9 @@ reOrderCycle depth (bind : binds) pairs
 
         | isOneOcc (idOccInfo bndr) = 2  -- Likely to be inlined
 
-        | canUnfold (idUnfolding bndr) = 1
-                -- the Id has some kind of unfolding
+        | canUnfold (realIdUnfolding bndr) = 1
+                -- The Id has some kind of unfolding
+		-- Ignore loop-breaker-ness here because that is what we are setting!
 
         | otherwise = 0
 
@@ -825,7 +826,7 @@ occAnal env (Note note body)
 
 occAnal env (Cast expr co)
   = case occAnal env expr of { (usage, expr') ->
-    (markRhsUds env True usage, Cast expr' co)
+      (markManyIf (isRhsEnv env) 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.
@@ -939,14 +940,23 @@ occAnalApp :: OccEnv
 occAnalApp env (Var fun, args)
   = case args_stuff of { (args_uds, args') ->
     let
-        final_args_uds = markRhsUds env is_pap args_uds
+       final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
+	  -- 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
     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 = isConLikeId fun || valArgCount args < idArity fun
+    is_exp = isExpandableApp fun (valArgCount args)
     	   -- See Note [CONLIKE pragma] in BasicTypes
+	   -- The definition of is_exp should match that in
+	   -- Simplify.prepareRhs
 
                 -- Hack for build, fold, runST
     args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
@@ -978,21 +988,11 @@ occAnalApp env (fun, args)
     (final_uds, mkApps fun' args') }}
 
 
-markRhsUds :: OccEnv            -- Check if this is a RhsEnv
-           -> Bool              -- and this is true
-           -> UsageDetails      -- The do markMany on this
+markManyIf :: Bool              -- If this is true
+           -> UsageDetails      -- Then 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
-
+markManyIf True  uds = mapVarEnv markMany uds
+markManyIf False uds = uds
 
 appSpecial :: OccEnv
            -> Int -> CtxtTy     -- Argument number, and context to use for it
@@ -1367,8 +1367,9 @@ extendProxyEnv pe scrut co case_bndr
   | otherwise          = PE env2 fvs2	--   don't extend
   where
     PE env1 fvs1 = trimProxyEnv pe [case_bndr]
-    env2 = extendVarEnv_C add env1 scrut1 (scrut1, [(case_bndr,co)])
-    add (x, cb_cos) _ = (x, (case_bndr,co):cb_cos)
+    env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
+    single cb_co = (scrut1, [cb_co]) 
+    add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
     fvs2 = fvs1 `unionVarSet`  freeVarsCoI co
 		`extendVarSet` case_bndr
 		`extendVarSet` scrut1