packages feed

data-fix-cse (empty) → 0.0.1

raw patch · 8 files changed

+406/−0 lines, 8 filesdep +basedep +containersdep +data-fixsetup-changed

Dependencies added: base, containers, data-fix, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Kholomiov 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Anton Kholomiov nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ data-fix-cse.cabal view
@@ -0,0 +1,37 @@+Name:            data-fix-cse+Version:         0.0.1+Cabal-Version:   >= 1.6+License:         BSD3+License-file:    LICENSE+Author:          Anton Kholomiov, Oleg Kiselyov+Maintainer:      <anton.kholomiov@gmail.com>+Category:        Data+Synopsis:        Common subexpression elimination for the fixploint types.   +Build-Type:      Simple+Description:     +  Common subexpression elimination for the fixploint types.   ++Stability:       Experimental++Extra-Source-Files:+    test/Exp.hs+    test/Impl.hs+    test/Expl.hs++Homepage:        https://github.com/anton-k/data-fix-cse+Bug-Reports:     https://github.com/anton-k/data-fix-cse/issues++Source-repository head+    Type: git+    Location: https://github.com/anton-k/data-fix-cse++Library+  Build-depends: base >= 4, base < 5, data-fix, transformers, containers+  Hs-source-dirs: src/++  ghc-options: -Wall++  Exposed-Modules: +      Data.Fix.Cse+  Other-Modules:  +      Data.Fix.BiMap
+ src/Data/Fix/BiMap.hs view
@@ -0,0 +1,57 @@+-- Establishing a bijection between the values of the type a and integers, with+-- the operations to retrieve the value given its key,+-- to find the key for the existing value, and to extend the +-- bijection with a new association.++-- The type 'a' of values should at least permit equality comparison;+-- In the present implementation, we require 'a' to be a member+-- of Ord.++-- There are many ways to implement bi-maps, for example, using hash tables,+-- or maps.+-- Our implementation uses Data.Map and Data.IntMap to record+-- both parts of the association.++module Data.Fix.BiMap (+	      BiMap, empty, getDag,+	      lookup_key, +	      lookup_val, +	      insert,+	      size,+	     )+    where++import qualified Data.Map    as M+import qualified Data.IntMap as IM++data BiMap a = BiMap (M.Map a Int) (IM.IntMap a)++getDag :: BiMap a -> IM.IntMap a+getDag (BiMap _ a) = a++-- Find a key for a value+lookup_key :: Ord a => a -> BiMap a -> Maybe Int+lookup_key v (BiMap m _) = M.lookup v m++-- Find a value for a key+lookup_val :: Int -> BiMap a -> a+lookup_val k (BiMap _ m) = m IM.! k++-- Insert the value and return the corresponding key+-- and the new map+-- Alas, Map interface does not have an operation to insert and find the index +-- at the same time (although such an operation is easily possible)+insert :: Ord a => a -> BiMap a -> (Int, BiMap a)+insert v (BiMap m im) = (k, BiMap m' im')+ where m'  = M.insert v k m+       im' = IM.insert k v im+       k   = IM.size im++empty :: BiMap a+empty = BiMap (M.empty) (IM.empty)++instance Show a => Show (BiMap a) where+    show (BiMap _ m) =  "BiMap" ++ show (IM.toList m)++size :: BiMap a -> Int+size (BiMap _ m) = IM.size m
+ src/Data/Fix/Cse.hs view
@@ -0,0 +1,106 @@+-- | Implements common subexpression elimination (CSE) with hashconsig algorithm as described in+-- the paper 'Implementing Explicit and Finding Implicit Sharing in EDSLs' by Oleg Kiselyov. +-- You can define your datatype as a fixpoint type. Then the only thing you need to perform CSE+-- is to define an instance of the class 'Traversable' for your datatype.+module Data.Fix.Cse (+    VarName, Dag, fromDag,+    -- * Implicit sharing+    cse,++    -- * Explicit sharing+    letCse, Let(..),+    letCata, letCataM,+    letWrapper+) where++import Control.Applicative hiding (empty)++import Data.Fix+import Control.Monad.Trans.State.Strict+import qualified Data.IntMap as IM+import Data.Traversable+import Control.Monad.Trans.Class(lift)++import Data.Fix.BiMap++type VarName = Int++-- | Directed acyclic graphs.+type Dag f = IM.IntMap (f VarName)++-- | If plain lists are enough for your case. +fromDag :: Dag f -> [(VarName, f VarName)]+fromDag = IM.toList++-- | Performs common subexpression elimination with implicit sharing.  +cse :: (Eq (f Int), Ord (f Int), Traversable f) => Fix f -> Dag f+cse x = getDag $ execState (cataM hashcons x) empty+++-- | With explicit sharing you provide user with the special function that+-- encodes let-bindings for your EDSL ('LetBind'). You should not use 'LetLift' case.+-- It's reserverd for the CSE algorithm. +data Let f a+    = LetExp (f a)+    | LetBind a (a -> a)+    | LetLift VarName++-- | Helper function to make explicit let-bindings.+-- For exampe:+--+-- > newtype T = T { unT :: Fix (Let f) }+-- > +-- > let_ :: T -> (T -> T) -> T+-- > let_ = letWrapper T unT+letWrapper :: (Fix (Let f) -> a) -> (a -> Fix (Let f)) -> a -> (a -> a) -> a+letWrapper to from a e = to $ Fix $ LetBind (from a) (from . e . to)++-- | Performs common subexpression elimination with explicit sharing.  +-- To make sharing explicit you can use the datatype 'Let'.+letCse :: (Eq (f Int), Ord (f Int), Traversable f)+   => Fix (Let f) -> Dag f+letCse x = getDag $ execState (letCataM hashcons x) empty++-- | Monadic catamorphism for fixpoint types wrapped in the type 'Let'.+letCataM :: (Applicative m, Monad m, Traversable f) =>+   (f a -> m a) -> Fix (Let f) -> m a+letCataM m expr = evalStateT (go expr) IM.empty+   where go    = phi . unFix+         phi x = case x of+                   LetLift var -> do+                                  s <- get+                                  return ((IM.!) s var)+                   LetExp a    -> (lift . m) =<< traverse go a+                   LetBind a e -> do+                                  v <- go a+                                  s <- get+                                  let var = IM.size s+                                  let s' = IM.insert var v s+                                  put s'+                                  go . e . Fix . LetLift $ var++-- | Catamorphism for fixpoint types wrapped in the type 'Let'.+letCata :: (Functor f, Traversable f) =>+   (f a -> a) -> Fix (Let f) -> a+letCata f expr = evalState (go expr) IM.empty+   where go    = phi . unFix+         phi x = case x of+                   LetLift var -> do+                                  s <- get+                                  return ((IM.!) s var)+                   LetExp a    -> traverse go a >>= return . f+                   LetBind a e -> do+                                  v <- go a+                                  s <- get+                                  let var = IM.size s+                                  let s' = IM.insert var v s+                                  put s'+                                  go . e . Fix . LetLift $ var++hashcons :: (Ord a) => a -> State (BiMap a) Int+hashcons e = do+  m <- get+  case lookup_key e m of+    Nothing -> let (k,m') = insert e m+               in  put m' >> return k+    Just k  -> return k
+ test/Exp.hs view
@@ -0,0 +1,47 @@+module Exp where++import Control.Applicative hiding (Const)+import Data.Monoid+import Data.Traversable+import Data.Foldable++data Exp a +    = Var String+    | Const Int+    | Add a a+    deriving (Show, Eq, Ord)++instance Functor Exp where+    fmap f x = case x of+        Var str     -> Var str+        Const n     -> Const n+        Add a b     -> Add (f a) (f b)++instance Foldable Exp where+    foldMap f x = case x of+        Add a b     -> f a <> f b+        _           -> mempty++instance Traversable Exp where+    traverse f x = case x of+        Var str     -> pure $ Var str+        Const n     -> pure $ Const n+        Add a b     -> Add <$> f a <*> f b++-----------------------------------------------+-- interpreters++-- ignore variables+expAsInt :: Exp Int -> Int+expAsInt x = case x of+    Var str     -> error "boom" +    Const n     -> n+    Add a b     -> a + b++expAsDepth :: Exp Int -> Int+expAsDepth x = case x of+    Add a b     -> 1 + max a b+    _           -> 1+++
+ test/Expl.hs view
@@ -0,0 +1,64 @@+-- | Explicit sharing+module Main where++import Data.Fix+import Data.Fix.Cse++import Exp++newtype T = T { unT :: Fix (Let Exp) }+   +instance Num T where+    (+) a b = T $ Fix $ LetExp $ Add (unT a) (unT b)+    fromInteger = T . Fix . LetExp . Const . fromInteger++    (*) = undefined+    negate = undefined+    abs = undefined+    signum = undefined+++var :: String -> T+var = T . Fix . LetExp . Var++x = var "x"+y = var "y"+z = var "z"+++let_ :: T -> (T -> T) -> T+let_ = letWrapper T unT++mulT :: Int -> T -> T+mulT 0 _ = 0+mulT 1 x = x+mulT n x+    | n `mod` 2 == 0    = let_ (x + x) $ \y -> mulT (n `div` 2) y+    | otherwise         = mulT (n - 1) x + x ++-- interpreters++asInt :: T -> Int+asInt = letCata expAsInt . unT++asDepth :: T -> Int+asDepth = letCata expAsDepth . unT++exec :: T -> Int+exec = length . fromDag . letCse . unT++-----------------------------------------------+-- expression++expr = mulT (2^30) 2++main = do+    print $ exec expr+    putStrLn "" +    putStr "value: "+    print $ asInt expr+    putStrLn ""+    putStr "depth: "+    print $ asDepth expr++
+ test/Impl.hs view
@@ -0,0 +1,62 @@+-- | Implicit sharing+module Main where++import Data.Monoid+import Control.Applicative hiding (Const)++import Data.Fix+import Data.Fix.Cse++import Exp++-----------------------------------------------+-- implicit sharing++newtype T = T { unT :: Fix Exp }+    deriving (Show, Eq)++   +instance Num T where+    (+) a b = T $ Fix $ Add (unT a) (unT b)+    fromInteger = T . Fix . Const . fromInteger++    (*) = undefined+    negate = undefined+    abs = undefined+    signum = undefined++var :: String -> T+var = T . Fix . Var++x = var "x"+y = var "y"+z = var "z"+++mulT :: Int -> T -> T+mulT 0 _ = 0+mulT 1 x = x+mulT n x+    | n `mod` 2 == 0    = mulT (n `div` 2) (x + x)+    | otherwise         = mulT (n - 1) x + x ++-- interpreters++asInt :: T -> Int+asInt = cata expAsInt . unT++asDepth :: T -> Int+asDepth = cata expAsDepth . unT++exec :: T -> Dag Exp+exec = cse . unT++-----------------------------------------------+-- expression++expr = mulT (2^20) 2++main = do+    putStrLn $ show $ length $ fromDag $ exec expr++