summaryrefslogtreecommitdiff
path: root/compiler/ghci/ByteCodeAsm.lhs
diff options
context:
space:
mode:
authorIan Lynagh <ian@well-typed.com>2013-04-09 12:02:07 +0100
committerIan Lynagh <ian@well-typed.com>2013-04-09 13:15:12 +0100
commit978afe6df28e2bc1ea68f663e6c914cb267f16c3 (patch)
tree83dd1a038845861b6692374f1190647357f96be5 /compiler/ghci/ByteCodeAsm.lhs
parent91a036fae63fb9b6fc346137b70745c63bc388e3 (diff)
downloadhaskell-978afe6df28e2bc1ea68f663e6c914cb267f16c3.tar.gz
Use the standard state monad transformer in GHCi
Diffstat (limited to 'compiler/ghci/ByteCodeAsm.lhs')
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs18
1 files changed, 10 insertions, 8 deletions
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index b63778c801..955119768d 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -37,6 +37,8 @@ import Util
import Control.Monad
import Control.Monad.ST ( runST )
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State.Strict
import Data.Array.MArray
import Data.Array.Unboxed ( listArray )
@@ -151,7 +153,7 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d
-- pass 2: run assembler and generate instructions, literals and pointers
let initial_state = (emptySS, emptySS, emptySS)
- (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm dflags long_jumps env asm
+ (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
-- precomputed size should be equal to final size
ASSERT (n_insns == sizeSS final_insns) return ()
@@ -245,20 +247,20 @@ largeOp long_jumps op = case op of
LabelOp _ -> long_jumps
-- LargeOp _ -> True
-runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> State AsmState IO a
+runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
runAsm dflags long_jumps e = go
where
go (NullAsm x) = return x
go (AllocPtr p_io k) = do
p <- lift p_io
- w <- State $ \(st_i0,st_l0,st_p0) -> do
+ w <- state $ \(st_i0,st_l0,st_p0) ->
let st_p1 = addToSS st_p0 p
- return ((st_i0,st_l0,st_p1), sizeSS st_p0)
+ in (sizeSS st_p0, (st_i0,st_l0,st_p1))
go $ k w
go (AllocLit lits k) = do
- w <- State $ \(st_i0,st_l0,st_p0) -> do
+ w <- state $ \(st_i0,st_l0,st_p0) ->
let st_l1 = addListToSS st_l0 lits
- return ((st_i0,st_l1,st_p0), sizeSS st_l0)
+ in (sizeSS st_l0, (st_i0,st_l1,st_p0))
go $ k w
go (AllocLabel _ k) = go k
go (Emit w ops k) = do
@@ -271,9 +273,9 @@ runAsm dflags long_jumps e = go
expand (LabelOp w) = expand (Op (e w))
expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
-- expand (LargeOp w) = largeArg dflags w
- State $ \(st_i0,st_l0,st_p0) -> do
+ state $ \(st_i0,st_l0,st_p0) ->
let st_i1 = addListToSS st_i0 (opcode : words)
- return ((st_i1,st_l0,st_p0), ())
+ in ((), (st_i1,st_l0,st_p0))
go k
type LabelEnvMap = Map Word16 Word