├── .gitignore ├── Compiler ├── Disjoint.hs ├── Lock.hs ├── Lock │ └── Shared.hs ├── Primitive.hs ├── Prop.hs ├── STM.hs ├── STM │ └── Chan.hs └── Sharing.hs ├── LICENSE ├── Setup.hs ├── compiler.cabal └── tests └── doctests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | wip 2 | dist 3 | -------------------------------------------------------------------------------- /Compiler/Disjoint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Compiler.Disjoint where 6 | 7 | import Control.Monad (unless) 8 | import Control.Monad.Primitive 9 | import Control.Monad.ST 10 | import Data.Primitive.MutVar 11 | 12 | -- | disjoint set with a monoidal annotation 13 | data Disjoint s a = Disjoint !(MutVar s (Either a (Disjoint s a))) !(MutVar s Int) 14 | 15 | -- | NB: this should be used on the result of 'find' rather than in general. 16 | instance Eq (Disjoint s a) where 17 | Disjoint m _ == Disjoint n _ = m == n 18 | 19 | findValue :: forall m a. (PrimMonad m, Monoid a) => Disjoint (PrimState m) a -> m (Disjoint (PrimState m) a, a) 20 | findValue k0 = stToPrim (go k0) where 21 | -- now notify listeners 22 | go :: Disjoint (PrimState m) a -> ST (PrimState m) (Disjoint (PrimState m) a, a) 23 | go k@(Disjoint v _) = readMutVar v >>= \case 24 | Left a -> return (k, a) 25 | Right k' -> do 26 | (k'', a) <- findValue k' 27 | writeMutVar v (Right k'') 28 | return (k'', a) 29 | 30 | find :: forall m a. (PrimMonad m, Monoid a) => Disjoint (PrimState m) a -> m (Disjoint (PrimState m) a) 31 | find k0 = stToPrim (go k0) where 32 | go :: Disjoint (PrimState m) a -> ST (PrimState m) (Disjoint (PrimState m) a) 33 | go k@(Disjoint v _) = readMutVar v >>= \case 34 | Left _ -> return k 35 | Right k' -> do 36 | k'' <- find k' 37 | writeMutVar v (Right k'') 38 | return k'' 39 | 40 | value :: (PrimMonad m, Monoid a) => Disjoint (PrimState m) a -> m a 41 | value k = stToPrim $ snd <$> findValue k 42 | 43 | -- | union-by-rank 44 | union :: (PrimMonad m, Monoid a) => Disjoint (PrimState m) a -> Disjoint (PrimState m) a -> m () 45 | union o1 o2 = stToPrim $ do 46 | (d1@(Disjoint v1 vr1), a) <- findValue o1 47 | (d2@(Disjoint v2 vr2), b) <- findValue o2 48 | unless (v1 == v2) $ do 49 | let !c = mappend a b 50 | r1 <- readMutVar vr1 51 | r2 <- readMutVar vr2 52 | case compare r1 r2 of 53 | LT -> do 54 | writeMutVar v1 (Left c) 55 | writeMutVar v2 (Right d1) 56 | EQ -> do 57 | writeMutVar vr1 (r1 + 1) 58 | writeMutVar v1 (Left c) 59 | writeMutVar v2 (Right d1) 60 | GT -> do 61 | writeMutVar v1 (Right d2) 62 | writeMutVar v2 (Left c) 63 | 64 | singleton :: PrimMonad m => a -> m (Disjoint (PrimState m) a) 65 | singleton a = stToPrim $ Disjoint <$> newMutVar (Left a) <*> newMutVar 0 66 | -------------------------------------------------------------------------------- /Compiler/Lock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Compiler.Lock 3 | ( Lock 4 | , newLock, newAcquiredLock 5 | , acquireLock, tryAcquireLock 6 | , releaseLock 7 | , withLock, tryWithLock 8 | , waitLock 9 | , unsafeIsUnlockedLock 10 | ) where 11 | 12 | import Control.Concurrent.MVar 13 | import Control.Monad.Catch 14 | import Control.Monad (unless) 15 | import Control.Monad.IO.Class 16 | import Data.Maybe (isJust) 17 | import Data.Typeable 18 | 19 | newtype Lock = Lock (MVar ()) 20 | deriving (Eq,Typeable) 21 | 22 | newLock :: MonadIO m => m Lock 23 | newLock = liftIO $ Lock <$> newMVar () 24 | {-# INLINE newLock #-} 25 | 26 | newAcquiredLock :: MonadIO m => m Lock 27 | newAcquiredLock = liftIO $ Lock <$> newEmptyMVar 28 | {-# INLINE newAcquiredLock #-} 29 | 30 | acquireLock :: MonadIO m => Lock -> m () 31 | acquireLock (Lock m) = liftIO $ takeMVar m 32 | {-# INLINE acquireLock #-} 33 | 34 | tryAcquireLock :: MonadIO m => Lock -> m Bool 35 | tryAcquireLock (Lock m) = liftIO $ isJust <$> tryTakeMVar m 36 | {-# INLINE tryAcquireLock #-} 37 | 38 | releaseLock :: MonadIO m => Lock -> m () 39 | releaseLock (Lock m) = liftIO $ do 40 | b <- tryPutMVar m () 41 | unless b $ fail "releasing unlocked lock" 42 | {-# INLINE releaseLock #-} 43 | 44 | withLock :: (MonadIO m, MonadMask m) => Lock -> m a -> m a 45 | withLock = bracket_ <$> acquireLock <*> releaseLock 46 | {-# INLINE withLock #-} 47 | 48 | tryWithLock :: (MonadIO m, MonadMask m) => Lock -> m a -> m (Maybe a) 49 | tryWithLock l a = mask $ \restore -> tryAcquireLock l >>= \ case 50 | False -> return Nothing 51 | True -> do 52 | r <- restore a `onException` releaseLock l 53 | releaseLock l 54 | return (Just r) 55 | {-# INLINE tryWithLock #-} 56 | 57 | waitLock :: MonadIO m => Lock -> m () 58 | waitLock (Lock m) = liftIO $ mask_ $ takeMVar m >> putMVar m () 59 | {-# INLINE waitLock #-} 60 | 61 | unsafeIsUnlockedLock :: MonadIO m => Lock -> m Bool 62 | unsafeIsUnlockedLock (Lock m) = liftIO $ isEmptyMVar m 63 | {-# INLINE unsafeIsUnlockedLock #-} 64 | -------------------------------------------------------------------------------- /Compiler/Lock/Shared.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 3 | module Compiler.Lock.Shared 4 | ( SharedLock 5 | , newSharedLock, newAcquiredReading, newAcquiredWriting 6 | , acquireReading, tryAcquireReading, releaseReading, withReading, tryWithReading, waitReading 7 | , acquireWriting, tryAcquireWriting, releaseWriting, withWriting, tryWithWriting, waitWriting 8 | -- * unsafe state access 9 | , SharedLockState(..) 10 | , unsafeSharedLockState 11 | ) where 12 | 13 | import Compiler.Lock 14 | import Control.Concurrent.MVar 15 | import Control.Monad.Catch 16 | import Control.Monad.IO.Class 17 | import Data.Data 18 | import GHC.Generics 19 | 20 | data SharedLockState = Free | Reading {-# UNPACK #-} !Int | Writing 21 | deriving (Eq,Ord,Show,Read,Typeable,Data,Generic) 22 | 23 | -- | A multiple-reader single-writer lock 24 | data SharedLock = SharedLock {-# UNPACK #-} !(MVar SharedLockState) {-# UNPACK #-} !Lock {-# UNPACK #-} !Lock 25 | deriving (Typeable) 26 | 27 | instance Eq SharedLock where 28 | SharedLock s _ _ == SharedLock s' _ _ = s == s' 29 | 30 | newSharedLock :: MonadIO m => m SharedLock 31 | newSharedLock = liftIO $ SharedLock <$> newMVar Free <*> newLock <*> newLock 32 | {-# INLINE newSharedLock #-} 33 | 34 | newAcquiredReading :: MonadIO m => m SharedLock 35 | newAcquiredReading = liftIO $ SharedLock <$> newMVar (Reading 1) <*> newAcquiredLock <*> newLock 36 | {-# INLINE newAcquiredReading #-} 37 | 38 | newAcquiredWriting :: MonadIO m => m SharedLock 39 | newAcquiredWriting = liftIO $ SharedLock <$> newMVar Writing <*> newLock <*> newAcquiredLock 40 | {-# INLINE newAcquiredWriting #-} 41 | 42 | acquireReading :: MonadIO m => SharedLock -> m () 43 | acquireReading (SharedLock s r w) = liftIO $ mask_ go where 44 | go = takeMVar s >>= \case 45 | Free -> do 46 | acquireLock r 47 | putMVar s $ Reading 1 48 | Reading n -> putMVar s $! Reading (n + 1) 49 | Writing -> do 50 | putMVar s Writing 51 | waitLock w 52 | go 53 | {-# INLINE acquireReading #-} 54 | 55 | tryAcquireReading :: MonadIO m => SharedLock -> m Bool 56 | tryAcquireReading (SharedLock s r _) = liftIO $ mask_ $ takeMVar s >>= \case 57 | Free -> do 58 | acquireLock r 59 | putMVar s (Reading 1) 60 | return True 61 | Reading n -> do 62 | putMVar s $! Reading (n+1) 63 | return True 64 | Writing -> False <$ putMVar s Writing 65 | {-# INLINE tryAcquireReading #-} 66 | 67 | releaseReading :: MonadIO m => SharedLock -> m () 68 | releaseReading (SharedLock s r _) = liftIO $ mask_ $ takeMVar s >>= \case 69 | Reading 1 -> do 70 | releaseLock r 71 | putMVar s Free 72 | Reading n -> putMVar s $ Reading (n-1) 73 | old -> do 74 | putMVar s old 75 | fail "releasing unacquired read lock" 76 | {-# INLINE releaseReading #-} 77 | 78 | withReading :: (MonadIO m, MonadMask m) => SharedLock -> m a -> m a 79 | withReading = bracket_ <$> acquireReading <*> releaseReading 80 | {-# INLINE withReading #-} 81 | 82 | tryWithReading :: (MonadIO m, MonadMask m) => SharedLock -> m a -> m (Maybe a) 83 | tryWithReading l a = mask $ \restore -> tryAcquireReading l >>= \case 84 | False -> return Nothing 85 | True -> do 86 | r <- restore a `onException` releaseReading l 87 | releaseReading l 88 | return (Just r) 89 | {-# INLINE tryWithReading #-} 90 | 91 | waitReading :: MonadIO m => SharedLock -> m () 92 | waitReading l = liftIO $ mask_ $ acquireReading l >> releaseReading l 93 | {-# INLINE waitReading #-} 94 | 95 | acquireWriting :: MonadIO m => SharedLock -> m () 96 | acquireWriting (SharedLock s r w) = liftIO $ mask_ go where 97 | go = takeMVar s >>= \case 98 | Free -> do 99 | acquireLock w 100 | putMVar s Writing 101 | Writing -> do 102 | putMVar s Writing 103 | waitLock w 104 | go 105 | other -> do 106 | putMVar s other 107 | waitLock r 108 | go 109 | {-# INLINE acquireWriting #-} 110 | 111 | tryAcquireWriting :: MonadIO m => SharedLock -> m Bool 112 | tryAcquireWriting (SharedLock s _ w) = liftIO $ mask_ $ takeMVar s >>= \case 113 | Free -> do 114 | acquireLock w 115 | putMVar s Writing 116 | return True 117 | state -> False <$ putMVar s state 118 | {-# INLINE tryAcquireWriting #-} 119 | 120 | releaseWriting :: MonadIO m => SharedLock -> m () 121 | releaseWriting (SharedLock s _ w) = liftIO $ mask_ $ takeMVar s >>= \case 122 | Writing -> do 123 | releaseLock w 124 | putMVar s Free 125 | other -> do 126 | putMVar s other 127 | fail "releasing unacquired write lock" 128 | {-# INLINE releaseWriting #-} 129 | 130 | withWriting :: (MonadIO m, MonadMask m) => SharedLock -> m a -> m a 131 | withWriting = bracket_ <$> acquireWriting <*> releaseWriting 132 | {-# INLINE withWriting #-} 133 | 134 | tryWithWriting :: (MonadIO m, MonadMask m) => SharedLock -> m a -> m (Maybe a) 135 | tryWithWriting l a = mask $ \restore -> tryAcquireWriting l >>= \case 136 | False -> return Nothing 137 | True -> do 138 | r <- restore a `onException` releaseWriting l 139 | releaseWriting l 140 | return (Just r) 141 | {-# INLINE tryWithWriting #-} 142 | 143 | waitWriting :: MonadIO m => SharedLock -> m () 144 | waitWriting l = liftIO $ mask_ $ acquireWriting l >> releaseWriting l 145 | {-# INLINE waitWriting #-} 146 | 147 | unsafeSharedLockState :: MonadIO m => SharedLock -> m SharedLockState 148 | unsafeSharedLockState (SharedLock s _ _) = liftIO $ do 149 | state <- readMVar s 150 | putMVar s state 151 | return state 152 | {-# INLINE unsafeSharedLockState #-} 153 | -------------------------------------------------------------------------------- /Compiler/Primitive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | module Compiler.Primitive 4 | ( casIntArray 5 | ) where 6 | 7 | import Control.Monad.Primitive 8 | import Data.Primitive.ByteArray 9 | import GHC.Int 10 | import GHC.Prim 11 | 12 | casIntArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> Int -> Int -> m Int 13 | casIntArray (MutableByteArray m) (I# i) (I# o) (I# n) = primitive $ \s -> case casIntArray# m i o n s of 14 | (# s', a #) -> (# s', I# a #) 15 | 16 | -------------------------------------------------------------------------------- /Compiler/Prop.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | module Compiler.Prop where 7 | 8 | import Compiler.STM 9 | import Compiler.STM.Chan 10 | import Control.Concurrent.STM 11 | import Control.Monad.Trans.Cont 12 | import Data.Hashable 13 | import Data.IntMap.Strict as IntMap 14 | import Data.Profunctor 15 | import Data.Reflection 16 | import Data.Set as Set 17 | import Data.Typeable 18 | 19 | data NetworkState = NetworkState {-# UNPACK #-} !Int !(IntMap (Set Int)) 20 | newtype Network = Network (TVar NetworkState) 21 | deriving (Eq,Typeable) 22 | 23 | withNetwork :: (forall s. Reifies s Network => Proxy s -> STM r) -> STM r 24 | withNetwork f = do 25 | tv <- newTVar (NetworkState 0 IntMap.empty) 26 | reify (Network tv) f 27 | 28 | data Cell s a b = Cell !Int (a -> STM ()) (STM (RChan b)) 29 | deriving Typeable 30 | 31 | instance Profunctor (Cell s) where 32 | dimap l r (Cell i p g) = Cell i (p . l) (fmap r <$> g) 33 | rmap r (Cell i p g) = Cell i p (fmap r <$> g) 34 | lmap l (Cell i p g) = Cell i (p . l) g 35 | 36 | instance Eq (Cell s a b) where 37 | Cell i _ _ == Cell j _ _ = i == j 38 | 39 | instance Ord (Cell s a b) where 40 | Cell i _ _ `compare` Cell j _ _ = compare i j 41 | 42 | instance Hashable (Cell s a b) where 43 | hashWithSalt s (Cell i _ _) = hashWithSalt s i 44 | 45 | data Prop s = Prop {-# UNPACK #-} !Int !(STM ()) !(STM Bool) 46 | 47 | instance Eq (Prop s) where 48 | Prop i _ _ == Prop j _ _ = i == j 49 | 50 | instance Ord (Prop s) where 51 | Prop i _ _ `compare` Prop j _ _ = compare i j 52 | 53 | instance Hashable (Prop s) where 54 | hashWithSalt s (Prop i _ _) = hashWithSalt s i 55 | 56 | quit :: ContT () STM a 57 | quit = ContT $ \_ -> return () 58 | 59 | cell :: forall m s a b. (MonadSTM m, Reifies s Network) => (a -> ContT () STM b) -> m (Cell s a b) 60 | cell f = stm $ do 61 | let Network tv = reflect (Proxy :: Proxy s) 62 | NetworkState i m <- readTVar tv 63 | writeTVar tv $! NetworkState (i + 1) m 64 | c <- newBroadcastTChan 65 | return $! Cell i (\a -> runContT (f a) (writeTChan c)) (RChan id <$> dupTChan c) 66 | 67 | write :: Cell s a b -> a -> STM () 68 | write (Cell _ cp _) a = cp a 69 | 70 | prop :: forall m s a a' b b'. (MonadSTM m, Reifies s Network) => (RChan a' -> ContT () STM b) -> Cell s a a' -> Cell s b b' -> m (Prop s) 71 | prop f (Cell ci _ cg) (Cell di dp _) = stm $ do 72 | let Network tv = reflect (Proxy :: Proxy s) 73 | NetworkState ip m <- readTVar tv 74 | writeTVar tv $! NetworkState (ip + 1) $ 75 | IntMap.insertWith Set.union ci (Set.singleton ip) $ 76 | IntMap.insert ip (Set.singleton di) m 77 | c' <- cg 78 | return $! Prop ip (runContT (f c') dp) (not <$> isEmptyChan c') 79 | 80 | prop2 :: forall m s a a' b b' c c'. (MonadSTM m, Reifies s Network) => (RChan a' -> RChan b' -> ContT () STM c) -> Cell s a a' -> Cell s b b' -> Cell s c c' -> m (Prop s) 81 | prop2 f (Cell ci _ cg) (Cell di _ dg) (Cell ei ep _) = stm $ do 82 | let Network tv = reflect (Proxy :: Proxy s) 83 | NetworkState ip m <- readTVar tv 84 | writeTVar tv $! NetworkState (ip + 1) $ 85 | IntMap.insertWith Set.union ci (Set.singleton ip) $ 86 | IntMap.insertWith Set.union di (Set.singleton ip) $ 87 | IntMap.insert ip (Set.singleton ei) m 88 | c' <- cg 89 | d' <- dg 90 | return $! Prop ip (runContT (f c' d') ep) $ 91 | isEmptyChan c' >>= \case 92 | False -> return True 93 | True -> not <$> isEmptyChan d' 94 | -------------------------------------------------------------------------------- /Compiler/STM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, TypeFamilies #-} 2 | module Compiler.STM 3 | ( MonadSTM(..) 4 | ) where 5 | 6 | import Control.Concurrent.STM 7 | import Control.Monad.Trans 8 | import Control.Monad.Trans.Cont 9 | import Control.Monad.Trans.Reader 10 | import Control.Monad.Trans.Maybe 11 | import Control.Monad.Trans.RWS.Lazy as Lazy 12 | import Control.Monad.Trans.RWS.Strict as Strict 13 | import Control.Monad.Trans.State.Lazy as Lazy 14 | import Control.Monad.Trans.State.Strict as Strict 15 | import Control.Monad.Trans.Writer.Lazy as Lazy 16 | import Control.Monad.Trans.Writer.Strict as Strict 17 | 18 | class Monad m => MonadSTM m where 19 | stm :: STM a -> m a 20 | default stm :: (m ~ t n, MonadTrans t, MonadSTM n) => STM a -> m a 21 | stm = lift . stm 22 | 23 | instance MonadSTM STM where stm = id 24 | instance MonadSTM m => MonadSTM (MaybeT m) 25 | instance MonadSTM m => MonadSTM (ReaderT e m) 26 | instance (MonadSTM m, Monoid w) => MonadSTM (Strict.RWST r w s m) 27 | instance (MonadSTM m, Monoid w) => MonadSTM (Lazy.RWST r w s m) 28 | instance (MonadSTM m, Monoid w) => MonadSTM (Strict.WriterT w m) 29 | instance (MonadSTM m, Monoid w) => MonadSTM (Lazy.WriterT w m) 30 | instance MonadSTM m => MonadSTM (Strict.StateT s m) 31 | instance MonadSTM m => MonadSTM (Lazy.StateT s m) 32 | instance MonadSTM m => MonadSTM (ContT r m) 33 | -------------------------------------------------------------------------------- /Compiler/STM/Chan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Compiler.STM.Chan 3 | ( WriteChan(..) 4 | , ReadChan(..) 5 | , RChan(..), rchan 6 | ) where 7 | 8 | import Compiler.STM 9 | import Control.Concurrent.STM 10 | 11 | class WriteChan c where 12 | writeChan :: MonadSTM m => c a -> a -> m () 13 | 14 | instance WriteChan TChan where 15 | writeChan c a = stm (writeTChan c a) 16 | 17 | class ReadChan c where 18 | readChan :: MonadSTM m => c a -> m a 19 | tryReadChan :: MonadSTM m => c a -> m (Maybe a) 20 | peekChan :: MonadSTM m => c a -> m a 21 | tryPeekChan :: MonadSTM m => c a -> m (Maybe a) 22 | isEmptyChan :: MonadSTM m => c a -> m Bool 23 | cloneChan :: MonadSTM m => c a -> m (c a) 24 | dupChan :: MonadSTM m => c a -> m (c a) 25 | 26 | instance ReadChan TChan where 27 | readChan = stm . readTChan 28 | tryReadChan = stm . tryReadTChan 29 | peekChan = stm . peekTChan 30 | tryPeekChan = stm . tryPeekTChan 31 | isEmptyChan = stm . isEmptyTChan 32 | cloneChan = stm . cloneChan 33 | dupChan = stm . dupChan 34 | 35 | -- Coyoneda TChan 36 | data RChan a where 37 | RChan :: (x -> a) -> {-# UNPACK #-} !(TChan x) -> RChan a 38 | 39 | rchan :: TChan a -> RChan a 40 | rchan = RChan id 41 | 42 | instance Functor RChan where 43 | fmap f (RChan g tc) = RChan (f . g) tc 44 | a <$ RChan _ tc = RChan (const a) tc 45 | 46 | instance ReadChan RChan where 47 | readChan (RChan f tc) = stm $ f <$> readTChan tc 48 | tryReadChan (RChan f tc) = stm $ fmap f <$> tryReadTChan tc 49 | peekChan (RChan f tc) = stm $ f <$> peekTChan tc 50 | tryPeekChan (RChan f tc) = stm $ fmap f <$> tryPeekTChan tc 51 | isEmptyChan (RChan _ tc) = stm $ isEmptyTChan tc 52 | cloneChan (RChan f tc) = stm $ RChan f <$> cloneTChan tc 53 | dupChan (RChan f tc) = stm $ RChan f <$> dupTChan tc 54 | -------------------------------------------------------------------------------- /Compiler/Sharing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE DeriveTraversable #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE DeriveDataTypeable #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | -------------------------------------------------------------------- 12 | -- | 13 | -- Copyright : (c) Edward Kmett and Dan Doel 2012-2013 14 | -- License : BSD3 15 | -- Maintainer: Edward Kmett 16 | -- Stability : experimental 17 | -- Portability: non-portable 18 | -- 19 | -- These combinators can be used to retain sharing information. 20 | -------------------------------------------------------------------- 21 | module Compiler.Sharing 22 | ( runSharing 23 | , withSharing 24 | , sharing 25 | , SharingT(..) 26 | , Shared(..) 27 | , uncaring 28 | ) where 29 | 30 | import Control.Monad (void) 31 | import Control.Monad.Writer.Class 32 | import Control.Monad.Reader.Class 33 | import Control.Monad.State.Class 34 | import Control.Monad.Trans.Class 35 | import Control.Monad.IO.Class 36 | import Control.Comonad 37 | import Data.Monoid 38 | import Data.Data 39 | import GHC.Generics 40 | 41 | data Shared a = Shared !Bool a 42 | deriving (Eq,Ord,Show,Read,Data,Typeable,Foldable,Functor,Traversable,Generic,Generic1) 43 | 44 | instance Applicative Shared where 45 | pure = Shared False 46 | Shared m a <* Shared n _ = Shared (m || n) a 47 | Shared m _ *> Shared n b = Shared (m || n) b 48 | Shared m f <*> Shared n a = Shared (m || n) (f a) 49 | 50 | instance Monad Shared where 51 | Shared m a >>= f = case f a of 52 | Shared n b -> Shared (m || n) b 53 | 54 | instance MonadWriter Any Shared where 55 | tell (Any p) = Shared p () 56 | {-# INLINE tell #-} 57 | listen (Shared p a) = Shared p (a, Any p) 58 | {-# INLINE listen #-} 59 | pass (Shared p (a, pp)) = Shared (getAny (pp (Any p))) a 60 | {-# INLINE pass #-} 61 | 62 | instance Comonad Shared where 63 | extract (Shared _ a) = a 64 | extend f s@(Shared b _) = Shared b (f s) 65 | 66 | instance ComonadApply Shared where 67 | (<@>) = (<*>) 68 | (<@) = (<*) 69 | (@>) = (*>) 70 | 71 | -- An efficient strict-in-the-monoid version of WriterT Any@ 72 | newtype SharingT m a = SharingT { unsharingT :: m (Shared a) } 73 | deriving (Typeable,Generic,Generic1,Functor,Foldable,Traversable) 74 | 75 | deriving instance (Typeable m, Typeable a, Data (m (Shared a))) => Data (SharingT m a) 76 | 77 | instance Monad m => Applicative (SharingT m) where 78 | pure a = SharingT (return (Shared False a)) 79 | {-# INLINE pure #-} 80 | SharingT mf <*> SharingT ma = SharingT $ do 81 | Shared p f <- mf 82 | Shared q a <- ma 83 | return $! Shared (p || q) (f a) 84 | {-# INLINE (<*>) #-} 85 | 86 | instance Monad m => Monad (SharingT m) where 87 | return a = SharingT (return (Shared False a)) 88 | {-# INLINE return #-} 89 | SharingT m >>= f = SharingT $ do 90 | Shared p a <- m 91 | Shared q b <- unsharingT (f a) 92 | return $! Shared (p || q) b 93 | {-# INLINE (>>=) #-} 94 | 95 | instance Monad m => MonadWriter Any (SharingT m) where 96 | tell (Any p) = SharingT $ return $ Shared p () 97 | {-# INLINE tell #-} 98 | listen (SharingT ma) = SharingT $ do 99 | Shared p a <- ma 100 | return $! Shared p (a, Any p) 101 | {-# INLINE listen #-} 102 | pass (SharingT mapp) = SharingT $ do 103 | Shared p (a, pp) <- mapp 104 | return $! Shared (getAny (pp (Any p))) a 105 | {-# INLINE pass #-} 106 | 107 | instance MonadTrans SharingT where 108 | lift ma = SharingT $ do 109 | a <- ma 110 | return $! Shared False a 111 | {-# INLINE lift #-} 112 | 113 | instance MonadIO m => MonadIO (SharingT m) where 114 | liftIO = lift . liftIO 115 | {-# INLINE liftIO #-} 116 | 117 | instance MonadState s m => MonadState s (SharingT m) where 118 | get = lift get 119 | {-# INLINE get #-} 120 | put = lift . put 121 | {-# INLINE put #-} 122 | 123 | instance MonadReader e m => MonadReader e (SharingT m) where 124 | ask = lift ask 125 | {-# INLINE ask #-} 126 | local f = SharingT . local f . unsharingT 127 | {-# INLINE local #-} 128 | 129 | -- | Run an action, if it returns @'Any' 'True'@ then use its new value, otherwise use the passed in value. 130 | -- 131 | -- This can be used to recover sharing during unification when no interesting unification takes place. 132 | -- 133 | -- This version discards the 'SharingT' wrapper. 134 | runSharing :: Monad m => a -> SharingT m a -> m a 135 | runSharing a m = do 136 | Shared modified b <- unsharingT m 137 | return $! if modified then b else a 138 | {-# INLINE runSharing #-} 139 | 140 | withSharing :: Monad m => (a -> SharingT m a) -> a -> m a 141 | withSharing k a = runSharing a (k a) 142 | {-# INLINE withSharing #-} 143 | 144 | uncaring :: Functor m => SharingT m a -> m () 145 | uncaring = void . unsharingT 146 | {-# INLINE uncaring #-} 147 | 148 | -- | Run an action, if it returns @'Any' 'True'@ then use its new value, otherwise use the passed in value. 149 | -- 150 | -- This can be used to recover sharing during unification when no interesting unification takes place. 151 | -- 152 | -- This version retains the current monad wrapper. 153 | sharing :: MonadWriter Any m => a -> m a -> m a 154 | sharing a m = do 155 | (b, Any modified) <- listen m 156 | return $! if modified then b else a 157 | {-# INLINE sharing #-} 158 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 20 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 22 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 23 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 24 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 25 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 26 | POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Distribution.Extra.Doctest (defaultMainWithDoctests) 4 | 5 | main :: IO () 6 | main = defaultMainWithDoctests "doctests" 7 | -------------------------------------------------------------------------------- /compiler.cabal: -------------------------------------------------------------------------------- 1 | name: compiler 2 | category: Compiler 3 | version: 0 4 | license: BSD2 5 | cabal-version: >= 1.8 6 | license-file: LICENSE 7 | author: Edward A. Kmett 8 | maintainer: Edward A. Kmett 9 | stability: provisional 10 | homepage: http://github.com/ekmett/compiler/ 11 | bug-reports: http://github.com/ekmett/compiler/issues 12 | copyright: Copyright (C) 2017 Edward A. Kmett 13 | synopsis: Random compiler tech 14 | description: Random compiler tech 15 | build-type: Custom 16 | 17 | extra-source-files: 18 | .travis.yml 19 | CHANGELOG.markdown 20 | README.markdown 21 | 22 | source-repository head 23 | type: git 24 | location: git://github.com/ekmett/compiler.git 25 | 26 | custom-setup 27 | setup-depends: 28 | base >= 4 && <5, 29 | Cabal, 30 | cabal-doctest >= 1 && <1.1 31 | 32 | 33 | library 34 | build-depends: 35 | base >= 4 && < 5, 36 | base-orphans >= 0.5 && < 1, 37 | comonad, 38 | containers, 39 | exceptions, 40 | ghc-prim >= 0.5, 41 | hashable, 42 | mtl, 43 | primitive, 44 | profunctors, 45 | reflection, 46 | stm, 47 | transformers >= 0.2 && < 0.6, 48 | transformers-compat >= 0.3 && < 1 49 | 50 | hs-source-dirs: . 51 | exposed-modules: 52 | Compiler.Disjoint 53 | Compiler.Lock 54 | Compiler.Lock.Shared 55 | Compiler.Primitive 56 | Compiler.Prop 57 | Compiler.Sharing 58 | Compiler.STM 59 | Compiler.STM.Chan 60 | 61 | ghc-options: -Wall 62 | 63 | test-suite doctests 64 | type: exitcode-stdio-1.0 65 | main-is: doctests.hs 66 | build-depends: 67 | base >= 4, 68 | directory >= 1.0, 69 | doctest >= 0.9.1, 70 | filepath >= 1.2 71 | ghc-options: -Wall -threaded 72 | hs-source-dirs: tests 73 | -------------------------------------------------------------------------------- /tests/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, pkgs, module_sources) 4 | import Test.DocTest (doctest) 5 | 6 | main :: IO () 7 | main = doctest $ flags ++ pkgs ++ module_sources 8 | --------------------------------------------------------------------------------