Make -fliberate-case work for GADTs

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

diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs
index e97480f..338a351 100644 (file)
--- a/ghc/compiler/stranal/SaLib.lhs
+++ b/ghc/compiler/stranal/SaLib.lhs
@@ -6,6 +6,10 @@
 See also: the ``library'' for the ``back end'' (@SaBackLib@).
 
 \begin{code}
+#ifndef OLD_STRICTNESS
+module SaLib () where
+#else
+
 module SaLib (
        AbsVal(..),
        AnalysisKind(..),
@@ -18,11 +22,10 @@ module SaLib (
 
 #include "HsVersions.h"
 
-import Id              ( Id )
-import CoreSyn         ( CoreExpr )
+import Type            ( Type )
 import VarEnv
 import IdInfo          ( StrictnessInfo(..) )
-import Demand          ( Demand, pprDemands )
+import Demand          ( Demand )
 import Outputable
 \end{code}
 
@@ -38,7 +41,7 @@ import Outputable
 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.
@@ -51,21 +54,21 @@ 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              -- 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
            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)
@@ -80,12 +83,9 @@ instance Outputable AbsVal where
     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 (AbsFun bndr_ty body) = ptext SLIT("AbsFun")
     ppr (AbsApproxFun demands val)
-      = hsep [ptext SLIT("AbsApprox "), pprDemands demands, ppr val]
+      = ptext SLIT("AbsApprox") <+> brackets (interpp'SP demands) <+> ppr val
 \end{code}
 
 %-----------
@@ -113,10 +113,18 @@ lookupAbsValEnv (AbsValEnv idenv) y
 \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 args_info _) = AbsApproxFun args_info AbsTop
+\begin{code}
+#endif /* OLD_STRICTNESS */
 \end{code}