VMMonad.hs 6.91 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3
module VMMonad (Mnd,
4 5 6 7 8 9
                run, lift,
                rfetch, rstore, rpush, rpop,
                mfetch, mstore, mstoren, mreserve,
                cload, cfind, cstore, cfetch,
                lstore, lfetch,
                optset, opttell,
10
                setProfileHandle, getProfileHandle,
11 12
                setDisplayHandle, getDisplayHandle,
                setTraceHandle, getTraceHandle,
13
                profinc, profresult)
14 15
where

16
import Control.Applicative (Applicative, pure, (<*>))
17 18
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Map (Map, empty, fromList, toList, insert, findWithDefault)
19
import System.IO (Handle)
20 21 22 23 24 25 26

import Ir
import Cpu (Registry)
import Code (Code)
import Level (Level)
import Memory (Memory)
import Annotation (Ann)
27
import Opt (OptVal)
28
import Control.Monad (ap, liftM)
29
-- Control.Monad.Fail import has become redundant in GHC 8.8+
30
import qualified Control.Monad.Fail as Fail
31
import qualified Cpu (initialize, rfetch, rstore, rpush, rpop)
32
import qualified Code (initialize, cload, cfind, cstore, cfetch)
33 34 35 36 37
import qualified Level (initialize, lfetch, lstore)
import qualified Memory (initialize, mfetch, mstore, mstoren, mreserve)

data State =
    State { reg :: Registry,
38 39 40 41
            mem :: Memory,
            code :: Code,
            level :: Level,
            option :: Map String OptVal,
42 43
            displayHandle :: Maybe Handle,
            traceHandle :: Maybe Handle,
44
            profileHandle :: Maybe Handle,
45
            profile :: ! (Map String Int) }
46

47 48
newtype Mnd a =
    Mnd (IORef State -> IO a)
49

50 51 52 53 54
instance Functor Mnd where
    fmap = liftM

instance Applicative Mnd where
    pure x =
55 56
        Mnd $ \ _ ->
            return x
57

58 59 60 61 62
    (<*>) = ap

instance Monad Mnd where
    return = pure

63 64
    (Mnd c) >>= f =
        Mnd $ \ r ->
65
            do x <- c r
