Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/903a1a9a61eb81a84ac7f28d0467ca7d71fe8877 >--------------------------------------------------------------- commit 903a1a9a61eb81a84ac7f28d0467ca7d71fe8877 Author: Ilya Sergey <[email protected]> Date: Wed Jul 4 15:21:12 2012 +0100 join domain implemented and tested >--------------------------------------------------------------- compiler/basicTypes/NewDemand.lhs | 177 ++++++++++++++++++++++++++---------- 1 files changed, 128 insertions(+), 49 deletions(-) diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs index 6c90069..66a5581 100644 --- a/compiler/basicTypes/NewDemand.lhs +++ b/compiler/basicTypes/NewDemand.lhs @@ -11,22 +11,28 @@ module NewDemand ( #include "HsVersions.h" +import Outputable + + \end{code} %************************************************************************ %* * -\subsection{Complete Lattices} +\subsection{Lattice-like structure for domains} %* * %************************************************************************ \begin{code} -class Lattice a where +class LatticeLike a where bot :: a top :: a pre :: a -> a -> Bool lub :: a -> a -> a - glb :: a -> a -> a + both :: a -> a -> a + +class Equivalent a where + equiv :: a -> a -> Bool \end{code} @@ -41,53 +47,65 @@ class Lattice a where -- Vanilla strictness domain data StrDmd - = HyperStr -- Hyperstrict + = HyperStr -- Hyperstrict | Lazy -- Lazy | Str -- Strict - | StrProd [StrDmd] -- Product or function demand - deriving ( Eq ) + | SProd [StrDmd] -- Product or function demand + deriving ( Eq, Show ) + + +instance Outputable StrDmd where + ppr HyperStr = char 'H' + ppr Lazy = char 'L' + ppr Str = char 'S' + ppr (SProd sx) = (char 'S') <> parens (hcat (map ppr sx)) + -- Equivalences on strictness demands -isEquivStr :: StrDmd -> StrDmd -> Bool --- S(... bot ...) == bot -isEquivStr (StrProd sx) HyperStr = any (flip isEquivStr HyperStr) sx -isEquivStr HyperStr (StrProd sx) = isEquivStr (StrProd sx) HyperStr --- S(L ... L) == S -isEquivStr (StrProd sx) Str = all (== Lazy) sx -isEquivStr Str (StrProd sx) = isEquivStr (StrProd sx) Str -isEquivStr x y = x == y - --- Lattice implementation for strictness demands -instance Lattice StrDmd where +instance Equivalent StrDmd where + -- S(... bot ...) == bot + equiv (SProd sx) HyperStr = any (flip equiv HyperStr) sx + equiv HyperStr (SProd sx) = equiv (SProd sx) HyperStr + -- S(L ... L) == S + equiv (SProd sx) Str = all (== Lazy) sx + equiv Str (SProd sx) = equiv (SProd sx) Str + equiv x y = x == y + + +-- LatticeLike implementation for strictness demands +instance LatticeLike StrDmd where bot = HyperStr top = Lazy - _ `pre` Lazy = True - s `pre` _ | isEquivStr s bot = True - (StrProd _) `pre` Str = True - (StrProd sx1) `pre` (StrProd sx2) - | length sx1 == length sx2 = all (== True) $ zipWith pre sx1 sx2 - _ `pre` _ = False - - s `lub` t | isEquivStr t bot = s - t `lub` s | isEquivStr t bot = s - _ `lub` Lazy = top - Lazy `lub` _ = top - (StrProd _) `lub` t | isEquivStr t Str = t - t `lub` (StrProd _) | isEquivStr t Str = t - (StrProd sx1) `lub` (StrProd sx2) - | length sx1 == length sx2 = StrProd $ zipWith lub sx1 sx2 - _ `lub` _ = top - - _ `glb` t | isEquivStr t bot = bot - t `glb` _ | isEquivStr t bot = bot - s `glb` Lazy = s - Lazy `glb` s = s - s@(StrProd _) `glb` t | isEquivStr t Str = s - t `glb` s@(StrProd _) | isEquivStr t Str = s - (StrProd sx1) `glb` (StrProd sx2) - | length sx1 == length sx2 = StrProd $ zipWith glb sx1 sx2 - _ `glb` _ = bot + pre _ Lazy = True + pre s _ | equiv s bot = True + pre (SProd _) Str = True + pre (SProd sx1) (SProd sx2) + | length sx1 == length sx2 = all (== True) $ zipWith pre sx1 sx2 + pre x y = equiv x y + + lub s t | equiv t bot = s + lub t s | equiv t bot = s + lub _ Lazy = top + lub Lazy _ = top + lub (SProd _) t | equiv t Str = t + lub t (SProd _) | equiv t Str = t + lub (SProd sx1) (SProd sx2) + | length sx1 == length sx2 = SProd $ zipWith lub sx1 sx2 + | otherwise = Str + lub x y | x == y = x + lub _ _ = top + + both _ t | equiv t bot = bot + both t _ | equiv t bot = bot + both s Lazy = s + both Lazy s = s + both s@(SProd _) t | equiv t Str = s + both t s@(SProd _) | equiv t Str = s + both (SProd sx1) (SProd sx2) + | length sx1 == length sx2 = SProd $ zipWith both sx1 sx2 + both x y | x == y = x + both _ _ = bot \end{code} @@ -98,18 +116,79 @@ instance Lattice StrDmd where %************************************************************************ \begin{code} + data AbsDmd = Abs -- Defenitely unused | Used -- May be used | UProd [AbsDmd] -- Product - deriving ( Eq ) + deriving ( Eq, Show ) + +instance Outputable AbsDmd where + ppr Abs = char 'A' + ppr Used = char 'U' + ppr (UProd as) = (char 'U') <> parens (hcat (map ppr as)) + -- Equivalences on absense demands -_isEquivAbs :: AbsDmd -> AbsDmd -> Bool --- U(U ... U) == U -_isEquivAbs (UProd ux) Used = all (flip _isEquivAbs Used) ux -_isEquivAbs Used (UProd ux) = _isEquivAbs (UProd ux) Used -_isEquivAbs x y = x == y +instance Equivalent AbsDmd where + -- U(U ... U) == U + equiv (UProd ux) Used = all (flip equiv Used) ux + equiv Used (UProd ux) = equiv (UProd ux) Used + equiv x y = x == y + + +instance LatticeLike AbsDmd where + bot = Abs + top = Used + + pre Abs _ = True + pre _ Used = True + pre (UProd ux1) (UProd ux2) + | length ux1 == length ux2 = all (== True) $ zipWith pre ux1 ux2 + pre x y = equiv x y + + lub Abs a = a + lub a Abs = a + lub Used _ = top + lub _ Used = top + lub (UProd ux1) (UProd ux2) + | length ux1 == length ux2 = UProd $ zipWith lub ux1 ux2 + lub x y | x == y = x + lub _ _ = top + + both = lub \end{code} +%************************************************************************ +%* * +\subsection{Joint domain for Strictness and Absence} +%* * +%************************************************************************ + +\begin{code} + +type Joint = (StrDmd, AbsDmd) + +instance Equivalent Joint where + equiv (s1, _) (s2, Used) + | equiv s1 s2 && s1 /= s2 = True + equiv (s1, Used) (s2, _) + | equiv s1 s2 && s1 /= s2 = True + equiv (Lazy, UProd _) (Lazy, Used) = True + equiv (Lazy, Used) (Lazy, UProd _) = True + equiv x y = x == y + + +instance LatticeLike Joint where + bot = (bot, bot) + top = (top, top) + + pre x _ | equiv x bot = True + pre _ x | equiv x top = True + pre (s1, a1) (s2, a2) = (pre s1 s2) && (pre a1 a2) + + lub (s1, a1) (s2, a2) = (lub s1 s2, lub a1 a2) + both (s1, a1) (s2, a2) = (both s1 s2, both a1 a2) + +\end{code} \ No newline at end of file _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
