Fix simplifier statistics

[ghc-hetmet.git] / compiler / simplCore / OccurAnal.lhs

diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 2199ab1..22e042a 100644 (file)
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -37,7 +37,7 @@ import UniqFM           ( keysUFM, intersectUFM_C, foldUFM_Directly )
 import Util             ( mapAndUnzip, filterOut )
 import Bag
 import Outputable
-
+import FastString
 import Data.List
 \end{code}
 
@@ -826,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.
@@ -940,7 +940,14 @@ occAnalApp :: OccEnv
 occAnalApp env (Var fun, args)
   = case args_stuff of { (args_uds, args') ->
     let
-        final_args_uds = markRhsUds env is_exp 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
@@ -981,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
@@ -1093,6 +1090,10 @@ data OccEncl
   | OccVanilla          -- Argument of function, body of lambda, scruintee of case etc.
                         -- Do inline into constructor args here
 
+instance Outputable OccEncl where
+  ppr OccRhs     = ptext (sLit "occRhs")
+  ppr OccVanilla = ptext (sLit "occVanilla")
+
 type CtxtTy = [Bool]
         -- []           No info
         --
@@ -1370,8 +1371,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