[commit: ghc] new-demand: strictness and absence domains implemented (2962fe2)

[Ilya Sergey]

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 <Ilya.Sergey at cs.kuleuven.be>
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