From: sof <unknown>
Date: Thu, 4 Sep 1997 20:04:29 +0000 (+0000)
Subject: [project @ 1997-09-04 20:04:29 by sof]
X-Git-Tag: Approximately_1000_patches_recorded~19
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=239486608f58da07892ae6a37ea23e35eb2a2ab8

[project @ 1997-09-04 20:04:29 by sof]
new function: extendEnvGivenInlining
---

diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 52d8a97..68453bc 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -21,7 +21,7 @@ module SimplEnv (
 	markDangerousOccs,
 	lookupRhsInfo, lookupOutIdEnv, isEvaluated,
 	extendEnvGivenBinding, extendEnvGivenNewRhs,
-	extendEnvGivenRhsInfo,
+	extendEnvGivenRhsInfo, extendEnvGivenInlining,
 
 	lookForConstructor,
 
@@ -84,7 +84,7 @@ import TyVar		( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
 			  SYN_IE(TyVar)
 			)
 import Unique		( Unique{-instance Outputable-}, Uniquable(..) )
-import UniqFM		( addToUFM_C, ufmToList	)
+import UniqFM		( addToUFM, addToUFM_C, ufmToList )
 import Usage		( SYN_IE(UVar), GenUsage{-instances-} )
 import Util		( SYN_IE(Eager), appEager, returnEager, runEager,
 			  zipEqual, thenCmp, cmpList, panic, panic#, assertPanic, Ord3(..) )
@@ -370,8 +370,11 @@ data RhsInfo = NoRhsInfo
 	     | OtherLit [Literal]		-- It ain't one of these
 	     | OtherCon [Id]			-- It ain't one of these
 
+		-- InUnfolding is used for let(rec) bindings that
+		-- are *definitely* going to be inlined.
+		-- We record the un-simplified RHS and drop the binding
 	     | InUnfolding SimplEnv		-- Un-simplified unfolding
-			   SimpleUnfolding	-- (need to snag envts therefore)
+			   SimplifiableCoreExpr	-- (need to snag envts therefore)
 
 	     | OutUnfolding CostCentre
 			    SimpleUnfolding	-- Already-simplified unfolding
@@ -401,7 +404,6 @@ modifyOutEnvItem (id, occ, info1) (_, _, info2)
 isEvaluated :: RhsInfo -> Bool
 isEvaluated (OtherLit _) = True
 isEvaluated (OtherCon _) = True
-isEvaluated (InUnfolding _  (SimpleUnfolding ValueForm _ expr)) = True
 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
 isEvaluated other = False
 \end{code}
@@ -436,6 +438,14 @@ markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) a
 \end{code}
 
 
+\begin{code}
+extendEnvGivenInlining :: SimplEnv -> Id -> BinderInfo -> InExpr -> SimplEnv
+extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
+		       id occ_info rhs
+  = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
+  where
+    new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs)
+\end{code}
 
 %************************************************************************
 %*									*
@@ -542,27 +552,6 @@ cmp_app (UCA c1 as1) (UCA c2 as2)
 \end{code}
 
 
-
-
-
-============================  OLD ================================
-	This version was used when we use the *simplified* RHS of a 
-	let as the thing's unfolding.  The has the nasty property described
-	in the following comments.  Much worse, it can fail to terminate
-	on recursive things.  Consider
-
-		letrec f = \x -> let z = f x' in ...
-
-		in
-		let n = f y
-		in
-		case n of { ... }
-
-	If we bind n to its *simplified* RHS, we then *re-simplify* it when
-	we inline n.  Then we may well inline f; and then the same thing
-	happens with z!
-
-
 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 of a new binding.  There is a horrid case we have to take care about,
 due to Andr\'e Santos: