Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
978afe6d
Commit
978afe6d
authored
Apr 09, 2013
by
ian@well-typed.com
Browse files
Use the standard state monad transformer in GHCi
parent
91a036fa
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/ByteCodeAsm.lhs
View file @
978afe6d
...
...
@@ -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
execState
T
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 -> State
T
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 <-
S
tate $ \(st_i0,st_l0,st_p0) ->
do
w <-
s
tate $ \(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 <-
S
tate $ \(st_i0,st_l0,st_p0) ->
do
w <-
s
tate $ \(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
S
tate $ \(st_i0,st_l0,st_p0) ->
do
s
tate $ \(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
...
...
compiler/ghci/ByteCodeItbls.lhs
View file @
978afe6d
...
...
@@ -15,7 +15,6 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
, StgInfoTable(..)
, State(..), runState, evalState, execState, MonadT(..)
) where
#include "HsVersions.h"
...
...
@@ -29,11 +28,11 @@ import Type ( flattenRepType, repType, typePrimRep )
import StgCmmLayout ( mkVirtHeapOffsets )
import Util
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Foreign
import Foreign.C
import Control.Monad ( liftM )
import GHC.Exts ( Int(I#), addr2Int# )
import GHC.Ptr ( Ptr(..) )
\end{code}
...
...
@@ -289,7 +288,7 @@ sizeOfConItbl conInfoTable
pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-> IO ()
pokeConItbl dflags wr_ptr ex_ptr itbl
= evalState (castPtr wr_ptr) $ do
=
flip
evalState
T
(castPtr wr_ptr) $ do
#ifdef GHCI_TABLES_NEXT_TO_CODE
store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags))
#endif
...
...
@@ -332,7 +331,7 @@ instance Storable StgInfoTable where
= SIZEOF_VOID_P
poke a0 itbl
= evalState (castPtr a0)
=
flip
evalState
T
(castPtr a0)
$ do
#ifndef GHCI_TABLES_NEXT_TO_CODE
store (entry itbl)
...
...
@@ -346,7 +345,7 @@ instance Storable StgInfoTable where
#endif
peek a0
= evalState (castPtr a0)
=
flip
evalState
T
(castPtr a0)
$ do
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry' <- load
...
...
@@ -375,34 +374,13 @@ instance Storable StgInfoTable where
fieldSz :: Storable b => (a -> b) -> a -> Int
fieldSz sel x = sizeOf (sel x)
newtype State s m a = State (s -> m (s, a))
instance Monad m => Monad (State s m) where
return a = State (\s -> return (s, a))
State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
fail str = State (\_ -> fail str)
class (Monad m, Monad (t m)) => MonadT t m where
lift :: m a -> t m a
instance Monad m => MonadT (State s) m where
lift m = State (\s -> m >>= \a -> return (s, a))
runState :: Monad m => s -> State s m a -> m (s, a)
runState s (State m) = m s
evalState :: Monad m => s -> State s m a -> m a
evalState s m = liftM snd (runState s m)
execState :: Monad m => s -> State s m a -> m s
execState s m = liftM fst (runState s m)
type PtrIO = State (Ptr Word8) IO
type PtrIO = StateT (Ptr Word8) IO
advance :: Storable a => PtrIO (Ptr a)
advance = State adv where
adv addr = case castPtr addr of { addrCast -> return
(addr `plusPtr` sizeOfPointee addrCast, addrCast) }
advance = state adv
where adv addr = case castPtr addr of
addrCast ->
(addrCast, addr `plusPtr` sizeOfPointee addrCast)
sizeOfPointee :: (Storable a) => Ptr a -> Int
sizeOfPointee addr = sizeOf (typeHack addr)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment