summaryrefslogtreecommitdiff
path: root/testsuite/tests/llvm/should_compile/T5054.hs
blob: 79b01f624a9ea4c4faf3e78750dba58e212c9f21 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
{-# OPTIONS_GHC -W #-}

import Data.Int
import Data.Packed
import Data.Packed.ST
import Control.Monad.ST
import Foreign.Storable
import Foreign.Ptr
import Foreign.Marshal.Utils

main :: IO ()
main = print $ arst (zeroMatrix 10 10) (Constant 9)

data ComputeElement
    = Constant !Double
    | Value !Double
  deriving (Eq)

isConstant (Constant _) = True
isConstant _            = False

instance Element ComputeElement

fromComputeElement (Constant v) = v
fromComputeElement (Value    v) = v

sizeofDouble = sizeOf (undefined :: Double)
sizeofInt64  = sizeOf (undefined :: Int64)

instance Storable ComputeElement where
    sizeOf    _ = sizeofDouble + sizeofInt64
    alignment _ = 16

    peek p = do
        v <- peek (castPtr p)
        c <- peek (castPtr (p `plusPtr` sizeofDouble))
        return $ if toBool (c :: Int64)
            then Constant v
            else Value v

    poke p v = do
        let c :: Int64
            c = fromBool (isConstant v)
        poke (castPtr p) (fromComputeElement v)
        poke (castPtr p `plusPtr` sizeofDouble) c


arst mat v = runST $ do
    mat' <- thawMatrix mat
    writeMatrix mat' 1 2 v
    x <- fromComputeElement `fmap` readMatrix mat' 1 9
    return (x > 0)

zeroMatrix m n = buildMatrix m n (const (Value 0))