X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FSaLib.lhs;h=338a351530dc207e53e0468f7846dc7ede7cc516;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=52f66506ac2efeb1fe47bc1074c1ce7d59cbc5b4;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index 52f6650..338a351 100644
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -1,34 +1,32 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 \section[SaLib]{Basic datatypes, functions for the strictness analyser}
 
 See also: the ``library'' for the ``back end'' (@SaBackLib@).
 
 \begin{code}
-#include "HsVersions.h"
+#ifndef OLD_STRICTNESS
+module SaLib () where
+#else
 
 module SaLib (
 	AbsVal(..),
 	AnalysisKind(..),
-	AbsValEnv{-abstract-}, StrictEnv(..), AbsenceEnv(..),
-	StrAnalFlags(..), getStrAnalFlags,
+	AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv,
+	mkAbsApproxFun,
 	nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
 	lookupAbsValEnv,
-	absValFromStrictness,
-
-	-- and to make the interface self-sufficient...
-	CoreExpr, Id, IdEnv(..), UniqFM, Unique,
-	Demand, PlainCoreExpr(..)
+	absValFromStrictness
     ) where
 
-import IdEnv
-import IdInfo
---import FiniteMap	-- debugging only
+#include "HsVersions.h"
+
+import Type		( Type )
+import VarEnv
+import IdInfo		( StrictnessInfo(..) )
+import Demand		( Demand )
 import Outputable
-import PlainCore
-import Pretty
-import Util		-- for pragmas only
 \end{code}
 
 %************************************************************************
@@ -43,7 +41,7 @@ import Util		-- for pragmas only
 data AnalysisKind
   = StrAnal 	-- We're doing strictness analysis
   | AbsAnal	-- We're doing absence analysis
-  deriving Text
+  deriving Show
 \end{code}
 
 @AbsVal@ is the data type of HNF abstract values.
@@ -56,73 +54,77 @@ data AbsVal
   | AbsBot		    -- An expression whose abstract value is
 			    -- AbsBot is sure to fail to terminate.
 			    -- AbsBot represents the abstract
-			    -- *function* bottom too.
+			    --  *function* bottom too.
 
   | AbsProd [AbsVal]	    -- (Lifted) product of abstract values
 			    -- "Lifted" means that AbsBot is *different* from
 			    --    AbsProd [AbsBot, ..., AbsBot]
 
   | AbsFun	    	    -- An abstract function, with the given:
-	    [Id]	    -- arguments
-	    PlainCoreExpr   -- body
-	    AbsValEnv	    -- and environment
+	    Type	   	 -- Type of the *argument* to the function
+	    (AbsVal -> AbsVal)	-- The function
 
   | AbsApproxFun	    -- This is used to represent a coarse
 	    [Demand]	    -- approximation to a function value.  It's an
-	    		    -- abstract function which is strict in its i'th
-			    -- argument if the i'th element of the Demand
-			    -- list so indicates.
-			    -- The list of arguments is always non-empty.
-			    -- In effect, AbsApproxFun [] = AbsTop 
+	    AbsVal	    -- abstract function which is strict in its
+			    -- 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 sty AbsTop = ppStr "AbsTop"
-    ppr sty AbsBot = ppStr "AbsBot"
-    ppr sty (AbsProd prod) = ppCat [ppStr "AbsProd", ppr sty prod]
-    ppr sty (AbsFun args body env)
-      = ppCat [ppStr "AbsFun{", ppr sty args,
-	       ppStr "???", -- ppStr "}{env:", ppr sty (keysFM env `zip` eltsFM env),
-	       ppStr "}" ]
-    ppr sty (AbsApproxFun demands)
-      = ppCat [ppStr "AbsApprox{", ppr sty demands, ppStr "}" ]
+    ppr AbsTop = ptext SLIT("AbsTop")
+    ppr AbsBot = ptext SLIT("AbsBot")
+    ppr (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr prod]
+    ppr (AbsFun bndr_ty body) = ptext SLIT("AbsFun")
+    ppr (AbsApproxFun demands val)
+      = ptext SLIT("AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val
 \end{code}
 
 %-----------
 
 An @AbsValEnv@ maps @Ids@ to @AbsVals@.  Any unbound @Ids@ are
 implicitly bound to @AbsTop@, the completely uninformative,
-pessimistic value---see @absEval@ of a @CoVar@.
+pessimistic value---see @absEval@ of a @Var@.
 
 \begin{code}
-data AbsValEnv = AbsValEnv StrAnalFlags (IdEnv AbsVal)
-
-type StrAnalFlags
-  = (Bool,	-- True <=> AllStrict flag is set
-     Bool)	-- True <=> NumbersStrict flag is set
+newtype AbsValEnv = AbsValEnv (IdEnv AbsVal)
 
 type StrictEnv  = AbsValEnv	-- Environment for strictness analysis
 type AbsenceEnv = AbsValEnv	-- Environment for absence analysis
 
-nullAbsValEnv flags -- this is the one and only way to create AbsValEnvs
-  = AbsValEnv flags nullIdEnv
-
-addOneToAbsValEnv (AbsValEnv x idenv) y z = AbsValEnv x (addOneToIdEnv idenv y z)
-growAbsValEnvList (AbsValEnv x idenv) ys  = AbsValEnv x (growIdEnvList idenv ys)
+nullAbsValEnv -- this is the one and only way to create AbsValEnvs
+  = AbsValEnv emptyVarEnv
 
-lookupAbsValEnv (AbsValEnv _ idenv) y
-  = lookupIdEnv idenv y
+addOneToAbsValEnv (AbsValEnv idenv) y z = AbsValEnv (extendVarEnv idenv y z)
+growAbsValEnvList (AbsValEnv idenv) ys  = AbsValEnv (extendVarEnvList idenv ys)
 
-getStrAnalFlags (AbsValEnv flags _) = flags
+lookupAbsValEnv (AbsValEnv idenv) y
+  = lookupVarEnv idenv y
 \end{code}
 
 \begin{code}
 absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
 
-absValFromStrictness anal NoStrictnessInfo 	       = AbsTop
+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}
 
-absValFromStrictness StrAnal BottomGuaranteed 	       = AbsBot -- Guaranteed bottom
-absValFromStrictness AbsAnal BottomGuaranteed 	       = AbsTop	-- Check for poison in
-								-- arguments (if any)
-absValFromStrictness anal (StrictnessInfo []        _) = AbsTop
-absValFromStrictness anal (StrictnessInfo args_info _) = AbsApproxFun args_info
+\begin{code}
+#endif /* OLD_STRICTNESS */
 \end{code}