66
               case f x of (Mnd c') -> c' r
67

68 69 70 71
#if !(MIN_VERSION_base(4,13,0))
  -- Monad(fail) is removed in GHC 8.8+
  fail = Fail.fail
#endif
72 73 74 75

instance Fail.MonadFail Mnd where
    fail = error "fail: invalid pattern matching"

76 77
run :: Mnd a -> IO a
run (Mnd c) =
78 79 80 81
    do m <- Memory.initialize 65536 16384
       r <- newIORef (s m)
       c r
    where s m = State { mem = m,
82 83 84 85
                        reg = Cpu.initialize 65536 16384,
                        code = Code.initialize,
                        level = Level.initialize,
                        option = empty,
86 87
                        displayHandle = Nothing,
                        traceHandle = Nothing,
88
                        profileHandle = Nothing,
89 90 91 92 93 94 95 96
                        profile = fromList [("temp"      , 0),
                                            ("binop"     , 0),
                                            ("mem"       , 0),
                                            ("call"      , 0),
                                            ("move(temp)", 0),
                                            ("move(mem)" , 0),
                                            ("jump"      , 0),
                                            ("cjump"     , 0)] }
97 98 99 100

lift :: IO a -> Mnd a
lift x =
    Mnd $ \ _ ->
101 102
        do r <- x
           return r
103 104 105 106

rfetch :: String -> Mnd Int
rfetch k =
    Mnd $ \ r ->
107 108
        do s <- readIORef r
           return $ Cpu.rfetch (reg s) k
109 110 111 112

rstore :: String -> Int -> Mnd ()
rstore k i =
    Mnd $ \ r ->
113 114
        do s <- readIORef r
           writeIORef r $ s { reg = Cpu.rstore (reg s) k i }
115 116 117 118

rpush :: Mnd ()
rpush =
    Mnd $ \ r ->
119 120
        do s <- readIORef r
           writeIORef r $ s { reg = Cpu.rpush (reg s) }
121 122 123 124

rpop :: Mnd ()
rpop =
    Mnd $ \ r ->
125 126
        do s <- readIORef r
           writeIORef r $ s { reg = Cpu.rpop (reg s) }
127 128 129 130

mfetch :: Int -> Mnd Int
mfetch a =
    Mnd $ \ r ->
131 132
        do s <- readIORef r
           Memory.mfetch (mem s) a
133 134 135 136

mstore :: Int -> Int -> Mnd ()
mstore a i =
    Mnd $ \ r ->
137 138
        do s <- readIORef r
           Memory.mstore (mem s) a i
139 140 141 142

mstoren :: Int -> [Int] -> Mnd ()
mstoren a is =
    Mnd $ \ r ->
143 144
        do s <- readIORef r
           Memory.mstoren (mem s) a is
145 146 147 148

mreserve :: Int -> Mnd Int
mreserve n =
    Mnd $ \ r ->
149 150
        do s <- readIORef r
           Memory.mreserve (mem s) n
151

152 153
cload :: String -> [Stm Ann] -> Mnd ()
cload a c =
154
    Mnd $ \ r ->
155 156
        do s <- readIORef r
           writeIORef r $ s { code = Code.cload (code s) a c }
157 158 159 160

cfind :: String -> Mnd [Stm Ann]
cfind a =
    Mnd $ \ r ->
161 162
        do s <- readIORef r
           return $ Code.cfind (code s) a
163 164 165 166

cstore :: String -> Int -> Mnd ()
cstore label pointer =
    Mnd $ \ reference ->
167 168
        do state <- readIORef reference
           writeIORef reference $ state { code = Code.cstore (code state) label pointer }
169 170 171 172

cfetch :: String -> Mnd Int
cfetch label =
    Mnd $ \ reference ->
173 174
        do state <- readIORef reference
           return $ Code.cfetch (code state) label
175 176 177 178

lstore :: String -> Int -> Mnd ()
lstore label depth =
    Mnd $ \ reference ->
179 180
        do state <- readIORef reference
           writeIORef reference $ state { level = Level.lstore (level state) label depth }
181 182 183 184

lfetch :: String -> Mnd Int
lfetch label =
    Mnd $ \ reference ->
185 186
        do state <- readIORef reference
           return $ Level.lfetch (level state) label
187

188
optset :: String -> OptVal -> Mnd ()
189 190
optset name value =
    Mnd $ \ reference ->
191 192
        do state <- readIORef reference
           writeIORef reference $ state { option = insert name value (option state) }
193

194
opttell :: String -> OptVal -> Mnd OptVal
195 196
opttell name value =
    Mnd $ \ reference ->
197 198
        do state <- readIORef reference
           return $ findWithDefault value name (option state)
199

200 201 202 203 204 205 206 207 208 209 210 211
setProfileHandle :: Handle -> Mnd ()
setProfileHandle h =
    Mnd $ \ reference ->
        do state <- readIORef reference
           writeIORef reference $ state { profileHandle = Just h }

getProfileHandle :: Mnd (Maybe Handle)
getProfileHandle =
    Mnd $ \ reference ->
        do state <- readIORef reference
           return $ (profileHandle state)

212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
setDisplayHandle :: Handle -> Mnd ()
setDisplayHandle h =
    Mnd $ \ reference ->
        do state <- readIORef reference
           writeIORef reference $ state { displayHandle = Just h }

getDisplayHandle :: Mnd (Maybe Handle)
getDisplayHandle =
    Mnd $ \ reference ->
        do state <- readIORef reference
           return $ (displayHandle state)

setTraceHandle :: Handle -> Mnd ()
setTraceHandle h =
    Mnd $ \ reference ->
        do state <- readIORef reference
           writeIORef reference $ state { traceHandle = Just h }

getTraceHandle :: Mnd (Maybe Handle)
getTraceHandle =
    Mnd $ \ reference ->
        do state <- readIORef reference
           return $ (traceHandle state)

236 237 238
profinc :: String -> Mnd ()
profinc key =
    Mnd $ \ reference ->
239 240
        do state <- readIORef reference
           writeIORef reference $ state { profile = insert key (findWithDefault 0 key (profile state) + 1 ) (profile state) }
241

242
profresult :: Mnd (Map String Int)
243 244
profresult =
    Mnd $ \ reference ->
245 246
        do state <- readIORef reference
           return $ profile state