explicit-sharing 0.7 → 0.8

raw patch · 8 files changed

+249/−19 lines, 8 filesdep ~derivedep ~mtldep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: derive, mtl, template-haskell

API changes (from Hackage documentation)

Files

• Control/Monad/Sharing.hs +1/−1
• Control/Monad/Sharing/Classes.hs +48/−0
• Control/Monad/Sharing/Implementation/CPS.hs +8/−2
• Data/Monadic/Derive.hs +15/−11
• explicit-sharing.cabal +5/−5
• last.hs +57/−0
• permsort.hs +66/−0
• reverse.hs +49/−0

@@ -18,7 +18,7 @@    -- * Monad transformer -  Lazy, evalLazy+  Lazy, evalLazy, runSharing   ) where 

@@ -61,6 +61,18 @@  where   shareArgs _ = return +instance Monad m => Shareable m Integer+ where+  shareArgs _ = return++instance Monad m => Shareable m Float+ where+  shareArgs _ = return++instance Monad m => Shareable m Double+ where+  shareArgs _ = return+ instance Monad m => Shareable m Char  where   shareArgs _ = return@@ -73,6 +85,18 @@  where   shareArgs _ = return +instance Monad m => Shareable m [Integer]+ where+  shareArgs _ = return++instance Monad m => Shareable m [Float]+ where+  shareArgs _ = return++instance Monad m => Shareable m [Double]+ where+  shareArgs _ = return+ instance Monad m => Shareable m [Char]  where   shareArgs _ = return@@ -108,6 +132,18 @@  where   convert = return +instance Monad m => Convertible m Integer Integer+ where+  convert = return++instance Monad m => Convertible m Float Float+ where+  convert = return++instance Monad m => Convertible m Double Double+ where+  convert = return+ instance Monad m => Convertible m Char Char  where   convert = return@@ -117,6 +153,18 @@   convert = return  instance Monad m => Convertible m [Int] [Int]+ where+  convert = return++instance Monad m => Convertible m [Integer] [Integer]+ where+  convert = return++instance Monad m => Convertible m [Float] [Float]+ where+  convert = return++instance Monad m => Convertible m [Double] [Double]  where   convert = return 

