79b01f624a9ea4c4faf3e78750dba58e212c9f21
[ghc.git] / testsuite / tests / llvm / should_compile / T5054.hs
1 {-# OPTIONS_GHC -W #-}
2
3 import Data.Int
4 import Data.Packed
5 import Data.Packed.ST
6 import Control.Monad.ST
7 import Foreign.Storable
8 import Foreign.Ptr
9 import Foreign.Marshal.Utils
10
11 main :: IO ()
12 main = print $ arst (zeroMatrix 10 10) (Constant 9)
13
14 data ComputeElement
15 = Constant !Double
16 | Value !Double
17 deriving (Eq)
18
19 isConstant (Constant _) = True
20 isConstant _ = False
21
22 instance Element ComputeElement
23
24 fromComputeElement (Constant v) = v
25 fromComputeElement (Value v) = v
26
27 sizeofDouble = sizeOf (undefined :: Double)
28 sizeofInt64 = sizeOf (undefined :: Int64)
29
30 instance Storable ComputeElement where
31 sizeOf _ = sizeofDouble + sizeofInt64
32 alignment _ = 16
33
34 peek p = do
35 v <- peek (castPtr p)
36 c <- peek (castPtr (p `plusPtr` sizeofDouble))
37 return $ if toBool (c :: Int64)
38 then Constant v
39 else Value v
40
41 poke p v = do
42 let c :: Int64
43 c = fromBool (isConstant v)
44 poke (castPtr p) (fromComputeElement v)
45 poke (castPtr p `plusPtr` sizeofDouble) c
46
47
48 arst mat v = runST $ do
49 mat' <- thawMatrix mat
50 writeMatrix mat' 1 2 v
51 x <- fromComputeElement `fmap` readMatrix mat' 1 9
52 return (x > 0)
53
54 zeroMatrix m n = buildMatrix m n (const (Value 0))
55