File I/O

2 files changed, 44 insertions, 20 deletions

diff --git a/Compiler.hs b/Compiler.hs
index c8771b9..9f8b595 100644
--- a/Compiler.hs
+++ b/Compiler.hs
@@ -75,7 +75,8 @@ newtype CM a = CM {unCM :: StateT CompState (Except String) a}
 builtinMap :: Map.Map Name ()
 builtinMap = Map.fromList [
     ("+", ()), ("-", ()), ("<=", ()), ("=", ()), ("print", ()),
-    ("list", ()), ("car", ()), ("cdr", ())]
+    ("list", ()), ("car", ()), ("cdr", ()),
+    ("sys-open-file", ()), ("sys-close-file", ()), ("sys-get-char", ()), ("sys-put-string", ())]
 
 bbId :: BB -> Int
 bbId (BB i _ _) = i
diff --git a/VM.hs b/VM.hs
index 12ccf60..ae9dc6f 100644
--- a/VM.hs
+++ b/VM.hs
@@ -20,7 +20,13 @@ data Info =
 
 type TempMap = Map.Map Int RunValue
 
-data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -})
+data State = State
+    { sTempMap :: TempMap
+    , sArgs :: [RunValue] {- current arguments -}
+    , sCloVals :: [RunValue] {- current closure -}
+    , sHandles :: Map.Map Int Handle
+    , sUniq :: Int
+    }
 
 -- TODO: are more constructors from Value needed?
 data RunValue
@@ -39,7 +45,7 @@ vmRun :: IRProgram -> IO ()
 vmRun (IRProgram bbs gfds datas) =
     let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs]
         info = Info bbmap gfds datas
-        state = State Map.empty ([], [])
+        state = State Map.empty [] [] Map.empty 0
     in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler
 
 vmErrorHandler :: IOError -> IO ()
@@ -53,7 +59,7 @@ vmRunBB info state (BB _ inss term) = do
 
 vmRunInstr :: Info -> State -> Instruction -> IO State
 -- vmRunInstr _ _ ins | traceShow ins False = undefined
-vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest, instr) = case instr of
+vmRunInstr info@(Info bbmap gfds datas) state@(State { sTempMap = tmap, sArgs = args, sCloVals = closure }) (dest, instr) = case instr of
     IAssign ref -> return (assignRef state dest (findRef tmap ref))
     IParam i ->
         if i < length args then return (assignRef state dest (args !! i))
@@ -72,15 +78,17 @@ vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest
                     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
+                        (rv, _) <- vmRunBB info (state { sArgs = map (findRef tmap) as, sCloVals = clvals }) bb
                         return (assignRef state dest rv)
-                Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as))
+                Nothing -> do
+                    (rv, state') <- vmRunBuiltin state clname (map (findRef tmap) as)
+                    return (assignRef state' dest rv)
             obj -> error $ "VM: Cannot call non-closure object: " ++ show obj
     IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs)))
     IDiscard _ -> return state
 
 vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State)
-vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of
+vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) 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)
@@ -94,24 +102,39 @@ findRef _ (RSClo name) = RVClosure 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 state (RTemp i) rv = state { sTempMap = Map.insert i rv (sTempMap state) }
 assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned"
 
-vmRunBuiltin :: Name -> [RunValue] -> IO RunValue
+vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State)
 -- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined
-vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [])
-vmRunBuiltin "=" [a, b] = return (if equalOp a b then RVNum 1 else RVNum 0)
-vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b)))
-vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b))
-vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b))
-vmRunBuiltin "car" [RVList l] = case l of
-    a : _ -> return a
+vmRunBuiltin state "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [], state)
+vmRunBuiltin state "=" [a, b] = return (if equalOp a b then RVNum 1 else RVNum 0, state)
+vmRunBuiltin state "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b)), state)
+vmRunBuiltin state "+" [RVNum a, RVNum b] = return (RVNum (a + b), state)
+vmRunBuiltin state "-" [RVNum a, RVNum b] = return (RVNum (a - b), state)
+-- TODO: null?
+vmRunBuiltin state "car" [RVList l] = case l of
+    a : _ -> return (a, state)
     _ -> throw "Empty list in 'car'"
-vmRunBuiltin "cdr" [RVList l] = case l of
-    _ : a -> return (RVList a)
+vmRunBuiltin state "cdr" [RVList l] = case l of
+    _ : a -> return (RVList a, state)
     _ -> throw "Empty list in 'cdr'"
-vmRunBuiltin "list" values = return (RVList values)
-vmRunBuiltin name args = error (name ++ " " ++ show args)
+vmRunBuiltin state "list" values = return (RVList values, state)
+vmRunBuiltin state "sys-open-file" [RVNum modenum, RVString path] = do
+    let mode = [ReadMode, WriteMode] !! modenum
+        fid = sUniq state
+    handle <- openFile path mode
+    return (RVNum fid, state { sHandles = Map.insert fid handle (sHandles state), sUniq = fid + 1 })
+vmRunBuiltin state "sys-close-file" [RVNum fid] = do
+    hClose (sHandles state ! fid)
+    return (RVList [], state { sHandles = Map.delete fid (sHandles state) })
+vmRunBuiltin state "sys-get-char" [RVNum fid] = do
+    ch <- hGetChar (sHandles state ! fid)
+    return (RVString [ch], state)
+vmRunBuiltin state "sys-put-string" [RVNum fid, RVString str] = do
+    hPutStr (sHandles state ! fid) str
+    return (RVList [], state)
+vmRunBuiltin _ name args = error (name ++ " " ++ show args)
 
 equalOp :: RunValue -> RunValue -> Bool
 equalOp (RVClosure _ _) _ = error "Cannot compare closures in '='"