-
Notifications
You must be signed in to change notification settings - Fork 3
/
Assembler.kalyn
385 lines (367 loc) · 11.8 KB
/
Assembler.kalyn
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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
(import "Assembly.kalyn")
(import "Stdlib.kalyn")
(import "Util.kalyn")
;; https://www.codeproject.com/Articles/662301/x86-Instruction-Encoding-Revealed-Bit-Twiddling-fo
;; https://wiki.osdev.org/X86-64_Instruction_Encoding
;; http://ref.x86asm.net/index.html
(data Mod
ModReg
ModMem
ModPC)
(data Reg
(Reg Register)
(RegExt Word8))
(data RM
(RMReg Register)
RMSIB
RMPC)
(defn regCode (Func Register (Pair Bool Word8))
(reg)
(case reg
(RAX (Pair False 0x0))
(RCX (Pair False 0x1))
(RDX (Pair False 0x2))
(RBX (Pair False 0x3))
(RSP (Pair False 0x4))
(RBP (Pair False 0x5))
(RSI (Pair False 0x6))
(RDI (Pair False 0x7))
(R8 (Pair True 0x0))
(R9 (Pair True 0x1))
(R10 (Pair True 0x2))
(R11 (Pair True 0x3))
(R12 (Pair True 0x4))
(R13 (Pair True 0x5))
(R14 (Pair True 0x6))
(R15 (Pair True 0x7))
(RIP (error "can't use %rip here\n"))))
(defn rex (Func (Maybe Register) (Maybe Register) (Maybe Register) Word8)
(reg rm index)
(foldr
| 0x48
[(case reg
((Just r)
(if (fst (regCode r))
0x4 ; REX.R
0))
(Nothing 0))
(case rm
((Just r)
(if (fst (regCode r))
0x1 ; REX.B
0))
(Nothing 0))
(case index
((Just r)
(if (fst (regCode r))
0x2 ; REX.X
0))
(Nothing 0))]))
(defn modRM (Func Mod Reg RM Word8)
(modOpt reg rm)
(let ((modBits (case modOpt
(ModReg 0x3)
(ModMem 0x2)
(ModPC 0x0)))
(regBits (case reg
((Reg r) (snd (regCode r)))
((RegExt b) b)))
(rmBits (case rm
((RMReg r) (snd (regCode r)))
(RMSIB 0x4)
(RMPC 0x5))))
(foldr
| 0
[(shl modBits 6)
(shl regBits 3)
rmBits])))
(defn sib (Func Register (Maybe (Pair Scale Register)) Word8)
(base msi)
(let ((scaleBits
(case msi
((Just (Pair Scale1 _)) 0x0)
((Just (Pair Scale2 _)) 0x1)
((Just (Pair Scale4 _)) 0x2)
((Just (Pair Scale8 _)) 0x3)
( Nothing 0x0)))
(indexBits
(case msi
((Just (Pair _ r)) (snd (regCode r)))
(Nothing (snd (regCode RSP)))))
(baseBits
(snd (regCode base))))
(foldr
| 0
[(shl scaleBits 6)
(shl indexBits 3)
baseBits])))
(defn memInstr (Func
(List Word8)
Register
(Maybe (Pair Scale Register))
Int32
(Either Word8 Register)
(Maybe Int32)
Bytes)
(opcode base msi disp other imm)
(let ((rexBits (rex
(case other
((Right r) (Just r))
(_ Nothing))
(case base
(RIP Nothing)
(_ (Just base)))
(case (Pair base msi)
((Pair RIP (Just _))
(error "can't use scale with %rip\n"))
((Pair RIP Nothing) Nothing)
(_ (case msi
((Just (Pair _ r)) (Just r))
(Nothing (Just RSP)))))))
(modRMBits (modRM
(case base
(RIP ModPC)
(_ ModMem))
(case other
((Right r) (Reg r))
((Left ext) (RegExt ext)))
(case base
(RIP RMPC)
(_ RMSIB))))
(maybeSIB (case base
(RIP Null)
(_ (word8 (sib base msi))))))
(concat
[(word8 rexBits)
(concat (map word8 opcode))
(word8 modRMBits)
maybeSIB
(int32 disp)
(case imm
((Just imm) (int32 imm))
(_ Null))])))
(defn opInstr* (Func
(Func imm Bytes)
(List Word8)
Register
(Either Word8 Register)
(Maybe imm)
Bytes)
(encodeImm opcode main other mimm)
(let ((rexBits (rex
(case other
((Right r) (Just r))
(_ Nothing))
(Just main)
Nothing))
(modRMBits (modRM
ModReg
(case other
((Left ext) (RegExt ext))
((Right r) (Reg r)))
(RMReg main))))
(concat
[(word8 rexBits)
(concat (map word8 opcode))
(word8 modRMBits)
(case mimm
(Nothing Null)
((Just imm) (encodeImm imm)))])))
(def opInstr (Func
(List Word8)
Register
(Either Word8 Register)
(Maybe Int32)
Bytes)
(opInstr* int32))
(def opInstr8U (Func
(List Word8)
Register
(Either Word8 Register)
(Maybe Word8)
Bytes)
(opInstr* word8))
(defn compressedInstr64 (Func Word8 Register (Maybe Int64) Bytes)
(opcode reg mimm)
(concat
[(word8 (rex Nothing (Just reg) Nothing))
(word8 (+ opcode (snd (regCode reg))))
(case mimm
(Nothing Null)
((Just imm) (int64 imm)))]))
(defn plainInstr (Func (List Word8) Bytes)
(opcode)
(concat (map word8 opcode)))
(defn plainInstr64 (Func (List Word8) Bytes)
(opcode)
(concatMap word8 (Cons (rex Nothing Nothing Nothing) opcode)))
(defn immInstr (Func (List Word8) Int32 Bytes)
(opcode rel)
(concat
[(concat (map word8 opcode))
(int32 rel)]))
(defn compileInstr (Func (Map Label Word32) Word32 PInstruction Bytes)
(labels pc instr)
(let ((getOffset (lambda (label)
(case (mapLookup label labels)
(Nothing
(error
(concat
["no such label " label "\n"])))
((Just labelOffset)
(- labelOffset pc)))))
(fromDisp (lambda (disp)
(case disp
((Left label) (getOffset label))
((Right imm) imm)))))
(case instr
((OP op args)
(let ((memDisallowed
"cannot imulq into memory address \n")
((Quad immOp immExt stdOp memOp)
(case op
(MOV (Quad [0xc7] (Just 0 ) [0x8b ] [0x89]))
(ADD (Quad [0x81] (Just 0 ) [0x03 ] [0x01]))
(SUB (Quad [0x81] (Just 5 ) [0x2b ] [0x29]))
(IMUL (Quad [0x69] Nothing [0x0f 0xaf] [ ]))
(AND (Quad [0x81] (Just 4 ) [0x23 ] [0x21]))
(OR (Quad [0x81] (Just 1 ) [0x0b ] [0x09]))
(XOR (Quad [0x81] (Just 6 ) [0x33 ] [0x31]))
(CMP (Quad [0x81] (Just 7 ) [0x3b ] [0x39])))))
(case args
((IR imm dst)
(opInstr
immOp
dst
(case immExt
(Nothing (Right dst))
((Just ext) (Left ext)))
(Just imm)))
((IM imm (Mem disp base msi))
(memInstr
immOp
base
msi
(fromDisp disp)
(case immExt
(Nothing (error memDisallowed))
((Just immExt) (Left immExt)))
(Just imm)))
((RR src dst)
(opInstr stdOp src (Right dst) Nothing))
((MR (Mem disp base msi) dst)
(memInstr
stdOp
base
msi
(fromDisp disp)
(Right dst)
Nothing))
((RM src (Mem disp base msi))
(case immExt
((Just _)
(memInstr
memOp
base
msi
(fromDisp disp)
(Right src)
Nothing))
(Nothing (error memDisallowed)))))))
((UN op arg)
(let (((Pair opcode ext)
(case op
(NOT (Pair [0xf7] 2))
(NEG (Pair [0xf7] 3))
(INC (Pair [0xff] 0))
(DEC (Pair [0xff] 1))
(PUSH (Pair [0xff] 6))
(POP (Pair [0x8f] 0))
(ICALL (Pair [0xff] 2)))))
(case arg
((R reg) (opInstr opcode reg (Left ext) Nothing))
((M (Mem disp base msi))
(memInstr
opcode
base
msi
(fromDisp disp)
(Left ext)
Nothing)))))
((JUMP op label)
(let ((opcode (case op
(JMP [0xe9 ])
(JE [0x0f 0x84])
(JNE [0x0f 0x85])
(JL [0x0f 0x8c])
(JLE [0x0f 0x8e])
(JG [0x0f 0x8f])
(JGE [0x0f 0x8d])
(JB [0x0f 0x82])
(JBE [0x0f 0x86])
(JA [0x0f 0x87])
(JAE [0x0f 0x83])
(CALL [0xe8 ]))))
(immInstr opcode (getOffset label))))
((SHIFT Nothing shift dst)
(let (((Pair op ext)
(case shift
(SHL (Pair 0xd3 4))
(SAL (Pair 0xd3 6))
(SHR (Pair 0xd3 5))
(SAR (Pair 0xd3 7)))))
(opInstr [op] dst (Left ext) Nothing)))
((SHIFT (Just amt) shift dst)
(let (((Pair op ext)
(case shift
(SHL (Pair 0xc1 4))
(SAL (Pair 0xc1 6))
(SHR (Pair 0xc1 5))
(SAR (Pair 0xc1 7)))))
(opInstr8U [op] dst (Left ext) (Just amt))))
((MOVBRM src (Mem disp base msi))
(memInstr [0x88] base msi (fromDisp disp) (Right src) Nothing))
((MOVBMR (Mem disp base msi) dst)
(memInstr [0x8a] base msi (fromDisp disp) (Right dst) Nothing))
((MOV64 imm dst)
(compressedInstr64 0xb8 dst (Just imm)))
((LEA (Mem disp base msi) dst)
(memInstr [0x8d] base msi (fromDisp disp) (Right dst) Nothing))
((IDIV src)
(opInstr [0xf7] src (Left 7) Nothing))
(CQTO (plainInstr64 [0x99]))
((PUSHI imm) (immInstr [0x68] imm))
(RET (plainInstr [0xc3]))
((SYSCALL _) (plainInstr [0x0f 0x05]))
((LABEL _) Null)
((GLOBAL _) Null))))
(public defn assemble (Func PProgram Bytes)
((Program main fns datums))
(let ((allInstrs (append (fnInstrs main) (concatMap fnInstrs fns)))
(binInstrs
(fixedPoint
(==List ==String)
(replicate (length allInstrs) Null)
(lambda (binInstrs)
(let ((codeOffsets
(scanl + 0 (map length binInstrs)))
(dataOffsets
(scanl + (last codeOffsets) (map (comp length snd) datums)))
(labels
(foldr
(lambda ((Pair label offset) labels)
(mapInsert label offset labels))
(foldr
(lambda ((Pair instr offset) labels)
(case instr
((LABEL name)
(mapInsert name offset labels))
((GLOBAL name)
(mapInsert name offset labels))
(_ labels)))
(mapEmpty compareString)
(zip allInstrs codeOffsets))
(zip (map fst datums) dataOffsets))))
(zipWith (compileInstr labels) (tail codeOffsets) allInstrs))))))
(concat
(append binInstrs (map snd datums)))))