[project @ 2005-03-02 10:00:36 by simonmar]

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

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 021ee87..bc45bef 100644 (file)
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -20,20 +20,20 @@ module OccurAnal (
 import CoreSyn
 import CoreFVs         ( idRuleVars )
 import CoreUtils       ( exprIsTrivial )
-import Id              ( isDataConId, isOneShotLambda, setOneShotLambda, 
+import Id              ( isDataConWorkId, isOneShotBndr, setOneShotLambda, 
                          idOccInfo, setIdOccInfo,
                          isExportedId, modifyIdInfo, idInfo, idArity,
                          idSpecialisation, isLocalId,
                          idType, idUnique, Id
                        )
-import IdInfo          ( shortableIdInfo, copyIdInfo )
+import IdInfo          ( copyIdInfo )
 import BasicTypes      ( OccInfo(..), isOneOcc )
 
 import VarSet
 import VarEnv
 
-import Type            ( splitFunTy_maybe, splitForAllTys )
-import Maybes          ( maybeToBool, orElse )
+import Type            ( isFunTy, dropForAlls )
+import Maybes          ( orElse )
 import Digraph         ( stronglyConnCompR, SCC(..) )
 import PrelNames       ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
 import Unique          ( Unique )
@@ -246,7 +246,7 @@ occAnalBind env (NonRec binder rhs) body_usage
 
   where
     (final_body_usage, tagged_binder) = tagBinder body_usage binder
-    (rhs_usage, rhs')                = occAnalRhs env binder rhs
+    (rhs_usage, rhs')                = occAnalRhs env tagged_binder rhs
 \end{code}
 
 Dropping dead code for recursive bindings is done in a very simple way:
@@ -485,9 +485,7 @@ reOrderRec env (CyclicSCC (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 (maybeToBool (splitFunTy_maybe rho_ty))
-                 where
-                   (_, rho_ty) = splitForAllTys ty
+    not_fun_ty ty = not (isFunTy (dropForAlls ty))
 \end{code}
 
 @occAnalRhs@ deals with the question of bindings where the Id is marked
@@ -504,26 +502,34 @@ ToDo: try using the occurrence info for the inline'd binder.
 \begin{code}
 occAnalRhs :: OccEnv
           -> Id -> CoreExpr    -- Binder and rhs
+                               -- For non-recs the binder is alrady tagged
+                               -- with occurrence info
           -> (UsageDetails, CoreExpr)
 
 occAnalRhs env id rhs
   = (final_usage, rhs')
   where
-    (rhs_usage, rhs') = occAnal (rhsCtxt env) rhs
-       -- Note that we use an rhsCtxt.  This tells the occ anal that it's
-       -- looking at an RHS, which has an effect in occAnalApp
+    (rhs_usage, rhs') = occAnal ctxt rhs
+    ctxt | certainly_inline id = env
+        | otherwise           = rhsCtxt env
+       -- Note that we generally use an rhsCtxt.  This tells the occ anal n
+       -- that it's looking at an RHS, which has an effect in occAnalApp
        --
        -- But there's a problem.  Consider
        --      x1 = a0 : []
        --      x2 = a1 : x1
        --      x3 = a2 : x2
-       --      g  = f x2
+       --      g  = f x3
        -- First time round, it looks as if x1 and x2 occur as an arg of a 
        -- let-bound constructor ==> give them a many-occurrence.
        -- But then x3 is inlined (unconditionally as it happens) and
        -- next time round, x2 will be, and the next time round x1 will be
        -- Result: multiple simplifier iterations.  Sigh.  
-       -- Possible solution: use rhsCtxt for things that occur just once...
+       -- 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
 
        -- [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
@@ -535,6 +541,7 @@ occAnalRhs env id rhs
     add v u = addOneOcc u v NoOccInfo          -- Give a non-committal binder info
                                                -- (i.e manyOcc) because many copies
                                                -- of the specialised thing can appear
+
 \end{code}
 
 Expressions
@@ -641,9 +648,9 @@ occAnal env expr@(Lam _ _)
     env2             = env1 `addNewCands` binders      -- Add in-scope binders
     env_body         = vanillaCtxt env2                -- Body is (no longer) an RhsContext
 
-occAnal env (Case scrut bndr alts)
+occAnal env (Case scrut bndr ty alts)
   = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts')   -> 
-    case occAnal (vanillaCtxt env) scrut                   of { (scrut_usage, scrut') ->
+    case occAnal (vanillaCtxt env) scrut           of { (scrut_usage, scrut') ->
        -- No need for rhsCtxt
     let
        alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
@@ -651,7 +658,7 @@ occAnal env (Case scrut bndr alts)
        (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
         total_usage = scrut_usage `combineUsageDetails` alts_usage1
     in
-    total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }}
+    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
   where
     alt_env = env `addNewCand` bndr
 
@@ -697,7 +704,7 @@ occAnalApp env (Var fun, args) is_rhs
        -- This is the *whole point* of the isRhsEnv predicate
         final_args_uds
                | isRhsEnv env,
-                 isDataConId fun || valArgCount args < idArity fun
+                 isDataConWorkId fun || valArgCount args < idArity fun
                = mapVarEnv markMany args_uds
                | otherwise = args_uds
     in
@@ -830,7 +837,7 @@ isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands
 
 addNewCands :: OccEnv -> [Id] -> OccEnv
 addNewCands (OccEnv cands encl ctxt) ids
-  = OccEnv (cands `unionVarSet` mkVarSet ids) encl ctxt
+  = OccEnv (extendVarSetList cands ids) encl ctxt
 
 addNewCand :: OccEnv -> Id -> OccEnv
 addNewCand (OccEnv cands encl ctxt) id
@@ -852,7 +859,7 @@ oneShotGroup (OccEnv cands encl ctxt) bndrs
   = case go ctxt bndrs [] of
        (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
   where
-    is_one_shot b = isId b && isOneShotLambda b
+    is_one_shot b = isId b && isOneShotBndr b
 
     go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)