@@ -19,7 +19,7 @@ -- performance. module Control.Monad.Sharing.Implementation.CPS ( -  Lazy, evalLazy, runLazy,+  Lazy, runLazy, evalLazy, runSharing,    Store, emptyStore, freshLabel, lookupValue, storeValue, @@ -52,17 +52,23 @@   fromLazy :: forall w . (a -> Store -> m w) -> Store -> m w  } +runSharing :: MonadPlus m => (forall s.(MonadPlus s,Sharing s) => s a) -> m a+runSharing a = runLazy a+ -- | -- Lifts all monadic effects to the top-level and unwraps the monad -- transformer for explicit sharing. evalLazy :: (Monad m, Convertible (Lazy m) a b) => Lazy m a -> m b evalLazy m = runLazy (m >>= convert)+{-# DEPRECATED evalLazy "Please use runSharing instead" #-}  -- private declarations  runLazy :: Monad m => Lazy m a -> m a runLazy m = fromLazy m (\a _ -> return a) emptyStore-  -- fromLazy m (\a s -> trace (show (nextLabel s)) (return a)) emptyStore+--   fromLazy m+--     (\a s -> trace ("used refs: "++show (nextLabel s-1)) (return a))+--     emptyStore  -- Stores consist of a fresh-reference counter and a heap represented -- as IntMap.

@@ -8,11 +8,15 @@ -- Automatic deriving of monadic data types and corresponding instances. module Data.Monadic.Derive ( -  monadic, makeMData, makeShareable, makeConvertible+  derive, +  monadic, mdata, shareable, convertible+   ) where  import Language.Haskell++import Data.DeriveTH ( derive ) import Data.Derive.Internal.Derivation  import Control.Monad.Error@@ -48,7 +52,7 @@ -- > $(derive monadic ''Maybe) --  monadic :: Derivation-monadic = derivationCustom "Monadic"+monadic = derivationCustom "monadic"             (\ (_,d) -> concat <$> mapM ($d) [convData,shareableInst,convInsts])  -- | Generates a monadic datatype and corresponding con- and@@ -60,7 +64,7 @@ --  --   can be translated into its monadic counterpart by typing -- --- > $(derive makeMData ''Maybe)+-- > $(derive mdata ''Maybe) --  --   This call generates the following datatype -- @@ -78,14 +82,14 @@ -- > matchMMaybe :: Monad m => m (MMaybe m a) -> m b -> (m a -> m b) -> m b -- > matchMMaybe x n j = x >>= \x -> case x of { MNothing -> n; MJust a -> j a } -- -makeMData :: Derivation-makeMData = derivationCustom "MData" (convData . snd)+mdata :: Derivation+mdata = derivationCustom "mdata" (convData . snd)  -- | Generates a 'Shareable' instance for a monadic datatype. --  --   For example the call -- --- > $(derive makeShareable ''Maybe)+-- > $(derive shareable ''Maybe) --  --   generates the following instance: -- @@ -93,15 +97,15 @@ -- >   shareArgs fun MNothing  = return MNothing -- >   shareArgs fun (MJust a) = fun a >>= \a -> mJust a -- -makeShareable :: Derivation-makeShareable = derivationCustom "Shareable" (shareableInst . snd)+shareable :: Derivation+shareable = derivationCustom "shareable" (shareableInst . snd)  -- | Generates 'Convertible' instances to convert between monadic and --   non-monadic datatypes. --  --   For example, the call -- --- > $(derive makeConvertible ''Maybe)+-- > $(derive convertible ''Maybe) --  --   generates the following instances: -- @@ -115,8 +119,8 @@ -- >   convArgs fun MNothing  = return Nothing -- >   convArgs fun (MJust a) = (a >>= fun) >>= \a -> return (Just a) -- -makeConvertible :: Derivation-makeConvertible = derivationCustom "Convertible" (convInsts . snd)+convertible :: Derivation+convertible = derivationCustom "convertible" (convInsts . snd)  -- printDecls (Left s) = Left s -- printDecls (Right ds) = trace (unlines . map prettyPrint $ ds) (Right ds)

@@ -1,5 +1,5 @@ Name:          explicit-sharing-Version:       0.7+Version:       0.8 Cabal-Version: >= 1.6 Synopsis:      Explicit Sharing of Monadic Effects Description:   @@ -17,12 +17,12 @@ Build-Type:    Custom Stability:     experimental -Extra-Source-Files: Test.hs+Extra-Source-Files: Test.hs, permsort.hs, reverse.hs, last.hs  Library-  Build-Depends:    base >= 3 && < 5, containers, mtl,-                    template-haskell >= 2.4 && < 2.5,-                    derive >= 2.3.0.1 && < 2.4+  Build-Depends:    base >= 3 && < 5, containers, mtl < 2,+                    template-haskell >= 2.4 && < 2.6,+                    derive >= 2.3.0.1 && < 2.5   Exposed-Modules:  Control.Monad.Sharing,                     Control.Monad.Sharing.Classes,                     Control.Monad.Sharing.FirstOrder,

@@ -0,0 +1,57 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++-- to compile, run:+-- ghc -O2 --make last++-- $ time ./last 1000000 +RTS -H1000M -K20M+-- True+-- user	0m1.154s++-- $ time ./last 10000000 +RTS -H1000M -K20M+-- True+-- user	0m9.263s++-- $ time ./last.mcc 1000000 +RTS -h1000m -k20m+-- 1000000+-- user	0m6.370s++-- $ time ./last.mcc 10000000 +RTS -h2000m -k50m+-- Not enough free memory after garbage collection++import Control.Monad.Sharing+import Data.Monadic.List+import System ( getArgs )++import Prelude hiding ( last )++main =+ do n <- liftM (read.head) getArgs+    let result = runSharing(last(convert(replicate n True))>>=convert)::[Bool]+    mapM_ print result++last :: (MonadPlus m, Sharing m) => m (List m Bool) -> m Bool+last l = do x <- share freeBool+            l =:= append freeBoolList (cons x nil)+            x++append :: Monad m => m (List m a) -> m (List m a) -> m (List m a)+append mxs ys = do xs <- mxs; appendLists xs ys++appendLists :: Monad m => List m a -> m (List m a) -> m (List m a)+appendLists Nil         ys = ys+appendLists (Cons x xs) ys = cons x (append xs ys)++freeBool :: MonadPlus m => m Bool+freeBool = return False `mplus` return True++freeBoolList :: MonadPlus m => m (List m Bool)+freeBoolList = nil `mplus` cons freeBool freeBoolList++(=:=) :: MonadPlus m => m (List m Bool) -> m (List m Bool) -> m ()+mxs =:= mys = do xs <- mxs; ys <- mys; eqBoolList xs ys++eqBoolList :: MonadPlus m => List m Bool -> List m Bool -> m ()+eqBoolList Nil         Nil         = return ()+eqBoolList (Cons x xs) (Cons y ys) = do True <- liftM2 (==) x y+                                        xs =:= ys+eqBoolList _           _           = mzero

@@ -0,0 +1,66 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++-- to compile, run:+-- ghc -O2 --make permsort.hs++-- $ time ./permsort 20+-- user	0m8.909s++-- time ./permsort.mcc 20+-- user	0m25.067s++-- Comparing different implementations using GHC 6.12.1++-- standard StateT with unevaluated thunks in store+-- user	1m41.645s++-- continition monad with unevaluated thunks in store+-- user	0m37.073s++-- continuation monad with fewer store operations+-- user	0m29.517s++-- additionally with hand optimized memo function+-- user	0m8.909s+++import Control.Monad.Sharing+import Data.Monadic.List++import System ( getArgs )++main = do+  n <- liftM (read.head) getArgs+  let result = runSharing (sort (convert [(1::Int)..n]) >>= convert) :: [[Int]]+  mapM_ print result++++perm :: MonadPlus m => List m a -> m (List m a)+perm Nil         = nil+perm (Cons x xs) = insert x (perm =<< xs)++insert :: MonadPlus m => m a -> m (List m a) -> m (List m a)+insert e l = cons e l+     `mplus` do+        Cons x xs <- l+        cons x (insert e xs)++sort :: (MonadPlus m, Sharing m) => m (List m Int) -> m (List m Int)+sort l = do+  xs <- share (perm =<< l)+  True <- isSorted =<< xs+  xs++isSorted :: Monad m => List m Int -> m Bool+isSorted Nil           = return True+isSorted (Cons mx mxs) = isSorted' mx =<< mxs++isSorted' :: Monad m => m Int -> List m Int -> m Bool+isSorted' _  Nil           = return True+isSorted' mx (Cons my mys) = do+  x <- mx+  y <- my+  if x <= y+   then isSorted' (return y) =<< mys+   else return False

@@ -0,0 +1,49 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++-- naive reverse to compare performance of purely functional programs+-- with monadic deterministic programs.++-- to compile, run:+-- ghc -O2 -o reverse.mon --make reverse.hs++-- $ time ./reverse.fun 20000+-- user	0m8.804s++-- $ time ./reverse.mon 20000+-- user	0m10.522s++-- $ time ./reverse.mcc 20000+-- user	0m14.530s+++import Control.Monad.Sharing+import Data.Monadic.List++import System ( getArgs )++main = main_mon++main_fun =+ do n <- liftM (read.head) getArgs+    print . length . rev $ [1..n]++rev []     = []+rev (x:xs) = rev xs ++ [x]++main_mon =+ do n <- liftM (read.head) getArgs+    let result =+          runSharing(convert=<<(length'=<<rev'=<<convert[(1::Int)..n]))::[Int]+    mapM_ print result++length' :: Monad m => List m a -> m Int+length' Nil         = return 0+length' (Cons _ xs) = liftM succ (length' =<< xs)++rev' :: Monad m => List m Int -> m (List m Int)+rev' Nil         = nil+rev' (Cons x xs) = (`append`cons x nil) =<< rev' =<< xs++append :: Monad m => List m a -> m (List m a) -> m (List m a)+append Nil         ys = ys+append (Cons x xs) ys = cons x (xs >>= (`append`ys))