ewe-0.1.0.12: src/Language/EWE/VM.hs
module Language.EWE.VM where
import Language.EWE.AbsSyn
import qualified Data.List as L
import qualified Data.Maybe as M
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Class(lift)
import Data.Char (ord,chr)
import System.IO(hFlush, stdout)
import System.Exit(exitWith,ExitCode(..))
type Memory = [(Int,Int)]
emptyMemory :: Memory
emptyMemory = []
type PC = Int
initPC :: PC
initPC = 0
data StateVM = StVM { mem :: Memory
, prg :: Prog
, pc :: PC
}
type StateVMM = StateT StateVM IO
mRef :: MRef -> Equates -> Int
mRef (MRefI i) _ = i
mRef (MRefId s) m = M.fromMaybe (error "No found") $ L.lookup s m
outMem :: Int -> Memory -> (Memory,Int)
outMem r m = M.maybe ((r,0):m, 0) (\i -> (m,i)) (L.lookup r m)
inMem :: Int -> Int -> Memory -> Memory
inMem = updateM emptyMemory
updateM :: Memory -> Int -> Int -> Memory -> Memory
updateM m r v [] = (r,v):m
updateM m r v (d@(r',_):m') = updateM (d:m) r v m'
incrPC :: StateVM -> Int
incrPC state = (pc state) + 1
ge :: StateVM -> Equates
ge = equates.prg
evalInstr :: StateVMM ()
evalInstr = do
st <- get
let pc' = pc st
prg' = prg st
(Stmt _ ci) = stms prg' !! pc'
st' = execInstr ci st
if (hasSideEffects ci)
then case (ci) of
(IRI _) -> do
i <- lift $ readInt "Enter an integer:"
let st'' = execIRI i ci st
put st''
(IWI _) -> do
let (st'',i) = execIWI ci st
lift $ putStrLn (show i)
put st''
(IRS _ _) -> do
s <- lift $ getLine
let st'' = execIRS s ci st
put st''
(IWS _) -> do
let (st'',s) = execIWS ci st
lift $ putStrLn s
put st''
(IH) -> lift $ exitWith ExitSuccess
(IB) -> lift $ exitWith ExitSuccess
else put st'
execInstr :: Instr -> StateVM -> StateVM
execInstr (INI) state =
state { pc = incrPC state }
execInstr (IMMI mr i) state =
state { mem = inMem (mRef mr (ge state)) i (mem state)
, pc = incrPC state
}
execInstr (IMMS mr s) state =
state { mem = inMem (mRef mr (ge state)) (mRef (MRefId s) (ge state)) (mem state)
, pc = incrPC state
}
execInstr (IMRPC mr i) state =
state { mem = inMem (mRef mr (ge state)) ((pc state) + i) (mem state)
, pc = incrPC state
}
execInstr (SPC mr) state =
state { pc = (mRef mr (ge state))
}
execInstr (IMMM mr1 mr2) state =
let m = mem state
ge' = ge state
(m', v) = outMem (mRef mr2 ge') m
in state { mem = inMem (mRef mr1 ge') v m'
, pc = incrPC state
}
execInstr (IAdd mrr mra mrb) state = comp (+) mrr mra mrb state
execInstr (ISub mrr mra mrb) state = comp (-) mrr mra mrb state
execInstr (IMul mrr mra mrb) state = comp (*) mrr mra mrb state
execInstr (IDiv mrr mra mrb) state = comp (div) mrr mra mrb state
execInstr (IMod mrr mra mrb) state = comp (mod) mrr mra mrb state
execInstr (IMRI mrr mr i) state =
let m = mem state
ge' = ge state
(m',v) = outMem (mRef mr ge') m
(m'', v')= outMem (v + i) m'
in state { mem = inMem (mRef mrr ge') v' m''
, pc = incrPC state
}
execInstr (IMMR mri i mr) state =
let m = mem state
ge' = ge state
(m', v) = outMem (mRef mr ge') m
(m'', v') = outMem (mRef mri ge') m'
in state { mem = inMem (v' + i) v m''
, pc = incrPC state
}
execInstr (IGI i) state =
let prg' = prg state
stms' = stms prg'
l' = length stms'
in state { pc = if (i >= 0 && i < l')
then i else error "Inst Pos not valid"
}
execInstr (IGS s) state =
let prg' = prg state
stms' = stms prg'
i = lookupLabel s stms'
in state { pc = i }
execInstr (IFI mra cond mrb i) state =
let m = mem state
pc' = pc state
ge' = ge state
prg' = prg state
stms' = stms prg'
l' = length stms'
(m',a) = outMem (mRef mra ge') m
(m'',b) = outMem (mRef mra ge') m'
op = fun cond
i' = if (i >= 0 && i < l')
then i else error "Inst Pos not valid in condition"
npc = if a `op` b then i' else pc' + 1
in state { mem = m''
, pc = npc
}
execInstr (IFS mra cond mrb s) state =
let m = mem state
pc' = pc state
ge' = ge state
prg' = prg state
stms' = stms prg'
l' = length stms'
(m',a) = outMem (mRef mra ge') m
(m'',b) = outMem (mRef mra ge') m'
op = fun cond
i = lookupLabel s stms'
npc = if a `op` b then i else pc' + 1
in state { mem = m''
, pc = npc
}
execIRI :: Int -> Instr -> StateVM -> StateVM
execIRI i (IRI mr) state =
state { mem = inMem (mRef mr (ge state)) i (mem state)
, pc = incrPC state
}
execIWI :: Instr -> StateVM -> (StateVM, Int)
execIWI (IWI mr ) state =
let m = mem state
ge' = ge state
(m', v) = outMem (mRef mr ge') m
in (state { mem = m', pc = incrPC state}, v)
execIRS :: String -> Instr -> StateVM -> StateVM
execIRS s (IRS mr1 mr2) state =
let ge' = ge state
startP = mRef mr1 ge'
endP = mRef mr1 ge'
state' = moveStrInMem s startP endP state
in if (startP <= endP)
then state' { pc = incrPC state }
else error "IRS start > end"
moveStrInMem :: String -> Int -> Int -> StateVM -> StateVM
moveStrInMem [] st en state
| st <= en = moveStrInMem [] (st+1) en (state { mem = inMem st 0 (mem state) })
| otherwise = state
moveStrInMem (c:cs) st en state
| st <= en = moveStrInMem cs (st+1) en (state { mem = inMem st (ord c) (mem state) })
| otherwise = state
execIWS :: Instr -> StateVM -> (StateVM, String)
execIWS (IWS mr) state =
let ge' = ge state
start = mRef mr ge'
(state', s) = moveStrOutMem start [] state
in (state' {pc = incrPC state }, s)
moveStrOutMem :: Int -> String -> StateVM -> (StateVM, String)
moveStrOutMem i s state =
let ge' = ge state
m = mem state
(m',v) = outMem i m
in if (v /= 0)
then moveStrOutMem (i+1) (s++[chr(v)]) (state { mem = m'})
else (state, s)
lookupLabel :: String -> Stmts -> Int
lookupLabel = lookupLabel' 0
lookupLabel' :: Int -> String -> Stmts -> Int
lookupLabel' n s [] = error "Label not found"
lookupLabel' n s ((Stmt [] _):stms) = lookupLabel' (n+1) s stms
lookupLabel' n s ((Stmt lbls _):stms)
| s `elem` lbls = n
| otherwise = lookupLabel' (n+1) s stms
fun :: Cond -> (Int -> Int -> Bool)
fun CLET = (<=)
fun CLT = (<)
fun CGET = (>=)
fun CGT = (>)
fun CE = (==)
fun CNE = (/=)
-- comp computes the functions that transform int values
comp :: (Int -> Int -> Int) -> MRef -> MRef -> MRef -> StateVM -> StateVM
comp f mrr mra mrb state =
let m = mem state
ge' = ge state
(m', a) = outMem (mRef mra ge') m
(m'', b) = outMem (mRef mrb ge') m'
in state { mem = inMem (mRef mrr ge') (a `f` b) m''
, pc = incrPC state
}
hasSideEffects :: Instr -> Bool
hasSideEffects (IRI _) = True
hasSideEffects (IWI _) = True
hasSideEffects (IRS _ _) = True
hasSideEffects (IWS _) = True
hasSideEffects (IH) = True
hasSideEffects (IB) = True
hasSideEffects _ = False
readInt :: String -> IO Int
readInt msg = do
putStr (msg ++ "> ")
hFlush stdout
readLn