FastPush (empty) → 0.1.0.0

raw patch · 8 files changed

+267/−0 lines, 8 filesdep +STMonadTransdep +basedep +mtlsetup-changed

Dependencies added: STMonadTrans, base, mtl, transformers, vector

Files

ChangeLog.md +5/−0
FastPush.cabal +29/−0
LICENSE +30/−0
Setup.hs +2/−0
src/Control/Monad/Push.hs +78/−0
src/Control/Monad/Push/Class.hs +7/−0
src/Control/Monad/Push/Example.hs +26/−0
src/Control/Monad/Trans/Push.hs +90/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Revision history for FastPush++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ FastPush.cabal view

@@ -0,0 +1,29 @@+-- Initial FastPush.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                FastPush+version:             0.1.0.0+synopsis:            A monad and monad transformer for pushing things onto a stack very fast.+description:         This library gives you a monad that lets you push things onto a stack very quickly. +                     You get things off the stack when you run the monad. Under the hood, this uses mutable+                     vectors. I've also included a monad transformer using the STMonadTrans library that +                     does the same thing as a transformer, but it's probably very unsafe. +homepage:            https://github.com/wyager/FastPush/+license:             BSD3+license-file:        LICENSE+author:              Will Yager+maintainer:          dev@yager.io+-- copyright:           +category:            Control+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++library+  exposed-modules:     Control.Monad.Push.Example, Control.Monad.Push, Control.Monad.Push.Class, Control.Monad.Trans.Push+  -- other-modules:       +  other-extensions:    FlexibleContexts, ScopedTypeVariables, TypeApplications, RankNTypes, MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveFunctor, FlexibleInstances, StandaloneDeriving, UnboxedTuples+  build-depends:       base >=4.9 && <4.10, vector >=0.12 && <0.13, transformers >=0.5 && <0.6, STMonadTrans >=0.3 && <0.4, mtl >=2.2 && <2.3+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -O2

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2017, Will Yager++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 Will Yager 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,2 @@+import Distribution.Simple+main = defaultMain

+ src/Control/Monad/Push.hs view

@@ -0,0 +1,78 @@+-- Hybrid ReaderT/StateT style+-- 100M Ints in ~3.1 seconds+-- 2.95G allocated. Seems to match minimal ST loop++{-# LANGUAGE TypeApplications, RankNTypes, MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveFunctor, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}++module Control.Monad.Push where++import Control.Monad.ST (ST, runST)+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import qualified Control.Monad.Trans.Class as Trans+import qualified Data.Vector.Generic         as VG+import qualified Data.Vector.Generic.Mutable as VGM+import Data.STRef.Strict (STRef, readSTRef, writeSTRef, newSTRef)+import qualified Data.STRef.Strict as Ref+import qualified Data.Foldable as Foldable+import Control.Monad.Push.Class (MonadPush, push)++-- | The internal return type of a push action.+-- The Int value is the new vector used length.+data Res a = Res !Int+                 !a deriving Functor++-- | A monad  that lets you push things onto a stack.+newtype Push v p a = Push (forall s . Int -> (STRef s (v s p)) -> (ST s (Res a))) deriving (Functor)++instance Applicative (Push v p) where+    {-# INLINE pure #-}+    pure a = Push $ \u v -> (return (Res u a))+    {-# INLINE (<*>) #-}+    (Push f) <*> (Push g) = Push $ \u v -> f u v >>= (\(Res u' o1) -> g u' v >>= (\(Res u'' o2) -> return (Res u'' (o1 o2))))++instance Monad (Push v p) where+    {-# INLINE return #-}+    return = pure+    {-# INLINE (>>=) #-}+    Push g >>= f = Push $ \u v -> ((g u v) >>= (\(Res u' x) -> let Push h = f x in h u' v))+    {-# INLINE (>>) #-}+    Push g >> Push h = Push $ \u v -> g u v >>= (\(Res u' _) -> h u' v)++instance VGM.MVector v p => MonadPush p (Push v p) where+    {-# INLINE push #-}+    push a = Push $ \used vec' -> do+        vec <- readSTRef vec'+        if (VGM.length vec == used) +            then do+                bigger <- VGM.grow vec used -- Double the length+                VGM.write bigger used a+                writeSTRef vec' bigger+            else do+                VGM.write vec used a+        return $ Res (used+1) ()++-- | Run the Push monad. Get the return value and the output stack.+{-# INLINE runPush #-}+runPush :: VG.Vector v p => Push (VG.Mutable v) p a -> (a, v p)+runPush (Push action) = runST $ do+    initial <- VGM.new 1+    vecRef <- newSTRef initial+    (Res used out) <- action 0 vecRef+    final <- readSTRef vecRef+    vec <- VG.freeze (VGM.slice 0 used final)+    return (out, vec)++-- | Specialized to Unboxed vectors.+{-# INLINE runPushU #-}+runPushU :: forall p a . VU.Unbox p => Push (VU.MVector) p a -> (a, VU.Vector p)+runPushU = runPush+-- | Specialized to standard Boxed vectors.+{-# INLINE runPushB #-}+runPushB :: forall p a . Push (V.MVector) p a -> (a, V.Vector p)+runPushB = runPush+-- | Specialized to Storable vectors.+{-# INLINE runPushS #-}+runPushS :: forall p a . VS.Storable p => Push (VS.MVector) p a -> (a, VS.Vector p)+runPushS = runPush

+ src/Control/Monad/Push/Class.hs view

@@ -0,0 +1,7 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}++module Control.Monad.Push.Class where++class Monad m => MonadPush a m where+    -- | Push an item onto the stack+    push :: a -> m ()

