Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/2962fe282f7740cfa10918b3724510ba6c588fab >--------------------------------------------------------------- commit 2962fe282f7740cfa10918b3724510ba6c588fab Author: Ilya Sergey <[email protected]> Date: Wed Jul 4 11:58:52 2012 +0100 strictness and absence domains implemented >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 2 +- compiler/basicTypes/NewDemand.lhs | 115 +++++++++++++++++++++++++++++++++++++ compiler/ghc.cabal.in | 1 + 3 files changed, 117 insertions(+), 1 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index bd3638a..7d6a093 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -269,7 +269,7 @@ dmdTypeDepth (DmdType _ ds _) = length ds %************************************************************************ %* * -\subsection{Strictness signature +\subsection{Strictness signature} %* * %************************************************************************ diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs new file mode 100644 index 0000000..6c90069 --- /dev/null +++ b/compiler/basicTypes/NewDemand.lhs @@ -0,0 +1,115 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[NewDemand]{@NewDemand@: A decoupled implementation of a demand domain} + +\begin{code} + +module NewDemand ( + ) where + +#include "HsVersions.h" + +\end{code} + +%************************************************************************ +%* * +\subsection{Complete Lattices} +%* * +%************************************************************************ + +\begin{code} + +class Lattice a where + bot :: a + top :: a + pre :: a -> a -> Bool + lub :: a -> a -> a + glb :: a -> a -> a + +\end{code} + + +%************************************************************************ +%* * +\subsection{Strictness domain} +%* * +%************************************************************************ + +\begin{code} + +-- Vanilla strictness domain +data StrDmd + = HyperStr -- Hyperstrict + | Lazy -- Lazy + | Str -- Strict + | StrProd [StrDmd] -- Product or function demand + deriving ( Eq ) + +-- 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 + 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 + +\end{code} + +%************************************************************************ +%* * +\subsection{Absence domain} +%* * +%************************************************************************ + +\begin{code} +data AbsDmd + = Abs -- Defenitely unused + | Used -- May be used + | UProd [AbsDmd] -- Product + deriving ( Eq ) + +-- 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 + +\end{code} + diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 5f873f4..ea3b3dc 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -137,6 +137,7 @@ Library BasicTypes DataCon Demand + NewDemand Exception GhcMonad Id _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
