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
|
implementation module Snug.Compile.Simulate
import StdEnv
import Control.Monad
import Control.Monad.Fail
import Control.Monad.Identity
import Control.Monad.State
import Data.Error
import Data.Functor
import MIPS.MIPS32
import Snug.Compile.ABI
import Snug.Syntax
:: SimulationState =
{ instrs :: ![[Instruction]]
, hp_offset :: !Int
, stack :: ![StackValue]
}
simulate :: ![StackValue] !(Simulator a) -> MaybeError String [Instruction]
simulate stack sim =
execStateT sim initial >>= \state ->
if (length state.stack == length stack)
(pure (flatten (reverse state.instrs)))
(fail "stack size changed")
where
initial =
{ instrs = []
, hp_offset = 0
, stack = stack
}
stackSize :: Simulator Int
stackSize = gets \s -> length s.stack
add :: ![Instruction] -> Simulator ()
add is = modify \s -> {s & instrs=[is:s.instrs]}
push :: StackValue -> Simulator ()
push sv = modify \s -> {s & stack=[sv:s.stack]}
pop :: Simulator StackValue
pop =
getState >>= \{stack} ->
modify (\s -> {s & stack=tl stack}) $> hd stack
write_heap :: !StackValue -> Simulator StackValue
write_heap sv =
getState >>= \{hp_offset} ->
storeStackValue sv hp_offset HeapPtr >>|
modify (\s -> {s & hp_offset=hp_offset+4}) $>
SVRegOffset HeapPtr hp_offset
storeStackValue :: !StackValue !Offset !Register -> Simulator ()
storeStackValue (SVImmediate (Immediate i)) doffset dreg
| i == 0 = add
[ StoreWord R0 doffset dreg
]
| 0 <= i && i < 0x10000 = add
[ OrImmediate (TempImm 0) R0 (Immediate i)
, StoreWord (TempImm 0) doffset dreg
]
| 0 > i && i >= -0x8000 = add
[ AddImmediate Signed (TempImm 0) R0 (Immediate i)
, StoreWord (TempImm 0) doffset dreg
]
| otherwise = add
[ LoadUpperImmediate (TempImm 0) (Immediate (i >> 16))
, OrImmediate (TempImm 0) (TempImm 0) (Immediate (i bitand 0xffff))
, StoreWord (TempImm 0) doffset dreg
]
storeStackValue (SVImmediate imm=:(Address _ _)) doffset dreg = add
[ LoadAddress (TempImm 0) imm
, StoreWord (TempImm 0) doffset dreg
]
storeStackValue (SVRegOffset reg 0) doffset dreg = add
[ StoreWord reg doffset dreg
]
storeStackValue (SVRegOffset reg offset) doffset dreg = add
[ AddImmediate Signed (TempImm 0) reg (Immediate offset)
, StoreWord (TempImm 0) doffset dreg
]
storeStackValue (SVIndirect offset reg) doffset dreg = add
[ LoadWord (TempImm 0) offset reg
, StoreWord (TempImm 0) doffset dreg
]
buildCons :: !Label !Int -> Simulator ()
buildCons cons nargs =
write_heap (SVImmediate (Address 0 cons)) >>= \addr ->
mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>|
push addr
buildThunk :: !Label !Int -> Simulator ()
buildThunk cons 0 =
write_heap (SVImmediate (Address 0 cons)) >>= \addr ->
modify (\s -> {s & hp_offset=s.hp_offset+4}) >>| // reserve space to overwrite with indir
push addr
buildThunk cons nargs =
write_heap (SVImmediate (Address 0 cons)) >>= \addr ->
mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>|
push addr
pushBasicValue :: !BasicValue -> Simulator ()
pushBasicValue val = push (SVImmediate (Immediate imm))
where
imm = case val of
BVInt i -> i
BVChar c -> toInt c
pushArg :: !Int !Int -> Simulator ()
pushArg i j =
getState >>= \{stack} ->
case stack !! i of
SVRegOffset reg offset ->
push (SVIndirect (offset + (j+1)*4) reg)
_ ->
fail "unexpected reference in pushArg\n"
indirectAndEval :: Simulator ()
indirectAndEval =
pop >>= \sv ->
case sv of
SVRegOffset HeapPtr offset ->
add
// Build indirection
[ LoadAddress (TempImm 0) (Address 0 (functionLabel "" NodeEntry "indir"))
, StoreWord (TempImm 0) 0 FrontEvalPtr
] >>|
storeStackValue sv 4 FrontEvalPtr >>|
getState >>= \{hp_offset} ->
add
// Evaluate
[ AddImmediate Signed FrontEvalPtr HeapPtr (Immediate offset)
, Jump NoLink (Direct (Address 0 "eval"))
, AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
]
SVIndirect 4 FrontEvalPtr ->
// We only need to overwrite the descriptor with an indirection
getState >>= \{hp_offset} ->
add
[ LoadAddress (TempImm 0) (Address 0 (functionLabel "" NodeEntry "indir"))
, StoreWord (TempImm 0) 0 FrontEvalPtr
, Jump NoLink (Direct (Address 0 "eval"))
, AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
]
_ ->
fail "unexpected top of stack in indirectAndEval\n"
|