+ src/Control/Monad/Push/Example.hs view

@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}++module Control.Monad.Push.Example where++import qualified Control.Monad.Push as P+import qualified Control.Monad.Trans.Push as TP+import Control.Monad.Push.Class (MonadPush, push)+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Unboxed as VU++-- | A simple test routine, generic over choice of MonadPush instance.+test :: MonadPush Int m => m ()+test = go (100000000 :: Int)+    where+    go 0 = push (5 :: Int)+    go n = push (5 :: Int) >> go (n-1)++-- | Using the pure Push monad+testMonad :: IO ()+testMonad = let (_, vec :: VU.Vector Int) = P.runPushU test in print (VG.length vec)++-- | Using PushT over IO+testTransformer :: IO ()+testTransformer = do+    (_, vec :: VU.Vector Int) <- TP.runPushTU test+    print (VG.length vec)

+ src/Control/Monad/Trans/Push.hs view

@@ -0,0 +1,90 @@+-- Hybrid ReaderT/StateT style over STT+-- 100M Ints in ~4 seconds over IO+-- Seems to optimize away the inner monad pretty well when feasible++{-# LANGUAGE TypeApplications, RankNTypes, MultiParamTypeClasses, +    GeneralizedNewtypeDeriving, DeriveFunctor, FlexibleInstances, +    FlexibleContexts, ScopedTypeVariables, StandaloneDeriving, UnboxedTuples #-}++module Control.Monad.Trans.Push where++import Control.Monad.ST.Trans (runST, STRef, readSTRef, writeSTRef, newSTRef)+import Control.Monad.ST.Trans.Internal (STT(STT), STTRet(STTRet))+import GHC.ST (ST(ST))+import Control.Monad.Identity (Identity, runIdentity)+import qualified Data.Vector as V+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import qualified Control.Monad.Trans.Class as Trans+import qualified Data.Vector.Generic         as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.STRef.Strict as Ref+import qualified Data.Foldable as Foldable+import Control.Monad.Push.Class (MonadPush, push)++-- | The internal return type of a push action.+-- The Int value is the new vector used length.+data Res a = Res !Int+                 !a deriving Functor++-- | A monad transformer that lets you push things onto a stack.+-- This is probably super unsafe; see the docs for Control.Monad.ST.Trans.+newtype PushT v p m a = PushT (forall s . Int -> (STRef s (v s p)) -> (STT s m (Res a)))++deriving instance Functor m => Functor (PushT v p m)++instance Monad m => Applicative (PushT v p m) where+    {-# INLINE pure #-}+    pure a = PushT $ \u v -> (return (Res u a))+    {-# INLINE (<*>) #-}+    (PushT f) <*> (PushT g) = PushT $ \u v -> f u v >>= (\(Res u' o1) -> g u' v >>= (\(Res u'' o2) -> return (Res u'' (o1 o2))))++instance Monad m => Monad (PushT v p m) where+    {-# INLINE return #-}+    return = pure+    {-# INLINE (>>=) #-}+    PushT g >>= f = PushT $ \u v -> ((g u v) >>= (\(Res u' x) -> let PushT h = f x in h u' v))+    {-# INLINE (>>) #-}+    PushT g >> PushT h = PushT $ \u v -> g u v >>= (\(Res u' _) -> h u' v)++-- | This seems *highly* questionable, but appears to get the job done.+{-# INLINE liftST #-}+liftST :: Applicative m => ST s a -> STT s m a+liftST (ST f) = STT (\s -> let (# s', a #) = f s in pure (STTRet s a))++instance (Monad m, VGM.MVector v p) => MonadPush p (PushT v p m) where+    {-# INLINE push #-}+    push a = PushT $ \used vec' -> do+        vec <- readSTRef vec'+        if (VGM.length vec == used) +            then do+                bigger <- liftST $ VGM.grow vec used -- Double the length+                liftST $ VGM.write bigger used a+                writeSTRef vec' bigger+            else do+                liftST $ VGM.write vec used a+        return $ Res (used+1) ()++-- | Run the monad transformer.+{-# INLINE runPushT #-}+runPushT :: (Monad m, VG.Vector v p) => PushT (VG.Mutable v) p m a -> m (a, v p)+runPushT (PushT action) = runST $ do+    initial <- liftST $ VGM.new 1+    vecRef <- newSTRef initial+    (Res used out) <- action 0 vecRef+    final <- readSTRef vecRef+    vec <- liftST $ VG.freeze (VGM.slice 0 used final)+    return (out, vec)++-- | Specialized to Unboxed vectors.+{-# INLINE runPushTU #-}+runPushTU :: forall p a m . (VU.Unbox p, Monad m) => PushT (VU.MVector) p m a -> m (a, VU.Vector p)+runPushTU = runPushT+-- | Specialized to standard Boxed vectors.+{-# INLINE runPushTB #-}+runPushTB :: forall p a m . Monad m => PushT (V.MVector) p m a -> m (a, V.Vector p)+-- | Specialized to Storable vectors.+runPushTB = runPushT+{-# INLINE runPushTS #-}+runPushTS :: forall p a m . (VS.Storable p, Monad m) => PushT (VS.MVector) p m a -> m (a, VS.Vector p)+runPushTS = runPushT