[project @ 2002-01-29 09:58:14 by simonpj]

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

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 6e359a3..021ee87 100644 (file)
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -26,7 +26,8 @@ import Id             ( isDataConId, isOneShotLambda, setOneShotLambda,
                          idSpecialisation, isLocalId,
                          idType, idUnique, Id
                        )
-import IdInfo          ( OccInfo(..), shortableIdInfo, copyIdInfo )
+import IdInfo          ( shortableIdInfo, copyIdInfo )
+import BasicTypes      ( OccInfo(..), isOneOcc )
 
 import VarSet
 import VarEnv
@@ -194,6 +195,9 @@ shortMeOut ind_env exported_id local_id
    
        not (local_id `elemVarEnv` ind_env)     -- Only if not already substituted for
     then
+       True
+
+{- No longer needed
        if shortableIdInfo (idInfo exported_id)         -- Only if its IdInfo is 'shortable'
                                                        -- (see the defn of IdInfo.shortableIdInfo)
        then True
@@ -202,6 +206,7 @@ shortMeOut ind_env exported_id local_id
           pprTrace "shortMeOut:" (ppr exported_id)
 #endif
                                                 False
+-}
     else
        False
 \end{code}
@@ -468,9 +473,7 @@ reOrderRec env (CyclicSCC (bind : binds))
 
     inlineCandidate :: Id -> CoreExpr -> Bool
     inlineCandidate id (Note InlineMe _) = True
-    inlineCandidate id rhs              = case idOccInfo id of
-                                               OneOcc _ _ -> True
-                                               other      -> False
+    inlineCandidate id rhs              = isOneOcc (idOccInfo id)
 
        -- Real example (the Enum Ordering instance from PrelBase):
        --      rec     f = \ x -> case d of (p,q,r) -> p x
@@ -507,6 +510,20 @@ 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
+       --
+       -- But there's a problem.  Consider
+       --      x1 = a0 : []
+       --      x2 = a1 : x1
+       --      x3 = a2 : x2
+       --      g  = f x2
+       -- 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...
 
        -- [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
@@ -622,7 +639,7 @@ occAnal env expr@(Lam _ _)
     (binders, body)   = collectBinders expr
     (linear, env1, _) = oneShotGroup env binders
     env2             = env1 `addNewCands` binders      -- Add in-scope binders
-    env_body         = vanillaCtxt env2                        -- Body is (no longer) an RhsContext
+    env_body         = vanillaCtxt env2                -- Body is (no longer) an RhsContext
 
 occAnal env (Case scrut bndr alts)
   = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts')   -> 
@@ -671,9 +688,20 @@ the "build hack" to work.
 occAnalApp env (Var fun, args) is_rhs
   = case args_stuff of { (args_uds, args') ->
     let
-       final_uds = fun_uds `combineUsageDetails` 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
+        final_args_uds
+               | isRhsEnv env,
+                 isDataConId fun || valArgCount args < idArity fun
+               = mapVarEnv markMany args_uds
+               | otherwise = args_uds
     in
-    (final_uds, mkApps (Var fun) args') }
+    (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
   where
     fun_uniq = idUnique fun
 
@@ -690,16 +718,6 @@ occAnalApp env (Var fun, args) is_rhs
                        --      foldr (\x -> let v = ...x... in \y -> ...v...) z xs
                        -- by floating in the v
 
-               | isRhsEnv env,
-                 isDataConId fun || valArgCount args < idArity fun
-               = case occAnalArgs env args of
-                   (arg_uds, args') -> (mapVarEnv markMany arg_uds, args')
-                       -- 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.
-
                | otherwise = occAnalArgs env args