1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
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 System.IO
import qualified System.IO.Error as IO
import AST
import Intermediate
data Info =
Info (Map.Map Int BB) -- basic blocks
(Map.Map Name GlobFuncDef) -- global functions
[Value] -- data table
type TempMap = Map.Map Int RunValue
data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -})
-- TODO: are more constructors from Value needed?
data RunValue
= RVClosure Name [RunValue]
| RVList [RunValue]
| RVNum Int
| RVString String
| RVQuoted RunValue
| RVName Name
deriving Show
kErrorExit :: String
kErrorExit = "VM:exit"
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 ([], [])
in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler
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 datas) state@(State tmap (args, 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))
else error $ show closure ++ ", " ++ show i ++ ", param-out-of-range"
IClosure i ->
if i < length closure then return (assignRef state dest (closure !! i))
else error $ show closure ++ ", " ++ show i ++ ", closure-out-of-range"
IData i ->
if i < length datas then return (assignRef state dest (toRunValue (datas !! i)))
else error "data-out-of-range"
ICallC cl as ->
-- trace ("callc " ++ show (findRef tmap cl) ++ " " ++ show (map (findRef tmap) as)) $
case findRef tmap cl of
RVClosure 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))
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
IFunctionEntry -> return state
IApplicationEntry -> return state
vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State)
vmRunTerm info@(Info bbmap _ _) state@(State 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)
IExit -> IO.ioError (IO.userError kErrorExit)
IUnknown -> undefined
findRef :: TempMap -> Ref -> RunValue
findRef _ (RConst n) = RVNum n
findRef tmap (RTemp i) = fromJust (Map.lookup i tmap)
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 _ 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 (RVList [])
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
_ -> throw "Empty list in 'car'"
vmRunBuiltin "cdr" [RVList l] = case l of
_ : a -> return (RVList a)
_ -> throw "Empty list in 'cdr'"
vmRunBuiltin "list" values = return (RVList values)
vmRunBuiltin name args = error (name ++ " " ++ show args)
printshow :: RunValue -> String
printshow (RVString str) = str
printshow (RVList values) = show values
printshow (RVNum i) = show i
printshow (RVQuoted value) = '\'' : show value
printshow (RVClosure _ _) = "[closure]"
printshow (RVName name) = name
truthy :: RunValue -> Bool
truthy (RVNum n) = n /= 0
truthy _ = True
toRunValue :: Value -> RunValue
toRunValue (VList values) = RVList (map toRunValue values)
toRunValue (VNum i) = RVNum i
toRunValue (VString s) = RVString s
toRunValue (VQuoted value) = RVQuoted (toRunValue value)
toRunValue (VName name) = RVName name
toRunValue _ = undefined
throw :: String -> IO a
throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit)
|
