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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
module VM(vmRun) where
import Control.Monad
import Data.Char
import Data.List
import qualified Data.Map.Strict as Map
import qualified Data.IntMap.Strict as IMap
import System.IO
import qualified System.IO.Error as IO
-- import Debug.Trace
import AST
import qualified DString as DS
import Intermediate
data Info =
Info (Map.Map Int BB) -- basic blocks
(Map.Map Name GlobFuncDef) -- global functions
[Value] -- data table
type TempMap = IMap.IntMap RunValue
data State = State
{ sTempMap :: TempMap
, sArgs :: [RunValue] {- current arguments -}
, sCloVals :: [RunValue] {- current closure -}
, sHandles :: IMap.IntMap Handle
, sUniq :: Int
}
-- TODO: are more constructors from Value needed?
data RunValue
= RVClosure Name [RunValue]
| RVList [RunValue]
| RVNum Int
| RVString DS.DString
| 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 IMap.empty [] [] (IMap.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0
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 _ _ datas) state (dest, instr) = case instr of
IAssign ref ->
return (assignRef state dest (findRef (sTempMap state) ref))
IParam i ->
let args = sArgs state
in if i < length args then return (assignRef state dest (args !! i))
else error $ show args ++ ", " ++ show i ++ ", param-out-of-range"
IClosure i ->
let closure = sCloVals state
in 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 -> do
(rv, state') <- callClosure info state cl as
return (assignRef state' dest rv)
IAllocClo name clrefs ->
let cloVals = (map (findRef (sTempMap state)) clrefs)
in return (assignRef state dest (RVClosure name cloVals))
IDiscard _ ->
return state -- TODO: erase temporary from state for IDiscard (RTemp i)
vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State)
vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) term = case term of
IBr ref b1 b2 -> vmRunBB info state . (bbmap Map.!) $ if truthy (findRef tmap ref) then b1 else b2
IJmp b -> vmRunBB info state (bbmap Map.! b)
IRet ref -> return (findRef tmap ref, state)
ITailC cl as -> callClosure info state cl as
IExit -> IO.ioError (IO.userError kErrorExit)
IUnknown -> undefined
findRef :: TempMap -> Ref -> RunValue
findRef _ (RConst n) = RVNum n
findRef tmap (RTemp i) = case IMap.lookup i tmap of
Nothing -> error "Use of declared but uninitialised variable"
Just v -> v
findRef _ (RSClo name) = RVClosure name []
findRef _ RNone = error "VM: None ref used"
assignRef :: State -> Ref -> RunValue -> State
assignRef state (RTemp i) rv = state { sTempMap = IMap.insert i rv (sTempMap state) }
assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned"
callClosure :: Info -> State -> Ref -> [Ref] -> IO (RunValue, State)
callClosure info@(Info bbmap gfds _) state@(State { sTempMap = tmap }) cl as =
case findRef tmap cl of
RVClosure clname clvals -> case Map.lookup clname gfds of
Just (GlobFuncDef b _ _) -> do
(rv, state') <- vmRunBB info (state { sArgs = map (findRef tmap) as, sCloVals = clvals })
(bbmap Map.! b)
-- TODO: we restore tempmap here after the call, and that's
-- _really_ dodgy. I think it works because we never mutate
-- a reference after first assigning it, and without it
-- recursion fails, but it feels ugly. A proper solution
-- would be to further compile the IR down to something
-- that stores its values on a stack, so that recursion is
-- handled automatically.
return (rv, state' { sArgs = sArgs state, sCloVals = sCloVals state, sTempMap = sTempMap state })
Nothing ->
-- Take 'tail as' to skip the first self-link argument
vmRunBuiltin state clname (map (findRef tmap) (tail as))
obj -> error $ "VM: Cannot call non-closure object: " ++ show obj
vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State)
-- vmRunBuiltin _ name args | trace (name ++ " " ++ show args) False = undefined
vmRunBuiltin state "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [], state)
vmRunBuiltin state "=" [a, b] = case equalOp a b of
Left err -> throw err
Right True -> return (RVNum 1, state)
Right False -> return (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)
vmRunBuiltin state "*" [RVNum a, RVNum b] = return (RVNum (a * b), state)
vmRunBuiltin state "/" [RVNum a, RVNum b] = return (RVNum (a `div` b), state)
vmRunBuiltin state "mod" [RVNum a, RVNum b] = return (RVNum (a `mod` b), state)
vmRunBuiltin state "null?" [v] = return (RVNum (case v of { RVList [] -> 1; _ -> 0 }), state)
vmRunBuiltin state "car" [RVList l] = case l of
a : _ -> return (a, state)
_ -> throw "Empty list in 'car'"
vmRunBuiltin state "cdr" [RVList l] = case l of
_ : a -> return (RVList a, state)
_ -> throw "Empty list in 'cdr'"
vmRunBuiltin state "list" values = return (RVList values, state)
vmRunBuiltin state "cons" [val, RVList l] = return (RVList (val : l), state)
vmRunBuiltin state "sys-open-file" [RVNum modenum, RVString path] = do
let mode = [ReadMode, WriteMode] !! modenum
fid = sUniq state
handle <- openFile (DS.unpack path) mode
return (RVNum fid, state { sHandles = IMap.insert fid handle (sHandles state), sUniq = fid + 1 })
vmRunBuiltin state "sys-close-file" [RVNum fid] = do
hClose (sHandles state IMap.! fid)
return (RVList [], state { sHandles = IMap.delete fid (sHandles state) })
vmRunBuiltin state "sys-get-char" [RVNum fid] = do
let h = sHandles state IMap.! fid
eof <- hIsEOF h
if eof
then return (RVList [], state)
else hGetChar h >>= \ch -> return (RVString (DS.singleton ch), state)
vmRunBuiltin state "sys-put-string" [RVNum fid, RVString str] = do
DS.hPutStr (sHandles state IMap.! fid) str
return (RVList [], state)
vmRunBuiltin state "sys-flush" [RVNum fid] = do
hFlush (sHandles state IMap.! fid)
return (RVList [], state)
vmRunBuiltin state "sys-stdin" [] = return (RVNum (-1), state)
vmRunBuiltin state "sys-stdout" [] = return (RVNum (-2), state)
vmRunBuiltin state "sys-stderr" [] = return (RVNum (-3), state)
vmRunBuiltin state "length" [RVString str] = return (RVNum (DS.length str), state)
vmRunBuiltin state "substr" [RVNum idx, RVNum len, RVString str] =
let s = (if len >= 0 then DS.take len else id) (DS.drop idx str)
in return (RVString s, state)
vmRunBuiltin state "ord" [RVString str] = return (RVNum (if DS.null str then 0 else ord (DS.head str)), state)
vmRunBuiltin state "chr" [RVNum num] = return (RVString (DS.singleton (chr num)), state)
vmRunBuiltin state "concat" values
| Just strings <- sequence (map fromRVString values) = return (RVString ({-# SCC builtin_string_concat #-} DS.concat strings), state)
| otherwise = throw "Non-string arguments to 'concat'"
vmRunBuiltin state "type-list?" [value] = return (RVNum (case value of { RVList _ -> 1; _ -> 0 }), state)
vmRunBuiltin state "type-number?" [value] = return (RVNum (case value of { RVNum _ -> 1; _ -> 0 }), state)
vmRunBuiltin state "type-string?" [value] = return (RVNum (case value of { RVString _ -> 1; _ -> 0 }), state)
vmRunBuiltin state "type-quoted?" [value] = return (RVNum (case value of { RVQuoted _ -> 1; _ -> 0 }), state)
vmRunBuiltin state "type-symbol?" [value] = return (RVNum (case value of { RVName _ -> 1; _ -> 0 }), state)
vmRunBuiltin _ "error" values = throw ("error: " ++ intercalate " " (map show values))
vmRunBuiltin _ name args = error (name ++ " " ++ show args)
equalOp :: RunValue -> RunValue -> Either String Bool
equalOp (RVClosure _ _) _ = Left "Cannot compare closures in '='"
equalOp _ (RVClosure _ _) = Left "Cannot compare closures in '='"
equalOp (RVList vs) (RVList ws)
| length vs == length ws = all id <$> sequence (zipWith equalOp vs ws)
| otherwise = Right False
equalOp (RVNum a) (RVNum b) = Right (a == b)
equalOp (RVString s) (RVString t) = Right (s == t)
equalOp (RVQuoted v) (RVQuoted w) = equalOp v w
equalOp (RVName n) (RVName m) = Right (n == m)
equalOp _ _ = Right False
printshow :: RunValue -> String
printshow (RVString str) = DS.unpack str
printshow (RVList values) = "[" ++ intercalate "," (map printshow values) ++ "]"
printshow (RVNum i) = show i
printshow (RVQuoted value) = '\'' : printshow 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 (DS.pack 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)
fromRVString :: RunValue -> Maybe DS.DString
fromRVString (RVString str) = Just str
fromRVString _ = Nothing
|
