Ticket #7561: heapAllocVec2.hs

File heapAllocVec2.hs, 890 bytes (added by wurmli, 16 months ago)
Line 
1
2import System.Environment
3import Control.Applicative
4
5import Control.Monad.ST
6
7import qualified Data.Vector.Unboxed.Mutable as VUM
8import qualified Data.Vector.Generic as G
9import qualified Data.Vector.Unboxed as V
10
11
12whileModify :: Int -> VUM.MVector s Int -> ST s ()
13whileModify n v = do
14  let cond n = do{k<-VUM.read v 0; return (k<n)}
15      acc  v = do{k<-VUM.read v 0; VUM.write v 0 (k+1)}
16  whileAcc (cond n) acc v
17  where
18    whileAcc :: ST s Bool -> 
19                (VUM.MVector s Int -> ST s ()) -> 
20                VUM.MVector s Int -> ST s ()
21    whileAcc mbool f v = do
22      t <- mbool
23      if t
24         then do
25                f v
26                whileAcc mbool f v
27        else return ()
28
29testVUM :: Int -> V.Vector Int 
30testVUM n = 
31  let v = G.singleton 0 in
32  G.modify (whileModify n) v
33
34 
35main = do
36   n <- read.head <$> getArgs
37   putStrLn $ show $ testVUM n
38   
39