X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaLib.lhs;h=1a057b6081591cefe21896d2e99cd4572ac3070b;hb=40dea1279d4d7940bfdfd6611939b8ec3588501c;hp=563ecc687a16f32574175d15c83cde06f80b32f2;hpb=26bb616517de72d5419b9bd4a12629fe3ba61e95;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index 563ecc6..1a057b6 100644
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 \section[SaLib]{Basic datatypes, functions for the strictness analyser}
 
@@ -10,6 +10,7 @@ module SaLib (
 	AbsVal(..),
 	AnalysisKind(..),
 	AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv,
+	mkAbsApproxFun,
 	nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
 	lookupAbsValEnv,
 	absValFromStrictness
@@ -17,15 +18,12 @@ module SaLib (
 
 #include "HsVersions.h"
 
+import Id		( Id )
 import CoreSyn		( CoreExpr )
-import Id		( nullIdEnv, addOneToIdEnv, growIdEnvList,
-			  lookupIdEnv, IdEnv,
-			  GenId{-instance Outputable-}, Id
-			)
+import VarEnv
 import IdInfo		( StrictnessInfo(..) )
-import Demand		( Demand{-instance Outputable-} )
+import Demand		( Demand, pprDemands )
 import Outputable
-import PprType		( GenType{-instance Outputable-} )
 \end{code}
 
 %************************************************************************
@@ -65,9 +63,19 @@ data AbsVal
 	    AbsValEnv	    -- and environment
 
   | AbsApproxFun	    -- This is used to represent a coarse
-	    Demand	    -- approximation to a function value.  It's an
+	    [Demand]	    -- approximation to a function value.  It's an
 	    AbsVal	    -- abstract function which is strict in its
-			    -- argument if the  Demand so indicates.
+			    -- arguments if the  Demand so indicates.
+	-- INVARIANT: the [Demand] is non-empty
+
+	-- AbsApproxFun has to take a *list* of demands, no just one,
+	-- because function spaces are now lifted.  Hence, (f bot top)
+	-- might be bot, but the partial application (f bot) is a *function*,
+	-- not bot.
+
+mkAbsApproxFun :: Demand -> AbsVal -> AbsVal
+mkAbsApproxFun d (AbsApproxFun ds val) = AbsApproxFun (d:ds) val
+mkAbsApproxFun d val	   	       = AbsApproxFun [d]    val
 
 instance Outputable AbsVal where
     ppr AbsTop = ptext SLIT("AbsTop")
@@ -77,8 +85,8 @@ instance Outputable AbsVal where
       = hsep [ptext SLIT("AbsFun{"), ppr arg,
 	       ptext SLIT("???"), -- text "}{env:", ppr (keysFM env `zip` eltsFM env),
 	       char '}' ]
-    ppr (AbsApproxFun demand val)
-      = hsep [ptext SLIT("AbsApprox "), ppr demand, ppr val]
+    ppr (AbsApproxFun demands val)
+      = hsep [ptext SLIT("AbsApprox "), hcat (map ppr demands), ppr val]
 \end{code}
 
 %-----------
@@ -94,22 +102,26 @@ type StrictEnv  = AbsValEnv	-- Environment for strictness analysis
 type AbsenceEnv = AbsValEnv	-- Environment for absence analysis
 
 nullAbsValEnv -- this is the one and only way to create AbsValEnvs
-  = AbsValEnv nullIdEnv
+  = AbsValEnv emptyVarEnv
 
-addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (addOneToIdEnv idenv y z)
-growAbsValEnvList (AbsValEnv idenv) ys  = AbsValEnv (growIdEnvList idenv ys)
+addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (extendVarEnv idenv y z)
+growAbsValEnvList (AbsValEnv idenv) ys  = AbsValEnv (extendVarEnvList idenv ys)
 
 lookupAbsValEnv (AbsValEnv idenv) y
-  = lookupIdEnv idenv y
+  = lookupVarEnv idenv y
 \end{code}
 
 \begin{code}
 absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
 
-absValFromStrictness anal NoStrictnessInfo 	       = AbsTop
-
-absValFromStrictness StrAnal BottomGuaranteed 	       = AbsBot -- Guaranteed bottom
-absValFromStrictness AbsAnal BottomGuaranteed 	       = AbsTop	-- Check for poison in
-								-- arguments (if any)
-absValFromStrictness anal (StrictnessInfo args_info _) = foldr AbsApproxFun AbsTop args_info
+absValFromStrictness anal NoStrictnessInfo = AbsTop
+absValFromStrictness anal (StrictnessInfo args_info bot_result)
+  = case args_info of	-- Check the invariant that the arg list on 
+	[] -> res	-- AbsApproxFun is non-empty
+	_  -> AbsApproxFun args_info res
+  where
+    res | not bot_result = AbsTop
+	| otherwise      = case anal of
+				StrAnal -> AbsBot
+				AbsAnal -> AbsTop
 \end{code}