ewe-0.1.0.43: src/Language/EWE/VM.hs
module Language.EWE.VM(runVM,execVM) where
import Language.EWE.AbsSyn
import Language.EWE.Utils(emptyProg, equates, stms)
import qualified Data.List as L
import qualified Data.Maybe as M
import qualified Data.Map.Strict as Map
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Class(lift)
import Data.Char (ord,chr)
import System.IO(hFlush, stdout,hPutStrLn,hPutStr)
import System.Exit(exitWith,ExitCode(..))
-- type Memory = [(Int,Int)]
type Memory = Map.Map Int Int
emptyMemory :: Memory
emptyMemory = Map.empty
-- emptyMemory :: Memory
-- emptyMemory = []
type PC = Int
initPC :: PC
initPC = 0
data StateVM = StVM { mem :: Memory
, prg :: Prog
, pc :: PC
} deriving (Show)
emptyStateVM = StVM { mem = emptyMemory
, pc = initPC
, prg = emptyProg
}
type StateVMM = StateT StateVM IO
runVM :: Prog -> IO ()
runVM prg = evalStateT evalVM (initVM prg)
execVM :: Prog -> IO StateVM
execVM prg = execStateT evalVM (initVM prg)
evalVM :: StateVMM ()
evalVM = do
-- lift $ hPutStrLn stdout "Iniciando maquina"
evalInstr
initVM :: Prog -> StateVM
initVM p = emptyStateVM { prg = p }
mRef :: MRef -> Equates -> Int
mRef (MRefI i) _ = i
mRef (MRefId s) m = M.fromMaybe (error $ "Internal error: memory reference " ++ s ++ " not found ") $ L.lookup s m
-- outMem :: Int -> Memory -> (Memory,Int)
-- outMem r m = M.maybe ((r,0):m, 0) ((,) m) (L.lookup r m)
outMem :: Int -> Memory -> (Memory,Int)
outMem r m = M.maybe (Map.insert r 0 m, 0) ((,) m) (Map.lookup r m)
-- inMem :: Int -> Int -> Memory -> Memory
-- inMem i v m = (i,v):m
inMem :: Int -> Int -> Memory -> Memory
inMem = Map.insert
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''
evalInstr
(IWI _) -> do
let (st'',i) = execIWI ci st
lift $ putStrLn (show i)
put st''
evalInstr
(IRS _ _) -> do
s <- lift $ readStr "Enter an string:"
let st'' = execIRS s ci st
put st''
evalInstr
(IWS _) -> do
let (st'',s) = execIWS ci st
lift $ putStrLn (show s)
put st''
evalInstr
(IH) -> return ()
(IB) -> return ()
else do put st'
evalInstr
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) st =
let base = mRef mr (ge st)
total = base + length s
st' = moveStrInMem s base total st
in st { mem = mem st'
, pc = incrPC st
}
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 mrb 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 mrb 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
m = mem state
startP = mRef mr1 ge'
lenP = mRef mr2 ge'
(m', v) = outMem lenP m
state' = state { mem = m' }
state'' = moveStrInMem s startP (startP + v) state'
in if v >= 0
then state'' { pc = incrPC state }
else error "IRS len is negative"
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 { mem = inMem st 0 (mem 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
readStr :: String -> IO String
readStr msg = do
putStr (msg ++ "> ")
hFlush stdout
s <- getLine
-- putStrLn s
return $ s