%
-% (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}
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-}, SYN_IE(StrictEnv), SYN_IE(AbsenceEnv),
- SYN_IE(StrAnalFlags), getStrAnalFlags,
+ AbsValEnv{-abstract-}, StrictEnv, AbsenceEnv,
+ mkAbsApproxFun,
nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
lookupAbsValEnv,
absValFromStrictness
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-import CoreSyn ( SYN_IE(CoreExpr) )
-import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList,
- lookupIdEnv, SYN_IE(IdEnv),
- GenId{-instance Outputable-}, SYN_IE(Id)
- )
+import Type ( Type )
+import VarEnv
import IdInfo ( StrictnessInfo(..) )
-import Demand ( Demand{-instance Outputable-} )
-import Outputable ( Outputable(..){-instance * []-} )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty ( ptext, hsep, char )
+import Demand ( Demand )
+import Outputable
\end{code}
%************************************************************************
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.
| 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 -- argument
- CoreExpr -- 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
+ [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 sty AbsTop = ptext SLIT("AbsTop")
- ppr sty AbsBot = ptext SLIT("AbsBot")
- ppr sty (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr sty prod]
- ppr sty (AbsFun arg body env)
- = hsep [ptext SLIT("AbsFun{"), ppr sty arg,
- ptext SLIT("???"), -- text "}{env:", ppr sty (keysFM env `zip` eltsFM env),
- char '}' ]
- ppr sty (AbsApproxFun demand val)
- = hsep [ptext SLIT("AbsApprox "), ppr sty demand, ppr sty val ]
+ 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}
%-----------
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
+nullAbsValEnv -- this is the one and only way to create AbsValEnvs
+ = AbsValEnv emptyVarEnv
-addOneToAbsValEnv (AbsValEnv x idenv) y z = AbsValEnv x (addOneToIdEnv idenv y z)
-growAbsValEnvList (AbsValEnv x idenv) ys = AbsValEnv x (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
-
-getStrAnalFlags (AbsValEnv flags _) = flags
+lookupAbsValEnv (AbsValEnv idenv) y
+ = lookupVarEnv idenv y
\end{code}
\begin{code}
-absValFromStrictness :: AnalysisKind -> StrictnessInfo bdee -> AbsVal
-
-absValFromStrictness anal NoStrictnessInfo = AbsTop
+absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
+
+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 args_info _) = foldr AbsApproxFun AbsTop args_info
+\begin{code}
+#endif /* OLD_STRICTNESS */
\end{code}
projects / ghc-hetmet.git / blobdiff