From d3a9d62b5866771489cdc9f4e0fced3e7845eb9c Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 14 Nov 2019 16:58:24 +0100 Subject: File I/O --- VM.hs | 61 ++++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 42 insertions(+), 19 deletions(-) (limited to 'VM.hs') 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 '='" -- cgit v1.2.3-70-g09d2