lvish 1.0.0.4 → 1.0.0.6
raw patch · 6 files changed
+57/−330 lines, 6 filesdep −abstract-pardep −asyncdep −bits-atomicdep ~atomic-primopsdep ~basedep ~containers
Dependencies removed: abstract-par, async, bits-atomic, bytestring, bytestring-mmap, hashable, missing-foreign, parallel, rdtsc, split
Dependency ranges changed: atomic-primops, base, containers, deepseq, lattices, time, vector
Files
- Control/LVish/DeepFrz.hs +1/−1
- Control/LVish/SchedIdempotent.hs +4/−0
- Data/LVar/NatArray.hs +0/−284
- Data/LVar/SLMap.hs +0/−1
- lvish.cabal +34/−33
- unit-tests.hs +18/−11
Control/LVish/DeepFrz.hs view
@@ -85,7 +85,7 @@ -- `freeze` at the end of a `runParIO`: there is an implicit barrier -- before the final freeze. Further, `DeepFrz` has no runtime -- overhead, whereas regular freezing has a cost.-runParThenFreezeIO :: DeepFrz a => Par d s a -> IO (FrzType a)+runParThenFreezeIO :: DeepFrz a => Par d NonFrzn a -> IO (FrzType a) runParThenFreezeIO (WrapPar p) = do x <- runParIO p return $ frz x
Control/LVish/SchedIdempotent.hs view
@@ -61,6 +61,10 @@ import Prelude hiding (mapM, sequence, head, tail) import System.Random (random) +#ifdef DEBUG_LVAR +import Text.Printf (printf)+#endif+ -- import Control.Compose ((:.), unO) import Data.Traversable
− Data/LVar/NatArray.hs
@@ -1,284 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE GADTs #-}--{-|--An I-structure (array) of /positive/ numbers. A `NatArray` cannot store zeros.--This particular implementation makes a trade-off between expressiveness (monomorphic-in array contents) and efficiency. The efficiency gained of course is that the array-may be unboxed, and we don't need extra bits to store empty/full status.--/However/, relative to "Data.LVar.IStructure", there is a performance disadvantage as-well. As of [2013.09.28] and their initial release, `NatArray`s are implemented as a-/single/ `LVar`, which means they share a single wait-list of blocked computations.-If there are many computations blocking on different elements within a `NatArray`,-scalability will be much worse than with other `IStructure` implementations.--The holy grail is to get unboxed arrays and scalable blocking, but we don't have this-yet.--Finally, note that this data-structure has an EXPERIMENTAL status and may be removed-in future releases as we find better ways to support unboxed array structures with-per-element synchronization.---}--module Data.LVar.NatArray- (- -- * Basic operations- NatArray,- newNatArray, put, get,-- -- * Iteration and callbacks- forEach, forEachHP-- -- -- * Quasi-deterministic operations- -- freezeSetAfter, withCallbacksThenFreeze, freezeSet,-- -- -- * Higher-level derived operations- -- copy, traverseSet, traverseSet_, union, intersection,- -- cartesianProd, cartesianProds, -- -- -- * Alternate versions of derived ops that expose HandlerPools they create.- -- forEachHP, traverseSetHP, traverseSetHP_,- -- cartesianProdHP, cartesianProdsHP- ) where---- import qualified Data.Vector.Unboxed as U--- import qualified Data.Vector.Unboxed.Mutable as M--import qualified Data.Vector.Storable as U-import qualified Data.Vector.Storable.Mutable as M-import Foreign.Marshal.MissingAlloc (callocBytes)-import Foreign.Marshal.Alloc (finalizerFree)-import Foreign.Storable (sizeOf, Storable)-import Foreign.ForeignPtr (newForeignPtr, withForeignPtr)-import qualified Foreign.Ptr as P-import qualified Data.Bits.Atomic as B-import Data.Bits ((.&.))--import Control.Monad (void)-import Control.Exception (throw)-import Data.IORef-import Data.Maybe (fromMaybe)-import qualified Data.Set as S-import qualified Data.LVar.IVar as IV-import qualified Data.Foldable as F-import qualified Data.Traversable as T-import Data.LVar.Generic--import Control.LVish as LV hiding (addHandler)-import Control.LVish.DeepFrz.Internal as DF-import Control.LVish.Internal as LI-import Control.LVish.SchedIdempotent (newLV, putLV, getLV, freezeLV,- freezeLVAfter, liftIO)-import qualified Control.LVish.SchedIdempotent as L-import System.IO.Unsafe (unsafeDupablePerformIO)----------------------------------------------------------------------------------- Toggles--#define USE_CALLOC--- A low-level optimization below.------------------------------------------------------------------------------------ | An array of bit-fields with a monotonic OR operation. This can be used to model--- a set of Ints by setting the vector entries to zero or one, but it can also--- model other finite lattices for each index.--- newtype NatArray s a = NatArray (LVar s (M.IOVector a) (Int,a))-data NatArray s a = Storable a => NatArray !(LVar s (M.IOVector a) (Int,a))--unNatArray (NatArray lv) = lv---- | Physical identity, just as with IORefs.--- instance Eq (NatArray s v) where--- NatArray lv1 == NatArray lv2 = state lv1 == state lv2 ---- | Create a new, empty, monotonically growing 'NatArray' of a given size.--- All entries start off as zero, which must be BOTTOM.-newNatArray :: forall elt d s . (Storable elt, Num elt) =>- Int -> Par d s (NatArray s elt)-newNatArray len = WrapPar $ fmap (NatArray . WrapLVar) $ newLV $ do-#ifdef USE_CALLOC- let bytes = sizeOf (undefined::elt) * len- mem <- callocBytes bytes- fp <- newForeignPtr finalizerFree mem- return $! M.unsafeFromForeignPtr0 fp len-#else- M.replicate len 0-#endif---- | /O(1)/ Freeze operation that directly returns a nice, usable, representation of--- the array data.-freezeNatArray :: Storable a => NatArray s a -> LV.Par QuasiDet s (U.Vector a)-freezeNatArray (NatArray lv) =- error "FINISHME"- -- LI.liftIO $ U.unsafeFreeze (LI.state lv)------------------------------------------------------------------------------------- Instances:---- FIXME: there is a tension here.. should NatArray really be a generic LVarData1 at all?--- Can it really store anything in Storable!?!? Or do we need to fix it to numbers--- to ensure the zero-trick makes sense?--{---instance DeepFrz a => DeepFrz (NatArray s a) where- type FrzType (NatArray s a) = NatArray Frzn (FrzType a)- frz = unsafeCoerceLVar---- | /O(1)/: Convert from a frozen `NatArray` to a plain vector.--- This is only permitted when the `NatArray` has already been frozen.--- This is useful for processing the result of `Control.LVish.DeepFrz.runParThenFreeze`.-fromNatArray :: NatArray Frzn a -> U.Vector a-fromNatArray (NatArray lv) = unsafeDupablePerformIO (readIORef (state lv))---}------------------------------------------------------------------------------------{-# INLINE forEachHP #-}--- | Add an (asynchronous) callback that listens for all new elements added to--- the array, optionally enrolled in a handler pool.-forEachHP :: (Storable a, Eq a, Num a) =>- Maybe HandlerPool -- ^ pool to enroll in, if any- -> NatArray s a -- ^ array to listen to- -> (Int -> a -> Par d s ()) -- ^ callback- -> Par d s ()-forEachHP hp (NatArray (WrapLVar lv)) callb = WrapPar $ do- L.addHandler hp lv globalCB deltaCB- return ()- where- deltaCB (ix,x) = return$ Just$ unWrapPar$ callb ix x- globalCB vec = return$ Just$ unWrapPar$- -- FIXME / TODO: need a better (parallel) for loop:- forVec vec $ \ ix elm ->- -- FIXME: When it starts off, it is SPARSE... there must be a good way to- -- avoid testing each position for zero.- if elm == 0- then return () - else forkHP hp $ callb ix elm--{-# INLINE forVec #-}--- | Simple for-each loops over vector elements.-forVec :: Storable a =>- M.IOVector a -> (Int -> a -> Par d s ()) -> Par d s ()-forVec vec fn = loop 0 - where- len = M.length vec- loop i | i == len = return ()- | otherwise = do elm <- LI.liftIO$ M.unsafeRead vec i- fn i elm- loop (i+1)--{-# INLINE forEach #-}--- | Add an (asynchronous) callback that listens for all new elements added to--- the set-forEach :: (Num a, Storable a, Eq a) =>- NatArray s a -> (Int -> a -> Par d s ()) -> Par d s ()-forEach = forEachHP Nothing---{-# INLINE put #-}--- | Put a single element in the array. That slot must be previously empty. (WHNF)--- Strict in the element being put in the set.-put :: forall s d elt . (Storable elt, B.AtomicBits elt, Num elt, Show elt) =>- NatArray s elt -> Int -> elt -> Par d s ()-put _ !ix 0 = throw (LVarSpecificExn$ "NatArray: violation! Attempt to put zero to index: "++show ix)-put (NatArray (WrapLVar lv)) !ix !elm = WrapPar$ putLV lv (putter ix)- where putter ix vec@(M.MVector offset fptr) =- withForeignPtr fptr $ \ ptr -> do - let offset = sizeOf (undefined::elt) * ix- -- ARG, if it weren't for the idempotency requirement we could use fetchAndAdd here:- -- orig <- B.fetchAndAdd (P.plusPtr ptr offset) elm - orig <- B.compareAndSwap (P.plusPtr ptr offset) 0 elm- case orig of- 0 -> return (Just (ix, elm))- i | i == elm -> return Nothing -- Allow repeated, equal puts.- | otherwise -> throw$ ConflictingPutExn$ "Multiple puts to index of a NatArray: "++- show ix++" new/old : "++show elm++"/"++show orig--{-# INLINE get #-}--- | Wait for an indexed entry to contain a non-zero value.--- --- Warning: this is inefficient if it needs to block, because the deltaThresh must--- monitor EVERY new addition.-get :: forall s d elt . (Storable elt, B.AtomicBits elt, Num elt) =>- NatArray s elt -> Int -> Par d s elt-get (NatArray (WrapLVar lv)) !ix = WrapPar $- getLV lv globalThresh deltaThresh- where- globalThresh ref _frzn = do - elm <- M.read ref ix - if elm == 0- then return Nothing- else return (Just elm)- -- FIXME: we don't actually want to call the deltaThresh on every element...- -- We want more locality than that...- deltaThresh (ix2,e2) | ix == ix2 = return$! Just e2- | otherwise = return Nothing ----- | A sequential for-loop with a catch. The body of the loop gets access to a--- special get function. This getter will not block subsequent iterations of the--- loop. Parallelism will be introduced minimally, only as neccessary to avoid--- blocking.-seqLoopNonblocking :: Int -> Int ->- ((NatArray s elt -> Int -> Par d s elt) -> Int -> Par d s ()) ->- Par d s ()-seqLoopNonblocking start end fn = do- error "TODO - FINISHME: seqLoopNonblocking optimization"- where- par =- L.Par $ \k -> L.ClosedPar $ \q -> do- -- tripped <- globalThresh state False--- case tripped of- -- Just b -> exec (k b) q -- already past the threshold; invoke the--- forkHP mh child = mkPar $ \k q -> do--- closed <- closeInPool mh child--- Sched.pushWork q (k ()) -- "Work-first" policy.--- -- hpMsg " [dbg-lvish] incremented and pushed work in forkInPool, now running cont" hp --- exec closed q - undefined--{--parFor :: (ParFuture iv p) => InclusiveRange -> (Int -> p ()) -> p ()-parFor (InclusiveRange start end) body =- do- let run (x,y) = for_ x (y+1) body- range_segments = splitInclusiveRange (4*numCapabilities) (start,end)-- vars <- M.forM range_segments (\ pr -> spawn_ (run pr))- M.mapM_ get vars- return ()--splitInclusiveRange :: Int -> (Int, Int) -> [(Int, Int)]-splitInclusiveRange pieces (start,end) =- map largepiece [0..remain-1] ++- map smallpiece [remain..pieces-1]- where- len = end - start + 1 -- inclusive [start,end]- (portion, remain) = len `quotRem` pieces- largepiece i =- let offset = start + (i * (portion + 1))- in (offset, offset + portion)- smallpiece i =- let offset = start + (i * portion) + remain- in (offset, offset + portion - 1)--data InclusiveRange = InclusiveRange Int Int--}
Data/LVar/SLMap.hs view
@@ -67,7 +67,6 @@ import Control.LVish.Internal as LI import Control.LVish.SchedIdempotent (newLV, putLV, putLV_, getLV, freezeLV) import qualified Control.LVish.SchedIdempotent as L-import System.Random (randomIO) import System.IO.Unsafe (unsafeDupablePerformIO) import GHC.Prim (unsafeCoerce#) import Prelude
lvish.cabal view
@@ -10,12 +10,14 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 1.0.0.4+version: 1.0.0.6 -- Changelog: -- 0.2 -- switch SLMap over to O(1) freeze -- 1.0 -- initial public release -- 1.0.0.2 -- minor docs polishing+-- 1.0.0.4 -- Bugfix for runParThenFreeze 's' param (issue #26).+-- 1.0.0.6 -- tighten up dependencies; remove unused flags; very minor doc fixes. synopsis: Parallel scheduler, LVar data structures, and infrastructure to build more. @@ -27,16 +29,14 @@ . * FHPC 2013: /LVars: lattice-based data structures for deterministic parallelism/ (<http://dl.acm.org/citation.cfm?id=2502326>). .-- * POPL 2014: /Freeze after writing: quasi-deterministic programming with LVars/ (<http://www.cs.indiana.edu/~lkuper/papers/2013-lvish-draft.pdf>).+ * POPL 2014: /Freeze after writing: quasi-deterministic parallel programming with LVars/ (<http://www.cs.indiana.edu/~lkuper/papers/2013-lvish-draft.pdf>). . If the haddocks are not building, here is a mirror: <http://www.cs.indiana.edu/~rrnewton/haddock/lvish/> . Change Log: .- * 1.0.0.4 - this is a critical bugfix release; please do not use earlier versions.-+ * 1.0.0.6 - tighten up dependencies; remove unused flags; very minor doc fixes. license: BSD3 license-file: LICENSE@@ -57,14 +57,6 @@ description: Use the Chase-Lev work-stealing deque default: True -flag quick- description: Build some targets but not others. Omit apps and tests.- default: False--flag abstract-par- description: If enabled, provide instances for generic par operations using the establish type classes.- default: False- flag getonce description: Ensure that continuations of get run at most once (by using extra synchronization)@@ -76,7 +68,7 @@ type: git location: https://github.com/iu-parfunc/lvars subdir: haskell/lvish- tag: release-lvish-1.0.0.2+ tag: release-lvish-1.0.0.6 -- Modules exported by the library. exposed-modules:@@ -114,28 +106,27 @@ Control.LVish.MonadToss Control.LVish.Types -- Not ready for prime-time yet:- Data.LVar.NatArray+-- Data.LVar.NatArray Data.LVar.MaxCounter -- Other library packages from which modules are imported.- build-depends: base ==4.6.*, deepseq ==1.3.*, containers ==0.5.*, lattices ==1.2.*, - split ==0.2.*, bytestring ==0.10.*, time ==1.4.*, rdtsc ==1.3.*, vector ==0.10.*, - parallel ==3.2.*, async ==2.0.*,- atomic-primops, hashable, transformers, random, - chaselev-deque, - bits-atomic, missing-foreign,+ build-depends: base >= 4.6 && <= 4.8, + deepseq >= 1.3, + containers >= 0.5, + lattices >= 1.2, + vector >=0.10,+ atomic-primops >= 0.4, + random, + transformers, ghc-prim- -- TEMP:- build-depends: HUnit, test-framework, test-framework-hunit, test-framework-th,- bytestring-mmap+ -- Used in NatArray:+-- bits-atomic, missing-foreign+ ghc-options: -O2 -rtsopts- if flag(abstract-par) - cpp-options: -DUSE_ABSTRACT_PAR- build-depends: abstract-par >=0.4- -- monad-par-extras >=0.4 if flag(debug) cpp-options: -DDEBUG_LVAR if flag(chaselev)+ build-depends: chaselev-deque cpp-options: -DCHASE_LEV if flag(getonce) cpp-options: -DGET_ONCE@@ -147,16 +138,26 @@ type: exitcode-stdio-1.0 main-is: unit-tests.hs other-modules: TestHelpers - + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N4- build-depends: base ==4.6.*, containers ==0.5.*, transformers, atomic-primops, chaselev-deque, - random, deepseq, vector, bits-atomic, missing-foreign, time, ghc-prim, HUnit, test-framework, - test-framework-hunit, test-framework-th++ -- DUPLICATE:+ build-depends: base >= 4.6 && <= 4.8, + deepseq >= 1.3, + containers >= 0.5, + lattices >= 1.2, + vector >=0.10,+ atomic-primops >= 0.4, + random, + transformers,+ ghc-prim+ + build-depends: time, HUnit, test-framework, test-framework-hunit, test-framework-th if flag(debug) cpp-options: -DDEBUG_LVAR if flag(chaselev)+ build-depends: chaselev-deque cpp-options: -DCHASE_LEV if flag(getonce) cpp-options: -DGET_ONCE-
unit-tests.hs view
@@ -38,7 +38,9 @@ import Data.Word import qualified Data.LVar.Generic as G+#ifdef NATARRAY import qualified Data.LVar.NatArray as NA+#endif import Data.LVar.PureSet as IS import Data.LVar.PureMap as IM @@ -105,13 +107,14 @@ , HU.TestLabel "case_v8b" $ HU.TestCase case_v8b , HU.TestLabel "case_v8c" $ HU.TestCase case_v8c , HU.TestLabel "case_v8d" $ HU.TestCase case_v8d+#ifdef NATARRAY , HU.TestLabel "case_v9a" $ HU.TestCase case_v9a , HU.TestLabel "case_i9c" $ HU.TestCase case_i9c , HU.TestLabel "case_v9d" $ HU.TestCase case_v9d , HU.TestLabel "case_v9e" $ HU.TestCase case_v9e -- , HU.TestLabel "case_v9f" $ HU.TestCase case_v9f -- [2013.09.26] RRN: problems..--- , HU.TestLabel "case_v9g" $ HU.TestCase case_v9g -- [2013.09.26] Blocked indefinitely , HU.TestLabel "case_i9h" $ HU.TestCase case_i9h+#endif , HU.TestLabel "case_lp01" $ HU.TestCase case_lp01 , HU.TestLabel "case_lp02" $ HU.TestCase case_lp02 , HU.TestLabel "case_lp03" $ HU.TestCase case_lp03@@ -573,6 +576,7 @@ -- NatArrays -------------------------------------------------------------------------------- +#ifdef NATARRAY case_v9a :: Assertion case_v9a = assertEqual "basic NatArray" 4 =<< v9a v9a :: IO Word8@@ -661,6 +665,19 @@ loop (acc+v) (ix+1) loop 0 0 +-- Uh oh, this is blocking indefinitely sometimes...+-- BUT, only when I run the whole test suite.. via cabal install --enable-tests+case_i9h :: Assertion+case_i9h = exceptionOrTimeOut 0.3 ["Attempt to put zero"] i9i+i9i :: IO Word+i9i = runParIO$ do+ arr <- NA.newNatArray 1+ NA.put arr 0 0+ NA.get arr 0++#endif+-- end: NatArray tests+ -- | One more time with a full IStructure. case_v9g :: Assertion case_v9g = assertEqual "IStructure, compare effficiency:" 5000050000 =<< v9g@@ -677,16 +694,6 @@ loop (acc+v) (ix+1) loop 0 0 ---- Uh oh, this is blocking indefinitely sometimes...--- BUT, only when I run the whole test suite.. via cabal install --enable-tests-case_i9h :: Assertion-case_i9h = exceptionOrTimeOut 0.3 ["Attempt to put zero"] i9i-i9i :: IO Word-i9i = runParIO$ do- arr <- NA.newNatArray 1- NA.put arr 0 0- NA.get arr 0 -------------------------------------------------------------------------------- -- Looping constructs