[commit: ghc] new-demand: join domain implemented and tested (903a1a9)
Ilya Sergey
ilya at galois.com
Tue Jul 10 22:53:05 CEST 2012
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 <Ilya.Sergey at cs.kuleuven.be>
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
More information about the Cvs-ghc
mailing list