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
|
structure CodeGen =
struct
fun enumerate l = ListPair.zip (List.tabulate (length l, (fn x => x)), l)
(* There are 256 registers *)
val tempReg = 255
structure VarMap = Map (type k = Syntax.var
val cmp = Int.compare)
fun cycle (outputs : Syntax.var VarMap.map) (output : Syntax.var) : Syntax.opcode list =
case VarMap.lookup output outputs of
NONE => Syntax.OShuf (output, Syntax.VVar tempReg) :: cycles outputs
| SOME input =>
Syntax.OShuf (output, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input
and cycles (outputs : Syntax.var VarMap.map) : Syntax.opcode list =
case VarMap.lookupMin outputs of
NONE => []
| SOME (output, input) =>
Syntax.OShuf (tempReg, Syntax.VVar input) :: cycle (VarMap.delete output outputs) input
fun shuffle' (inputs : unit VarMap.map) (outputs : Syntax.var VarMap.map) : Syntax.opcode list =
case VarMap.lookupMin (VarMap.difference outputs inputs) of
NONE => cycles outputs
| SOME (output, input) =>
Syntax.OShuf (output, Syntax.VVar input) :: shuffle' (VarMap.delete input inputs) (VarMap.delete output outputs)
fun shuffle (args : Syntax.value list) : Syntax.opcode list =
let
val outputMap =
VarMap.fromList
(List.mapPartial
(fn (i, Syntax.VVar v) =>
if i = v
then NONE
else SOME (i, v)
| _ => NONE)
(enumerate args))
val inputMap =
VarMap.fromList
(map
(fn (_, input) => (input, ()))
(VarMap.toList outputMap))
val constants =
List.mapPartial
(fn (_, Syntax.VVar _) => NONE
| (i, constArg) => SOME (Syntax.OShuf (i, constArg)))
(enumerate args)
in
shuffle' inputMap outputMap @ constants
end
fun buildVarMap (first : int) (expr : Syntax.cexp) : Syntax.var VarMap.map =
let
val next = ref first
fun insert v m =
let val this = !next
in
next := this + 1;
VarMap.insert v this m
end
fun go expr =
case expr of
Syntax.CRecord (records, k) =>
foldl
(fn ((_, res), acc) => insert res acc)
(go k)
records
| Syntax.CSelect (_, _, res, k) => insert res (go k)
| Syntax.CApp _ => VarMap.empty
| Syntax.CFix (funcs, body) =>
let
val funcsVars =
foldl
(fn ((_, args, body), acc) =>
let
val argsVars =
foldl
(fn ((i, arg), acc) => VarMap.insert arg i acc)
VarMap.empty
(ListPair.zip
(List.tabulate (length args, fn x => x + 1),
args))
val bodyVars = buildVarMap (length args + 1) body
in VarMap.union (VarMap.union acc argsVars) bodyVars
end)
VarMap.empty
funcs
val bodyVars = go body
in VarMap.union funcsVars bodyVars
end
| Syntax.CPrimop (_, _, res, k) =>
let
val resVars =
foldl
(fn (v, acc) => insert v acc)
VarMap.empty
res
val kVars =
foldl
(fn (expr, acc) => VarMap.union acc (go expr))
VarMap.empty
k
in
VarMap.union resVars kVars
end
in go expr
end
fun toASM (expr : Syntax.cexp) : Syntax.opcode list =
let
val varMap = buildVarMap 0 expr
fun translate v =
case VarMap.lookup v varMap of
NONE => raise Fail ("unable to translate var " ^ Int.toString v)
| SOME x => x
fun translateVal (Syntax.VVar v) = Syntax.VVar (translate v)
| translateVal x = x
fun go expr =
case expr of
Syntax.CRecord (records, k) =>
map (fn (args, res) => Syntax.OAlloc (translate res, Syntax.VInt (length args)))
records
@ List.concat
(map
(fn (args, res) =>
List.concat
(map
(fn (i, (arg, path)) =>
let val (temp, ops) =
foldl
(fn (off, (arg, ops)) =>
(Syntax.VVar tempReg, Syntax.OPeek (tempReg, off, arg) :: ops))
(translateVal arg, [])
path
in rev (Syntax.OPoke (i, translate res, temp) :: ops)
end)
(enumerate args)))
records)
@ go k
| Syntax.CSelect (i, arg, res, k) => Syntax.OPeek (translate res, i, translateVal arg) :: go k
| Syntax.CApp (func, args) => shuffle (map translateVal (func :: args)) @ [Syntax.OCall]
| Syntax.CFix (funcs, body) =>
let
val bodyASM = go body
val funcsASM =
foldl
(fn ((name, _, body), acc) =>
Syntax.OLabel name :: go body @ acc)
[]
funcs
in
bodyASM @ funcsASM
end
| Syntax.CPrimop (Syntax.PExit, [arg], _, _) => [Syntax.OExit (translateVal arg)]
| Syntax.CPrimop (Syntax.PAdd, [x, y], [res], [k]) => Syntax.OAdd (translate res, translateVal x, translateVal y) :: go k
| Syntax.CPrimop (Syntax.PSub, [x, y], [res], [k]) => Syntax.OSub (translate res, translateVal x, translateVal y) :: go k
| Syntax.CPrimop (Syntax.PMul, [x, y], [res], [k]) => Syntax.OMul (translate res, translateVal x, translateVal y) :: go k
| Syntax.CPrimop (Syntax.PDiv, [x, y], [res], [k]) => Syntax.ODiv (translate res, translateVal x, translateVal y) :: go k
| Syntax.CPrimop (Syntax.PLess, [x, y], [res], [k]) => Syntax.OLess (translate res, translateVal x, translateVal y) :: go k
| Syntax.CPrimop (Syntax.PEq, [x, y], [res], [k]) => Syntax.OEq (translate res, translateVal x, translateVal y) :: go k
| Syntax.CPrimop (Syntax.PIf, [b], [], [k1, k2]) =>
let
val trueLabel = Gensym.new ()
in
Syntax.OIf (translateVal b, trueLabel)
:: go k2
@ Syntax.OLabel trueLabel
:: go k1
end
| _ => raise Fail ("malformed CPS:\n" ^ Syntax.cexpToString expr)
in go expr
end
end
|
