[project @ 1999-06-23 10:44:59 by simonmar]

[ghc-hetmet.git] / ghc / compiler / stranal / SaLib.lhs

diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index 13a89ce..1a057b6 100644 (file)
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -1,35 +1,29 @@
 %
-% (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"
-
 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 Id              ( Id )
+import CoreSyn         ( CoreExpr )
+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, pprDemands )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -69,20 +63,30 @@ 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 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),
+    ppr AbsTop = ptext SLIT("AbsTop")
+    ppr AbsBot = ptext SLIT("AbsBot")
+    ppr (AbsProd prod) = hsep [ptext SLIT("AbsProd"), ppr prod]
+    ppr (AbsFun arg body env)
+      = hsep [ptext SLIT("AbsFun{"), ppr arg,
+              ptext SLIT("???"), -- text "}{env:", ppr (keysFM env `zip` eltsFM env),
               char '}' ]
-    ppr sty (AbsApproxFun demand val)
-      = hsep [ptext SLIT("AbsApprox "), ppr sty demand, ppr sty val ]
+    ppr (AbsApproxFun demands val)
+      = hsep [ptext SLIT("AbsApprox "), hcat (map ppr demands), ppr val]
 \end{code}
 
 %-----------
@@ -92,34 +96,32 @@ implicitly bound to @AbsTop@, the completely uninformative,
 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 bdee -> 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 :: 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}