Permalink
Fetching contributors…
Cannot retrieve contributors at this time
111 lines (91 sloc) 2.51 KB
{-# LANGUAGE TemplateHaskell
, KindSignatures
, MultiParamTypeClasses
, FlexibleInstances #-}
-- demonstrates store blowup due to repeated sharing
import System ( getArgs )
import Data.Monadic.Derive
import Control.Monad.Sharing
data Bin = Tip | Bin Bin Bin -- ; $(derive monadic ''Bin)
-- exponential store blowup with derived monadic data:
--
-- # for n in `gseq 1 10`; do ./repeated-sharing $n; done
-- used refs: 1
-- 3
-- used refs: 4
-- 7
-- used refs: 11
-- 15
-- used refs: 26
-- 31
-- used refs: 57
-- 63
-- used refs: 120
-- 127
-- used refs: 247
-- 255
-- used refs: 502
-- 511
-- used refs: 1013
-- 1023
-- used refs: 2036
-- 2047
main = print . test . read . head =<< getArgs
test :: Int -> Int
test = head . evalLazy . size . complete
complete :: (Monad m, Sharing m) => Int -> m (MBin m)
complete 0 = mTip
complete (n+1) = do t <- share (complete n)
mBin t t
size :: Monad m => m (MBin m) -> m Int
size t = matchMBin t (return 1)
(\l r -> do m <- size l
n <- size r
return (m+n+1))
-- custom monadic data with 'arguments are already shared' flag:
data MBin m = MTip | MBin Bool (m (MBin m)) (m (MBin m))
mTip :: Monad m => m (MBin m)
mTip = return MTip
mBin :: Monad m => m (MBin m) -> m (MBin m) -> m (MBin m)
mBin l r = return (MBin False l r)
matchMBin :: Monad m => m (MBin m)
-> m a -> (m (MBin m) -> m (MBin m) -> m a)
-> m a
matchMBin mbin tip bin = do t <- mbin
case t of
MTip -> tip
MBin _ l r -> bin l r
instance Monad m => Shareable m (MBin m) where
shareArgs _ MTip = return MTip
shareArgs f (MBin isShared l r)
| isShared = return (MBin isShared l r)
| otherwise = do x <- f l; y <- f r; return (MBin True x y)
instance Monad m => Convertible m Bin (MBin m) where
convert Tip = mTip
convert (Bin l r) = mBin (convert l) (convert r)
instance Monad m => Convertible m (MBin m) Bin where
convert MTip = return Tip
convert (MBin _ l r) = do x <- l >>= convert
y <- r >>= convert
return (Bin x y)
-- # for n in `gseq 1 10`; do ./repeated-sharing $n; done
-- used refs: 1
-- 3
-- used refs: 4
-- 7
-- used refs: 7
-- 15
-- used refs: 10
-- 31
-- used refs: 13
-- 63
-- used refs: 16
-- 127
-- used refs: 19
-- 255
-- used refs: 22
-- 511
-- used refs: 25
-- 1023
-- used refs: 28
-- 2047