Remove the implementation of gmp primops from the rts
[ghc-hetmet.git] / compiler / cmm / CmmTx.hs
1 module CmmTx where
2
3 data ChangeFlag = NoChange | SomeChange
4
5 type Tx a    = a -> TxRes a
6 data TxRes a = TxRes ChangeFlag a
7
8 seqTx :: Tx a -> Tx a -> Tx a
9 iterateTx :: Tx a -> Tx a
10 runTx :: Tx a -> a -> a
11
12 noTx, aTx :: a -> TxRes a
13 noTx x = TxRes NoChange   x
14 aTx  x = TxRes SomeChange x
15
16 replaceTx :: a -> TxRes b -> TxRes a
17 replaceTx a (TxRes change _) = TxRes change a
18
19 txVal :: TxRes a -> a
20 txVal (TxRes _ a) = a
21
22 txHasChanged :: TxRes a -> Bool
23 txHasChanged (TxRes NoChange   _) = False
24 txHasChanged (TxRes SomeChange _) = True
25
26 plusTx :: (a -> b -> c) -> TxRes a -> TxRes b -> TxRes c
27 plusTx f (TxRes c1 a) (TxRes c2 b) = TxRes (c1 `orChange` c2) (f a b)
28
29 mapTx :: Tx a -> Tx [a]
30 mapTx _ []     = noTx []
31 mapTx f (x:xs) = plusTx (:) (f x) (mapTx f xs)
32
33 runTx f = txVal . f
34
35 seqTx f1 f2 a =
36     let TxRes c1 a1 = f1 a
37         TxRes c2 a2 = f2 a1
38     in  TxRes (c1 `orChange` c2) a2
39
40 iterateTx f a 
41   = case f a of
42         TxRes NoChange   a' -> TxRes NoChange a'
43         TxRes SomeChange a' -> let TxRes _ a'' = iterateTx f a'
44                              in TxRes SomeChange a''
45
46 orChange :: ChangeFlag -> ChangeFlag -> ChangeFlag
47 orChange NoChange   c = c
48 orChange SomeChange _ = SomeChange
49
50
51
52 instance Functor TxRes where
53   fmap f (TxRes ch a) = TxRes ch (f a)
54
55 instance Monad TxRes where
56     return = TxRes NoChange
57     (TxRes NoChange a) >>= k = k a
58     (TxRes SomeChange a) >>= k = let (TxRes _ a') = k a in TxRes SomeChange a'