From 897fb17dd6a045a7056e6d6babbbb24748f698f6 Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Sat, 9 Dec 2017 10:48:58 +0100
Subject: Initial

---
 vm.hs | 99 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)
 create mode 100644 vm.hs

(limited to 'vm.hs')

diff --git a/vm.hs b/vm.hs
new file mode 100644
index 0000000..10c084f
--- /dev/null
+++ b/vm.hs
@@ -0,0 +1,99 @@
+module VM(vmRun) where
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict ((!))
+import qualified System.IO.Error as IO
+import Debug.Trace
+
+import AST
+import Intermediate
+
+
+data Info = Info (Map.Map Int BB) (Map.Map Name GlobFuncDef)
+
+type TempMap = Map.Map Int RunValue
+
+data State = State TempMap ([RunValue], [RunValue])
+
+data RunValue = RClosure Name [RunValue] | RValue Value
+  deriving Show
+
+kErrorExit :: String
+kErrorExit = "VM:exit"
+
+vmRun :: IRProgram -> IO ()
+vmRun (IRProgram bbs gfds []) =
+    let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs]
+        info = Info bbmap gfds
+        state = State Map.empty ([], [])
+    in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler
+vmRun _ = undefined
+
+vmErrorHandler :: IOError -> IO ()
+vmErrorHandler e =
+    if IO.isUserError e && IO.ioeGetErrorString e == kErrorExit then return () else IO.ioError e
+
+vmRunBB :: Info -> State -> BB -> IO (RunValue, State)
+vmRunBB info state (BB _ inss term) = do
+    state' <- foldM (vmRunInstr info) state inss
+    vmRunTerm info state' term
+
+vmRunInstr :: Info -> State -> Instruction -> IO State
+-- vmRunInstr _ _ ins | traceShow ins False = undefined
+vmRunInstr info@(Info bbmap gfds) state@(State tmap (args, closure)) (dest, instr) = case instr of
+    IAssign ref -> return (assignRef state dest (findRef tmap ref))
+    IParam i -> return (assignRef state dest (args !! i))
+    IClosure i -> return (assignRef state dest (closure !! i))
+    IData _ -> undefined
+    ICallC cl as -> case findRef tmap cl of
+        RClosure clname clvals -> case Map.lookup clname gfds of
+            Just (GlobFuncDef b _ _) ->
+                let Just bb = Map.lookup b bbmap
+                in do
+                    -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as))
+                    (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb
+                    return (assignRef state dest rv)
+            Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as))
+        _ -> error "VM: Cannot call non-closure object"
+    IAllocClo name clrefs -> return (assignRef state dest (RClosure name (map (findRef tmap) clrefs)))
+    IDiscard _ -> return state
+
+vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State)
+vmRunTerm info@(Info bbmap gfds) state@(State tmap (args, closure)) term = case term of
+    IBr ref b1 b2 -> vmRunBB info state . (bbmap !) $ if truthy (findRef tmap ref) then b1 else b2
+    IJmp b -> vmRunBB info state (bbmap ! b)
+    IRet ref -> return (findRef tmap ref, state)
+    IExit -> IO.ioError (IO.userError kErrorExit)
+    IUnknown -> undefined
+
+findRef :: TempMap -> Ref -> RunValue
+findRef _ (RConst n) = RValue (VNum n)
+findRef tmap (RTemp i) = fromJust (Map.lookup i tmap)
+findRef _ (RSClo name) = RClosure name []
+findRef _ RNone = error "VM: None ref used"
+
+assignRef :: State -> Ref -> RunValue -> State
+assignRef (State tmap pair) (RTemp i) rv = State (Map.insert i rv tmap) pair
+assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned"
+
+vmRunBuiltin :: Name -> [RunValue] -> IO RunValue
+-- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined
+vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RValue (VList []))
+vmRunBuiltin "<=" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (fromEnum (a <= b))))
+vmRunBuiltin "+" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a + b)))
+vmRunBuiltin "-" [RValue (VNum a), RValue (VNum b)] = return (RValue (VNum (a - b)))
+vmRunBuiltin "car" [RValue (VList (a:_))] = return (RValue a)
+vmRunBuiltin "cdr" [RValue (VList (_:a))] = return (RValue (VList a))
+vmRunBuiltin name args = error (name ++ " " ++ show args)
+
+printshow :: RunValue -> String
+printshow (RValue (VString str)) = str
+printshow (RValue value) = show value
+printshow (RClosure _ _) = "[closure]"
+
+truthy :: RunValue -> Bool
+truthy (RValue (VNum n)) = n /= 0
+truthy _ = True
-- 
cgit v1.2.3-54-g00ecf