module Control.Monad.MultiPass.Instrument.EmitST2Array
( EmitST2Array
, setBaseIndex, emit, emitList, getIndex, getResult
)
where
import Control.Exception ( assert )
import Control.Monad.ST2
import Control.Monad.MultiPass
import Control.Monad.MultiPass.ThreadContext.CounterTC
import Data.Ix
data EmitST2Array i a r w p1 p2 p3 tc
= EmitST2Array
{ setBaseInternal :: !(p2 i -> MultiPassPrologue r w tc ())
, emitInternal :: !(p3 a -> MultiPass r w tc ())
, emitListInternal :: !(p1 Int -> p3 [a] -> MultiPass r w tc ())
, getIndexInternal :: !(forall w'. MultiPass r w' tc (p2 i))
, getResultInternal
:: !(MultiPassEpilogue r w tc (p3 (ST2Array r w i a)))
}
setBaseIndex
:: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
=> EmitST2Array i a r w p1 p2 p3 tc
-> p2 i
-> MultiPassPrologue r w tc ()
setBaseIndex =
setBaseInternal
emit
:: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
=> EmitST2Array i a r w p1 p2 p3 tc
-> p3 a
-> MultiPass r w tc ()
emit =
emitInternal
emitList
:: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
=> EmitST2Array i a r w p1 p2 p3 tc
-> p1 Int
-> p3 [a]
-> MultiPass r w tc ()
emitList =
emitListInternal
getIndex
:: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
=> EmitST2Array i a r w p1 p2 p3 tc
-> MultiPass r w' tc (p2 i)
getIndex =
getIndexInternal
getResult
:: (Ix i, Num i, Monad p1, Monad p2, Monad p3)
=> EmitST2Array i a r w p1 p2 p3 tc
-> MultiPassEpilogue r w tc (p3 (ST2Array r w i a))
getResult =
getResultInternal
newtype GC2 r w i
= GC2 { gc2_base :: ST2Ref r w i }
data GC3 r w i a
= GC3
{ gc3_base :: !(ST2Ref r w i)
, gc3_output_array :: !(ST2Array r w i a)
}
instance Instrument tc () ()
(EmitST2Array i a r w Off Off Off tc) where
createInstrument _ _ () =
wrapInstrument $
EmitST2Array
{ setBaseInternal = \Off -> return ()
, emitInternal = \Off -> return ()
, emitListInternal = \Off Off -> return ()
, getIndexInternal = return Off
, getResultInternal = return Off
}
instance Num i =>
Instrument tc (CounterTC1 i r) ()
(EmitST2Array i a r w On Off Off tc) where
createInstrument _ updateCtx () =
wrapInstrument $
EmitST2Array
{ setBaseInternal = \Off ->
return ()
, emitInternal = \Off ->
mkMultiPass $
do _ <- updateCtx incrCounterTC1
return ()
, emitListInternal = \(On n) Off ->
mkMultiPass $
do _ <- updateCtx (addkCounterTC1 (fromIntegral n))
return ()
, getIndexInternal =
return Off
, getResultInternal =
return Off
}
instance Num i =>
Instrument tc (CounterTC2 i r) (GC2 r w i)
(EmitST2Array i a r w On On Off tc) where
createInstrument st2ToMP updateCtx gc =
wrapInstrument $
EmitST2Array
{ setBaseInternal = \(On base) ->
mkMultiPassPrologue $
st2ToMP $ writeST2Ref (gc2_base gc) base
, emitInternal = \Off ->
mkMultiPass $
do _ <- updateCtx incrCounterTC2
return ()
, emitListInternal = \(On n) Off ->
mkMultiPass $
do _ <- updateCtx (addkCounterTC2 (fromIntegral n))
return ()
, getIndexInternal =
mkMultiPass $
do counter <- updateCtx id
base <- st2ToMP $ readST2Ref (gc2_base gc)
return (On (base + counterVal2 counter))
, getResultInternal =
return Off
}
instance (Ix i, Num i) =>
Instrument tc (CounterTC2 i r) (GC3 r w i a)
(EmitST2Array i a r w On On On tc) where
createInstrument st2ToMP updateCtx gc =
wrapInstrument $
EmitST2Array
{ setBaseInternal = \(On base) ->
mkMultiPassPrologue $
st2ToMP $ writeST2Ref (gc3_base gc) base
, emitInternal = \(On x) ->
mkMultiPass $
do base <- st2ToMP $ readST2Ref (gc3_base gc)
counter <- updateCtx incrCounterTC2
let k = base + counterVal2 counter
let xs = gc3_output_array gc
st2ToMP $ writeST2Array xs k x
, emitListInternal = \(On n) (On ys) ->
assert (n == length ys) $
mkMultiPass $
do base <- st2ToMP $ readST2Ref (gc3_base gc)
counter <- updateCtx (addkCounterTC2 (fromIntegral n))
let k = base + counterVal2 counter
sequence_
[ let k' = k + fromIntegral i in
let xs = gc3_output_array gc in
st2ToMP $ writeST2Array xs k' y
| (i,y) <- zip [0 .. n1] ys
]
, getIndexInternal =
mkMultiPass $
do base <- st2ToMP $ readST2Ref (gc3_base gc)
counter <- updateCtx id
return (On (base + counterVal2 counter))
, getResultInternal =
return $ On $ gc3_output_array gc
}
instance BackTrack r w (CounterTC2 i r) (GC2 r w i)
instance BackTrack r w (CounterTC2 i r) (GC3 r w i a)
instance Num i => NextGlobalContext r w tc () (GC2 r w i) where
nextGlobalContext _ _ _ () =
do base <- newST2Ref 0
return $ GC2
{ gc2_base = base
}
instance (Ix i, Num i) =>
NextGlobalContext r w (CounterTC1 i r) (GC2 r w i)
(GC3 r w i a) where
nextGlobalContext _ _ counter gc =
do base <- readST2Ref (gc2_base gc)
let n = base + counterVal1 counter
xs <- newST2Array_ (base, n1)
return $ GC3
{ gc3_base = gc2_base gc
, gc3_output_array = xs
}
instance NextGlobalContext r w tc (GC2 r w i) (GC2 r w i) where
nextGlobalContext _ _ _ gc =
return gc
instance (Ix i, Num i) =>
NextGlobalContext r w (CounterTC2 i r) (GC2 r w i)
(GC3 r w i a) where
nextGlobalContext _ _ counter gc =
do base <- readST2Ref (gc2_base gc)
let n = base + counterVal2 counter
xs <- newST2Array_ (base, n1)
return $ GC3
{ gc3_base = gc2_base gc
, gc3_output_array = xs
}
instance NextGlobalContext r w (CounterTC2 i r)
(GC3 r w i a) (GC3 r w i a)
where
nextGlobalContext _ _ _ gc =
return gc
instance NextGlobalContext r w (CounterTC2 i r)
(GC3 r w i a) (GC2 r w i)
where
nextGlobalContext _ _ _ gc =
return $ GC2 { gc2_base = gc3_base gc }