HCoop / hcoop / debian / mlton.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Import Upstream version 20180207
[hcoop/debian/mlton.git] / mlton / codegen / amd64-codegen / amd64.fun
CommitLineData
7f918cf1
CE		 1(* Copyright (C) 2012 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
5 *
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
8 *)
9
10functor amd64 (S: AMD64_STRUCTS): AMD64 =
11struct
12
13 val tracerTop
14 = fn s => Control.traceBatch (Control.Pass, s)
15(*
16 = fn s => fn f => (Control.trace (Control.Pass, s) f, fn () => ())
17*)
18 val tracer
19 = fn s => Control.traceBatch (Control.Detail, s)
20(*
21 = fn s => fn f => (Control.trace (Control.Detail, s) f, fn () => ())
22*)
23
24 (* compensate for differences between
25 * C-escape sequences and ASM-escape sequences
26 *)
27 val Char_escapeASM = fn #"\000" => "\\000"
28 | #"\^G" => "\\007"
29 | #"\^K" => "\\013"
30 | #"?" => "?"
31 | #"'" => "'"
32 | c => Char.escapeC c
33 fun String_escapeASM s = String.translate(s, Char_escapeASM)
34
35 val rec lexical
36 = fn [] => EQUAL
37 | thunk::tl => let
38 val ord = thunk ()
39 in
40 if Relation.equals(ord, EQUAL)
41 then lexical tl
42 else ord
43 end
44
45
46 open S
47
48 structure Label =
49 struct
50 open Label
51
52 fun toString l =
53 if !Control.labelsHaveExtra_
54 then concat ["_", Label.toString l]
55 else Label.toString l
56
57 val layout = Layout.str o toString
58 end
59
60 structure Size =
61 struct
62 datatype class = INT | FLT
63
64 datatype t
65 = BYTE | WORD | LONG | QUAD
66 | SNGL | DBLE
67
68 val layout
69 = let
70 open Layout
71 in
72 fn BYTE => str "b"
73 | WORD => str "w"
74 | LONG => str "l"
75 | QUAD => str "q"
76 | SNGL => str "s"
77 | DBLE => str "d"
78 end
79 val toString = Layout.toString o layout
80
81 val fromBytes : int -> t
82 = fn 1 => BYTE
83 | 2 => WORD
84 | 4 => LONG
85 | 8 => QUAD
86 | _ => Error.bug "amd64.Size.fromBytes"
87 val toBytes : t -> int
88 = fn BYTE => 1
89 | WORD => 2
90 | LONG => 4
91 | QUAD => 8
92 | SNGL => 4
93 | DBLE => 8
94
95 local
96 datatype z = datatype CType.t
97 in
98 fun fromCType t =
99 case t of
100 CPointer => Vector.new1 QUAD
101 | Int8 => Vector.new1 BYTE
102 | Int16 => Vector.new1 WORD
103 | Int32 => Vector.new1 LONG
104 | Int64 => Vector.new1 QUAD
105 | Objptr => Vector.new1 QUAD
106 | Real32 => Vector.new1 SNGL
107 | Real64 => Vector.new1 DBLE
108 | Word8 => Vector.new1 BYTE
109 | Word16 => Vector.new1 WORD
110 | Word32 => Vector.new1 LONG
111 | Word64 => Vector.new1 QUAD
112 end
113
114 val class
115 = fn BYTE => INT
116 | WORD => INT
117 | LONG => INT
118 | QUAD => INT
119 | SNGL => FLT
120 | DBLE => FLT
121
122 val eq = fn (s1, s2) => s1 = s2
123 val lt = fn (s1, s2) => (toBytes s1) < (toBytes s2)
124 end
125
126 structure Register =
127 struct
128
129 datatype reg
130 = RAX | RBX | RCX | RDX | RDI | RSI | RBP | RSP
131 | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 | RIP
132 val allReg = [RAX, RBX, RCX, RDX, RDI, RSI, RBP, RSP,
133 R8, R9, R10, R11, R12, R13, R14, R15]
134
135 datatype part
136 = R | E | X | L
137
138 datatype t = T of {reg: reg, part: part}
139
140 fun size (T {part, ...})
141 = case part
142 of R => Size.QUAD
143 | E => Size.LONG
144 | X => Size.WORD
145 | L => Size.BYTE
146
147 fun layout (T {reg, part})
148 = let
149 open Layout
150 fun doit1 base =
151 let
152 val {prefix, suffix} =
153 case part of
154 R => {prefix = "%r", suffix = "x"}
155 | E => {prefix = "%e", suffix = "x"}
156 | X => {prefix = "%", suffix = "x"}
157 | L => {prefix = "%", suffix = "l"}
158 in
159 str (String.concat [prefix, base, suffix])
160 end
161 fun doit2 base =
162 let
163 val {prefix, suffix} =
164 case part of
165 R => {prefix = "%r", suffix = ""}
166 | E => {prefix = "%e", suffix = ""}
167 | X => {prefix = "%", suffix = ""}
168 | L => {prefix = "%", suffix = "l"}
169 in
170 str (String.concat [prefix, base, suffix])
171 end
172 fun doit3 base =
173 let
174 val {suffix} =
175 case part of
176 R => {suffix = ""}
177 | E => {suffix = "d"}
178 | X => {suffix = "w"}
179 | L => {suffix = "b"}
180 in
181 str (String.concat ["%", base, suffix])
182 end
183 in
184 case reg
185 of RAX => doit1 "a"
186 | RBX => doit1 "b"
187 | RCX => doit1 "c"
188 | RDX => doit1 "d"
189 | RDI => doit2 "di"
190 | RSI => doit2 "si"
191 | RBP => doit2 "bp"
192 | RSP => doit2 "sp"
193 | R8 => doit3 "r8"
194 | R9 => doit3 "r9"
195 | R10 => doit3 "r10"
196 | R11 => doit3 "r11"
197 | R12 => doit3 "r12"
198 | R13 => doit3 "r13"
199 | R14 => doit3 "r14"
200 | R15 => doit3 "r15"
201 | RIP => doit3 "rip"
202 end
203 val toString = Layout.toString o layout
204
205 fun eq(T r1, T r2) = r1 = r2
206
207 val rax = T {reg = RAX, part = R}
208 val eax = T {reg = RAX, part = E}
209 val ax = T {reg = RAX, part = X}
210 val al = T {reg = RAX, part = L}
211 val rbx = T {reg = RBX, part = R}
212 val ebx = T {reg = RBX, part = E}
213 val bl = T {reg = RBX, part = L}
214 val rcx = T {reg = RCX, part = R}
215 val ecx = T {reg = RCX, part = E}
216 val cl = T {reg = RCX, part = L}
217 val rdx = T {reg = RDX, part = R}
218 val edx = T {reg = RCX, part = E}
219 val dl = T {reg = RDX, part = L}
220 val rdi = T {reg = RDI, part = R}
221 val rsi = T {reg = RSI, part = R}
222 val rsp = T {reg = RSP, part = R}
223 val rbp = T {reg = RBP, part = R}
224 val r8 = T {reg = R8, part = R}
225 val r8w = T {reg = R8, part = X}
226 val r9 = T {reg = R9, part = R}
227 val r9w = T {reg = R9, part = X}
228 val r10 = T {reg = R10, part = R}
229 val r10w = T {reg = R10, part = X}
230 val r11 = T {reg = R11, part = R}
231 val r11w = T {reg = R11, part = X}
232 val r12 = T {reg = R12, part = R}
233 val r12w = T {reg = R12, part = X}
234 val r13 = T {reg = R13, part = R}
235 val r13w = T {reg = R13, part = X}
236 val r14 = T {reg = R14, part = R}
237 val r14w = T {reg = R14, part = X}
238 val r15 = T {reg = R15, part = R}
239 val r15w = T {reg = R15, part = X}
240 val rip = T {reg = RIP, part = R}
241
242 local
243 fun make part =
244 List.rev
245 [T {reg = RAX, part = part},
246 T {reg = RBX, part = part},
247 T {reg = RCX, part = part},
248 T {reg = RDX, part = part},
249 T {reg = RDI, part = part},
250 T {reg = RSI, part = part},
251 T {reg = RBP, part = part},
252 T {reg = RSP, part = part},
253 T {reg = R8, part = part},
254 T {reg = R9, part = part},
255 T {reg = R10, part = part},
256 T {reg = R11, part = part},
257 T {reg = R12, part = part},
258 T {reg = R13, part = part},
259 T {reg = R14, part = part},
260 T {reg = R15, part = part}]
261 in
262 val byteRegisters = make L
263 val wordRegisters = make X
264 val longRegisters = make E
265 val quadRegisters = make R
266 end
267
268 val all = List.concat [byteRegisters, wordRegisters,
269 longRegisters, quadRegisters]
270
271 fun valid r = List.contains(all, r, eq)
272
273 val contains
274 = fn (R, R) => true | (R, E) => true | (R, X) => true | (R, L) => true
275 | (E, E) => true | (E, X) => true | (E, L) => true
276 | (X, X) => true | (X, L) => true
277 | (L, L) => true
278 | _ => false
279
280 fun coincide (T {reg = reg1, part = part1},
281 T {reg = reg2, part = part2})
282 = reg1 = reg2 andalso (contains(part1,part2) orelse
283 contains(part2,part1))
284
285 fun coincident' reg
286 = List.keepAllMap([R, E, X, L],
287 fn part
288 => let
289 val register' = T {reg = reg, part = part}
290 in
291 if valid register' andalso
292 coincide(T {reg = reg, part = E}, register')
293 then SOME register'
294 else NONE
295 end)
296
297 val registers
298 = fn Size.BYTE => byteRegisters
299 | Size.WORD => wordRegisters
300 | Size.LONG => longRegisters
301 | Size.QUAD => quadRegisters
302 | _ => Error.bug "amd64.Register.registers"
303
304 val baseRegisters = quadRegisters
305 val indexRegisters = [T {reg = RAX, part = R},
306 T {reg = RBX, part = R},
307 T {reg = RCX, part = R},
308 T {reg = RDX, part = R},
309 T {reg = RDI, part = R},
310 T {reg = RSI, part = R},
311 T {reg = RBP, part = R},
312 T {reg = R8, part = R},
313 T {reg = R9, part = R},
314 T {reg = R10, part = R},
315 T {reg = R11, part = R},
316 T {reg = R12, part = R},
317 T {reg = R13, part = R},
318 T {reg = R14, part = R},
319 T {reg = R15, part = R}]
320
321 local
322 fun make reg =
323 [T {reg = reg, part = R},
324 T {reg = reg, part = E},
325 T {reg = reg, part = X},
326 T {reg = reg, part = L}]
327 in
328 val callerSaveRegisters =
329 List.concatMap ([RAX, RCX, RDX, RDI, RSI, R8, R9, R10, R11], make)
330 val calleeSaveRegisters =
331 List.concatMap ([RBX, R12, R13, R14, R15], make)
332 end
333
334 val withLowPart (* (fullsize,lowsize) *)
335 = fn (Size.WORD,Size.BYTE) => wordRegisters
336 | (Size.LONG,Size.BYTE) => longRegisters
337 | (Size.QUAD,Size.BYTE) => quadRegisters
338 | (Size.LONG,Size.WORD) => longRegisters
339 | (Size.QUAD,Size.WORD) => quadRegisters
340 | (Size.QUAD,Size.LONG) => quadRegisters
341 | _ => Error.bug "amd64.Register.withLowPart: fullsize,lowsize"
342
343 val lowPartOf (* (register,lowsize) *)
344 = fn (T {reg, ...},Size.BYTE) => T {reg = reg, part = L}
345 | (T {reg, ...},Size.WORD) => T {reg = reg, part = X}
346 | (T {reg, ...},Size.LONG) => T {reg = reg, part = E}
347 | _ => Error.bug "amd64.Register.lowPartOf: register,lowsize"
348 end
349
350 structure XmmRegister =
351 struct
352
353 datatype reg
354 = XMM0 | XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7
355 | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15
356 val allReg = [XMM0, XMM1, XMM2, XMM3, XMM4, XMM5, XMM6, XMM7,
357 XMM8, XMM9, XMM10, XMM11, XMM12, XMM13, XMM14, XMM15]
358
359 datatype part
360 = D | S
361
362 datatype t = T of {reg: reg, part: part}
363
364 fun size (T {part, ...})
365 = case part
366 of D => Size.DBLE
367 | S => Size.SNGL
368
369 fun layout (T {reg, ...})
370 = let
371 open Layout
372 in
373 case reg
374 of XMM0 => str "%xmm0"
375 | XMM1 => str "%xmm1"
376 | XMM2 => str "%xmm2"
377 | XMM3 => str "%xmm3"
378 | XMM4 => str "%xmm4"
379 | XMM5 => str "%xmm5"
380 | XMM6 => str "%xmm6"
381 | XMM7 => str "%xmm7"
382 | XMM8 => str "%xmm8"
383 | XMM9 => str "%xmm9"
384 | XMM10 => str "%xmm10"
385 | XMM11 => str "%xmm11"
386 | XMM12 => str "%xmm12"
387 | XMM13 => str "%xmm13"
388 | XMM14 => str "%xmm14"
389 | XMM15 => str "%xmm15"
390 end
391 val toString = Layout.toString o layout
392
393 fun eq(T r1, T r2) = r1 = r2
394
395 val xmm0S = T {reg = XMM0, part = S}
396 val xmm0D = T {reg = XMM0, part = D}
397 val xmm1S = T {reg = XMM1, part = S}
398 val xmm1D = T {reg = XMM1, part = D}
399 val xmm2S = T {reg = XMM2, part = S}
400 val xmm2D = T {reg = XMM2, part = D}
401 val xmm3S = T {reg = XMM3, part = S}
402 val xmm3D = T {reg = XMM3, part = D}
403 val xmm4S = T {reg = XMM4, part = S}
404 val xmm4D = T {reg = XMM4, part = D}
405 val xmm5S = T {reg = XMM5, part = S}
406 val xmm5D = T {reg = XMM5, part = D}
407 val xmm6S = T {reg = XMM6, part = S}
408 val xmm6D = T {reg = XMM6, part = D}
409 val xmm7S = T {reg = XMM7, part = S}
410 val xmm7D = T {reg = XMM7, part = D}
411 val xmm8S = T {reg = XMM8, part = S}
412 val xmm8D = T {reg = XMM8, part = D}
413 val xmm9S = T {reg = XMM9, part = S}
414 val xmm9D = T {reg = XMM9, part = D}
415 val xmm10S = T {reg = XMM10, part = S}
416 val xmm10D = T {reg = XMM10, part = D}
417 val xmm11S = T {reg = XMM11, part = S}
418 val xmm11D = T {reg = XMM11, part = D}
419 val xmm12S = T {reg = XMM12, part = S}
420 val xmm12D = T {reg = XMM12, part = D}
421 val xmm13S = T {reg = XMM13, part = S}
422 val xmm13D = T {reg = XMM13, part = D}
423 val xmm14S = T {reg = XMM14, part = S}
424 val xmm14D = T {reg = XMM14, part = D}
425 val xmm15S = T {reg = XMM15, part = S}
426 val xmm15D = T {reg = XMM15, part = D}
427
428 local
429 fun make part =
430 List.rev
431 [T {reg = XMM0, part = part},
432 T {reg = XMM1, part = part},
433 T {reg = XMM2, part = part},
434 T {reg = XMM3, part = part},
435 T {reg = XMM4, part = part},
436 T {reg = XMM5, part = part},
437 T {reg = XMM6, part = part},
438 T {reg = XMM7, part = part},
439 T {reg = XMM8, part = part},
440 T {reg = XMM9, part = part},
441 T {reg = XMM10, part = part},
442 T {reg = XMM11, part = part},
443 T {reg = XMM12, part = part},
444 T {reg = XMM13, part = part},
445 T {reg = XMM14, part = part},
446 T {reg = XMM15, part = part}]
447 in
448 val singleRegisters = make S
449 val doubleRegisters = make D
450 end
451
452 val all = List.concat [singleRegisters, doubleRegisters]
453
454 fun valid r = List.contains(all, r, eq)
455
456 val contains
457 = fn (D, D) => true | (D, S) => true
458 | (S, S) => true
459 | _ => false
460
461 fun coincide (T {reg = reg1, part = part1},
462 T {reg = reg2, part = part2})
463 = reg1 = reg2 andalso (contains(part1,part2) orelse
464 contains(part2,part1))
465
466 fun coincident' reg
467 = List.keepAllMap([D, S],
468 fn part
469 => let
470 val register' = T {reg = reg, part = part}
471 in
472 if valid register' andalso
473 coincide(T {reg = reg, part = D}, register')
474 then SOME register'
475 else NONE
476 end)
477
478 fun coincident (T {reg, ...}) = coincident' reg
479 (* quell unused warning *)
480 val _ = coincident
481
482 val registers
483 = fn Size.SNGL => singleRegisters
484 | Size.DBLE => doubleRegisters
485 | _ => Error.bug "amd64.XmmRegister.registers"
486
487 val callerSaveRegisters = all
488 val calleeSaveRegisters = []
489 end
490
491 structure Immediate =
492 struct
493 datatype u
494 = Word of WordX.t
495 | Label of Label.t
496 | LabelPlusWord of Label.t * WordX.t
497 and t
498 = T of {immediate: u,
499 plist: PropertyList.t,
500 hash: Word.t}
501
502 local
503 open Layout
504 in
505 val rec layoutU
506 = fn Word w => WordX.layout w
507 | Label l => Label.layout l
508 | LabelPlusWord (l, w)
509 => paren (seq [Label.layout l, str "+", WordX.layout w])
510 and layout
511 = fn T {immediate, ...} => layoutU immediate
512 end
513
514 val rec eqU
515 = fn (Word w1, Word w2) => WordX.equals (w1, w2)
516 | (Label l1, Label l2) => Label.equals(l1, l2)
517 | (LabelPlusWord (l1, w1), LabelPlusWord (l2,w2))
518 => Label.equals(l1,l2) andalso WordX.equals(w1, w2)
519 | _ => false
520 and eq
521 = fn (T {plist = plist1, ...},
522 T {plist = plist2, ...})
523 => PropertyList.equals(plist1, plist2)
524
525 local
526 open WordX
527 in
528 val rec evalU
529 = fn Word w => SOME w
530 | Label _ => NONE
531 | LabelPlusWord _ => NONE
532 and eval
533 = fn T {immediate, ...} => evalU immediate
534 end
535
536 val isZero = fn i => case eval i of SOME w => WordX.isZero w | _ => false
537
538 local
539 open Word
540 in
541 val rec hashU
542 = fn Word w => WordX.hash w
543 | Label l => Label.hash l
544 | LabelPlusWord (l,w)
545 => Word.xorb(0wx5555 * (Label.hash l), WordX.hash w)
546 and hash
547 = fn T {hash, ...} => hash
548 end
549
550 local
551 val table: t HashSet.t ref = ref (HashSet.new {hash = hash})
552 in
553 val construct
554 = fn immediate
555 => let
556 val hash = hashU immediate
557 in
558 HashSet.lookupOrInsert
559 (!table,
560 hash,
561 fn T {immediate = immediate', ...}
562 => eqU(immediate', immediate),
563 fn () => T {immediate = immediate,
564 hash = hash,
565 plist = PropertyList.new ()})
566 end
567
568 val destruct
569 = fn T {immediate, ...} => immediate
570
571 fun clearAll ()
572 = HashSet.foreach
573 (!table, fn T {immediate, plist, ...} =>
574 let in
575 PropertyList.clear plist;
576 case immediate
577 of Word _ => ()
578 | Label l => Label.clear l
579 | LabelPlusWord (l, _) => Label.clear l
580 end)
581 end
582
583 val word = construct o Word
584 val label = construct o Label
585 val labelPlusWord = fn (l, w) =>
586 if WordSize.equals (WordX.size w, WordSize.word64)
587 then construct (LabelPlusWord (l, w))
588 else Error.bug "amd64.Immediate.labelPlusWord"
589
590 val int' = fn (i, ws) => word (WordX.fromIntInf (IntInf.fromInt i, ws))
591 val int = fn i => int' (i, WordSize.word64)
592 val zero = int 0
593
594 val labelPlusInt = fn (l, i) =>
595 labelPlusWord (l, WordX.fromIntInf (IntInf.fromInt i, WordSize.word64))
596
597 val deLabel
598 = fn T {immediate = Label l, ...} => SOME l
599 | _ => NONE
600 end
601
602 structure Scale =
603 struct
604 datatype t
605 = One | Two | Four | Eight
606
607 val layout
608 = let
609 open Layout
610 in
611 fn One => str "1"
612 | Two => str "2"
613 | Four => str "4"
614 | Eight => str "8"
615 end
616
617 val fromBytes : int -> t
618 = fn 1 => One
619 | 2 => Two
620 | 4 => Four
621 | 8 => Eight
622 | _ => Error.bug "amd64.Scale.fromBytes"
623 local
624 datatype z = datatype CType.t
625 in
626 fun fromCType t =
627 case t of
628 CPointer => Eight
629 | Int8 => One
630 | Int16 => Two
631 | Int32 => Four
632 | Int64 => Eight
633 | Objptr => Eight
634 | Real32 => Four
635 | Real64 => Eight
636 | Word8 => One
637 | Word16 => Two
638 | Word32 => Four
639 | Word64 => Eight
640 end
641
642 fun eq(s1, s2) = s1 = s2
643
644 val toWordX
645 = fn One => WordX.fromIntInf (1, WordSize.word64)
646 | Two => WordX.fromIntInf (2, WordSize.word64)
647 | Four => WordX.fromIntInf (4, WordSize.word64)
648 | Eight => WordX.fromIntInf (8, WordSize.word64)
649 val toImmediate = Immediate.word o toWordX
650 end
651
652 structure Address =
653 struct
654 datatype t = T of {disp: Immediate.t option,
655 base: Register.t option,
656 index: Register.t option,
657 scale: Scale.t option}
658
659 fun layout (T {disp, base, index, scale})
660 = let
661 open Layout
662 in
663 seq [case disp
664 of NONE => empty
665 | SOME disp => Immediate.layout disp,
666 if (isSome base orelse isSome index)
667 then paren (seq
668 [case base
669 of NONE => empty
670 | SOME base
671 => Register.layout base,
672 case index
673 of NONE => empty
674 | SOME index
675 => seq [str ",", Register.layout index],
676 case scale
677 of NONE => empty
678 | SOME scale
679 => seq [str ",", Scale.layout scale]])
680 else empty]
681 end
682
683 fun eq(T {disp = disp, base = base, index = index, scale = scale},
684 T {disp = disp', base = base', index = index', scale = scale'})
685 = (case (disp, disp')
686 of (NONE, NONE) => true
687 | (SOME disp, SOME disp') => Immediate.eq(disp, disp')
688 | _ => false) andalso
689 base = base' andalso
690 index = index' andalso
691 scale = scale'
692 end
693
694 structure MemLoc =
695 struct
696 structure Class =
697 struct
698 val counter = Counter.new 0
699 datatype t = T of {counter: int,
700 name: string}
701
702 fun layout (T {name, ...})
703 = let
704 open Layout
705 in
706 str name
707 end
708 val toString = Layout.toString o layout
709
710 fun new {name}
711 = let
712 val class = T {counter = Counter.next counter,
713 name = name}
714 in
715 class
716 end
717
718 val eq
719 = fn (T {counter = counter1, ...},
720 T {counter = counter2, ...})
721 => counter1 = counter2
722 val compare
723 = fn (T {counter = counter1, ...},
724 T {counter = counter2, ...})
725 => Int.compare (counter1, counter2)
726 val counter
727 = fn (T {counter, ...}) => counter
728 val mayAlias = eq
729
730 val Temp = new {name = "Temp"}
731 val StaticTemp = new {name = "StaticTemp"}
732 val CArg = new {name = "CArg"}
733 val CStack = new {name = "CStack"}
734 val Code = new {name = "Code"}
735 end
736
737 datatype u
738 = U of {immBase: Immediate.t option,
739 memBase: t option,
740 immIndex: Immediate.t option,
741 memIndex: t option,
742 scale: Scale.t,
743 size: Size.t,
744 class: Class.t}
745 and t
746 = T of {memloc: u,
747 hash: Word.t,
748 plist: PropertyList.t,
749 counter: Int.t,
750 utilized: t list}
751
752 local
753 open Layout
754 in
755 val rec layoutImmMem
756 = fn (NONE, NONE) => str "0"
757 | (SOME imm, NONE) => Immediate.layout imm
758 | (NONE, SOME mem) => layout mem
759 | (SOME imm, SOME mem) => seq [Immediate.layout imm,
760 str "+",
761 layout mem]
762
763 and layoutImmMemScale
764 = fn (NONE, NONE, _) => str "0"
765 | (SOME imm, NONE, _) => Immediate.layout imm
766 | (NONE, SOME mem, scale) => seq [layout mem,
767 str "*",
768 Scale.layout scale]
769 | (SOME imm, SOME mem, scale) => seq [Immediate.layout imm,
770 str "+(",
771 layout mem,
772 str "*",
773 Scale.layout scale,
774 str ")"]
775 and layoutU
776 = fn U {immBase, memBase,
777 immIndex, memIndex,
778 scale,
779 size, class}
780 => seq [str "MEM<",
781 Size.layout size,
782 str ">{",
783 Class.layout class,
784 str "}[(",
785 layoutImmMem (immBase, memBase),
786 str ")+(",
787 layoutImmMemScale (immIndex, memIndex, scale),
788 str ")]"]
789 and layout
790 = fn T {memloc, ...} => layoutU memloc
791 end
792 val toString = Layout.toString o layout
793
794 val rec hashImmMem
795 = fn (NONE, NONE) => 0wx55555555
796 | (SOME imm, NONE) => Immediate.hash imm
797 | (NONE, SOME mem) => hash mem
798 | (SOME imm, SOME mem)
799 => Word.xorb(0wx5555 * (Immediate.hash imm), hash mem)
800 and hashU
801 = fn U {immBase, memBase, immIndex, memIndex, ...}
802 => let
803 val hashBase = hashImmMem(immBase, memBase)
804 val hashIndex = hashImmMem(immIndex, memIndex)
805 in
806 Word.xorb(0wx5555 * hashBase, hashIndex)
807 end
808 and hash
809 = fn T {hash, ...} => hash
810
811 val rec eqImm
812 = fn (NONE, NONE) => true
813 | (SOME imm1, SOME imm2) => Immediate.eq(imm1, imm2)
814 | _ => false
815 and eqMem
816 = fn (NONE, NONE) => true
817 | (SOME mem1, SOME mem2) => eq(mem1, mem2)
818 | _ => false
819 and eqU
820 = fn (U {immBase = immBase1, memBase = memBase1,
821 immIndex = immIndex1, memIndex = memIndex1,
822 scale = scale1, size = size1,
823 class = class1},
824 U {immBase = immBase2, memBase = memBase2,
825 immIndex = immIndex2, memIndex = memIndex2,
826 scale = scale2, size = size2,
827 class = class2})
828 => Class.eq(class1, class2) andalso
829 eqImm(immBase1, immBase2) andalso
830 eqMem(memBase1, memBase2) andalso
831 eqImm(immIndex1, immIndex2) andalso
832 eqMem(memIndex1, memIndex2) andalso
833 Scale.eq(scale1, scale2) andalso
834 Size.eq(size1, size2)
835 and eq
836 = fn (T {plist = plist1, ...},
837 T {plist = plist2, ...})
838 => PropertyList.equals(plist1, plist2)
839
840 val rec utilizedMem
841 = fn NONE => []
842 | SOME m => m::(utilized m)
843 and utilizedU
844 = fn U {memBase, memIndex, ...}
845 => (utilizedMem memBase) @ (utilizedMem memIndex)
846 and utilized
847 = fn T {utilized, ...}
848 => utilized
849
850 local
851 val counter = Counter.new 0
852 val table: t HashSet.t ref = ref (HashSet.new {hash = hash})
853 in
854 val construct
855 = fn memloc
856 => let
857 val hash = hashU memloc
858 in
859 HashSet.lookupOrInsert
860 (!table,
861 hash,
862 fn T {memloc = memloc', ...} => eqU(memloc', memloc),
863 fn () => T {memloc = memloc,
864 hash = hash,
865 plist = PropertyList.new (),
866 counter = Counter.next counter,
867 utilized = utilizedU memloc})
868 end
869
870 val destruct
871 = fn T {memloc, ...}
872 => memloc
873
874 fun clearAll ()
875 = HashSet.foreach
876 (!table, fn T {plist, ...} =>
877 let in
878 PropertyList.clear plist
879 end)
880 end
881
882 val rec mayAliasImmIndex
883 = fn ({immIndex = immIndex1, size = size1},
884 {immIndex = immIndex2, size = size2})
885 => let
886 val size1 = IntInf.fromInt (Size.toBytes size1)
887 val size2 = IntInf.fromInt (Size.toBytes size2)
888 in
889 case (Immediate.eval (case immIndex1
890 of NONE => Immediate.zero
891 | SOME immIndex => immIndex),
892 Immediate.eval (case immIndex2
893 of NONE => Immediate.zero
894 | SOME immIndex => immIndex))
895 of (SOME pos1, SOME pos2)
896 => (let
897 val pos1 = WordX.toIntInfX pos1
898 val pos2 = WordX.toIntInfX pos2
899 in
900 if pos1 < pos2
901 then pos2 < (pos1 + size1)
902 else pos1 < (pos2 + size2)
903 end
904 handle Overflow => false)
905 | _ => true
906 end
907 and mayAliasU
908 = fn (U {immBase = SOME immBase1, memBase = NONE,
909 immIndex = immIndex1, memIndex = NONE,
910 size = size1, ...},
911 U {immBase = SOME immBase2, memBase = NONE,
912 immIndex = immIndex2, memIndex = NONE,
913 size = size2, ...})
914 => Immediate.eq(immBase1, immBase2)
915 andalso
916 mayAliasImmIndex ({immIndex = immIndex1,
917 size = size1},
918 {immIndex = immIndex2,
919 size = size2})
920 | (U {immBase = SOME immBase1, memBase = NONE,
921 immIndex = immIndex1, memIndex = SOME memIndex1,
922 size = size1, ...},
923 U {immBase = SOME immBase2, memBase = NONE,
924 immIndex = immIndex2, memIndex = SOME memIndex2,
925 size = size2, ...})
926 => not (Immediate.eq(immBase1, immBase2))
927 andalso
928 (not (eq(memIndex1, memIndex2))
929 orelse
930 mayAliasImmIndex ({immIndex = immIndex1,
931 size = size1},
932 {immIndex = immIndex2,
933 size = size2}))
934 | (U {immBase = NONE, memBase = SOME memBase1,
935 immIndex = immIndex1, memIndex = NONE,
936 size = size1, ...},
937 U {immBase = NONE, memBase = SOME memBase2,
938 immIndex = immIndex2, memIndex = NONE,
939 size = size2, ...})
940 => not (eq(memBase1, memBase2))
941 orelse
942 mayAliasImmIndex ({immIndex = immIndex1,
943 size = size1},
944 {immIndex = immIndex2,
945 size = size2})
946 | (U {immBase = NONE, memBase = SOME memBase1,
947 immIndex = immIndex1, memIndex = SOME memIndex1,
948 size = size1, ...},
949 U {immBase = NONE, memBase = SOME memBase2,
950 immIndex = immIndex2, memIndex = SOME memIndex2,
951 size = size2, ...})
952 => not (eq(memBase1, memBase2))
953 orelse
954 not (eq(memIndex1, memIndex2))
955 orelse
956 mayAliasImmIndex ({immIndex = immIndex1,
957 size = size1},
958 {immIndex = immIndex2,
959 size = size2})
960 | _ => true
961 and mayAlias
962 = fn (T {memloc = memloc1 as U {class = class1, ...}, ...},
963 T {memloc = memloc2 as U {class = class2, ...}, ...})
964 => Class.mayAlias(class1, class2) andalso
965 mayAliasU(memloc1, memloc2)
966
967 val rec mayAliasOrdImmIndex
968 = fn ({immIndex = immIndex1, size = size1},
969 {immIndex = immIndex2, size = size2})
970 => let
971 val size1 = IntInf.fromInt (Size.toBytes size1)
972 val size2 = IntInf.fromInt (Size.toBytes size2)
973 in
974 case (Immediate.eval (case immIndex1
975 of NONE => Immediate.zero
976 | SOME immIndex => immIndex),
977 Immediate.eval (case immIndex2
978 of NONE => Immediate.zero
979 | SOME immIndex => immIndex))
980 of (SOME pos1, SOME pos2)
981 => (let
982 val pos1 = WordX.toIntInfX pos1
983 val pos2 = WordX.toIntInfX pos2
984 in
985 if pos1 < pos2
986 then if pos2 < (pos1 + size1)
987 then SOME LESS
988 else NONE
989 else if pos1 < (pos2 + size2)
990 then SOME GREATER
991 else NONE
992 end
993 handle Overflow => NONE)
994 | _ => SOME EQUAL
995 end
996 and mayAliasOrdU
997 = fn (U {immBase = SOME immBase1, memBase = NONE,
998 immIndex = immIndex1, memIndex = NONE,
999 size = size1, ...},
1000 U {immBase = SOME immBase2, memBase = NONE,
1001 immIndex = immIndex2, memIndex = NONE,
1002 size = size2, ...})
1003 => if Immediate.eq(immBase1, immBase2)
1004 then mayAliasOrdImmIndex ({immIndex = immIndex1,
1005 size = size1},
1006 {immIndex = immIndex2,
1007 size = size2})
1008 else NONE
1009 | (U {immBase = SOME immBase1, memBase = NONE,
1010 immIndex = immIndex1, memIndex = SOME memIndex1,
1011 size = size1, ...},
1012 U {immBase = SOME immBase2, memBase = NONE,
1013 immIndex = immIndex2, memIndex = SOME memIndex2,
1014 size = size2, ...})
1015 => if Immediate.eq(immBase1, immBase2)
1016 then if not (eq(memIndex1, memIndex2))
1017 then SOME EQUAL
1018 else mayAliasOrdImmIndex ({immIndex = immIndex1,
1019 size = size1},
1020 {immIndex = immIndex2,
1021 size = size2})
1022 else NONE
1023 | (U {immBase = NONE, memBase = SOME memBase1,
1024 immIndex = immIndex1, memIndex = NONE,
1025 size = size1, ...},
1026 U {immBase = NONE, memBase = SOME memBase2,
1027 immIndex = immIndex2, memIndex = NONE,
1028 size = size2, ...})
1029 => if not (eq(memBase1, memBase2))
1030 then SOME EQUAL
1031 else mayAliasOrdImmIndex ({immIndex = immIndex1,
1032 size = size1},
1033 {immIndex = immIndex2,
1034 size = size2})
1035 | (U {immBase = NONE, memBase = SOME memBase1,
1036 immIndex = immIndex1, memIndex = SOME memIndex1,
1037 size = size1, ...},
1038 U {immBase = NONE, memBase = SOME memBase2,
1039 immIndex = immIndex2, memIndex = SOME memIndex2,
1040 size = size2, ...})
1041 => if (not (eq(memBase1, memBase2))
1042 orelse
1043 not (eq(memIndex1, memIndex2)))
1044 then SOME EQUAL
1045 else mayAliasOrdImmIndex ({immIndex = immIndex1,
1046 size = size1},
1047 {immIndex = immIndex2,
1048 size = size2})
1049 | _ => SOME EQUAL
1050 and mayAliasOrd
1051 = fn (T {memloc = memloc1 as U {class = class1, ...}, ...},
1052 T {memloc = memloc2 as U {class = class2, ...}, ...})
1053 => if Class.mayAlias(class1, class2)
1054 then mayAliasOrdU(memloc1, memloc2)
1055 else NONE
1056
1057 val compare
1058 = fn (T {counter = counter1, ...},
1059 T {counter = counter2, ...})
1060 => Int.compare(counter1, counter2)
1061
1062 fun replaceMem replacer
1063 = fn NONE => NONE
1064 | SOME mem => SOME (replace replacer mem)
1065 and replaceU replacer
1066 = fn memloc as T {memloc = U {immBase, memBase, immIndex, memIndex,
1067 scale, size, class}, ...}
1068 => let
1069 val memBase' = replaceMem replacer memBase
1070 val memIndex' = replaceMem replacer memIndex
1071 in
1072 if eqMem(memBase, memBase') andalso eqMem(memIndex, memIndex')
1073 then memloc
1074 else construct (U {immBase = immBase,
1075 memBase = memBase',
1076 immIndex = immIndex,
1077 memIndex = memIndex',
1078 scale = scale,
1079 size = size,
1080 class = class})
1081 end
1082 and replace replacer
1083 = fn memloc
1084 => let
1085 val memloc' = replacer memloc
1086 in
1087 if eq(memloc', memloc)
1088 then replaceU replacer memloc
1089 else memloc'
1090 end
1091
1092 val rec sizeU = fn U {size, ...} => size
1093 and size = fn T {memloc, ...} => sizeU memloc
1094 val rec classU = fn U {class, ...} => class
1095 and class = fn T {memloc, ...} => classU memloc
1096
1097 fun scaleImmediate (imm, scale) =
1098 case Immediate.destruct imm of
1099 Immediate.Word w => Immediate.word (WordX.mul (w,
1100 Scale.toWordX scale,
1101 {signed = true}))
1102 | _ => Error.bug "amd64.MemLoc.scaleImmediate"
1103
1104 fun addImmediate (imm1, imm2) =
1105 case (Immediate.destruct imm1, Immediate.destruct imm2) of
1106 (Immediate.Word w1, Immediate.Word w2) => Immediate.word (WordX.add (w1, w2))
1107 | _ => Error.bug "amd64.MemLoc.scaleImmediate"
1108
1109 val imm = fn {base, index, scale, size, class}
1110 => construct (U {immBase = SOME base,
1111 memBase = NONE,
1112 immIndex = SOME (scaleImmediate (index, scale)),
1113 memIndex = NONE,
1114 scale = scale,
1115 size = size,
1116 class = class})
1117 val basic = fn {base, index, scale, size, class}
1118 => construct (U {immBase = SOME base,
1119 memBase = NONE,
1120 immIndex = NONE,
1121 memIndex = SOME index,
1122 scale = scale,
1123 size = size,
1124 class = class})
1125 val simple = fn {base, index, scale, size, class}
1126 => construct (U {immBase = NONE,
1127 memBase = SOME base,
1128 immIndex = SOME (scaleImmediate (index, scale)),
1129 memIndex = NONE,
1130 scale = scale,
1131 size = size,
1132 class = class})
1133
1134 val complex = fn {base, index, scale, size, class}
1135 => construct (U {immBase = NONE,
1136 memBase = SOME base,
1137 immIndex = NONE,
1138 memIndex = SOME index,
1139 scale = scale,
1140 size = size,
1141 class = class})
1142 val shift = fn {origin, disp, scale, size}
1143 => let
1144 val disp = scaleImmediate (disp, scale)
1145 val U {immBase, memBase,
1146 immIndex, memIndex,
1147 scale, class, ...} =
1148 destruct origin
1149 in
1150 construct (U {immBase = immBase,
1151 memBase = memBase,
1152 immIndex =
1153 case immIndex of
1154 NONE => SOME disp
1155 | SOME immIndex => SOME (addImmediate (immIndex, disp)),
1156 memIndex = memIndex,
1157 scale = scale,
1158 size = size,
1159 class = class})
1160 end
1161
1162 local
1163 val num : int ref = ref 0
1164 in
1165 val temp = fn {size} => (Int.inc num;
1166 imm {base = Immediate.zero,
1167 index = Immediate.int (!num),
1168 scale = Scale.One,
1169 size = size,
1170 class = Class.Temp})
1171 end
1172
1173 (*
1174 * Static memory locations
1175 *)
1176 fun makeContents {base, size, class}
1177 = imm {base = base,
1178 index = Immediate.zero,
1179 scale = Scale.Eight,
1180 size = size,
1181 class = class}
1182(*
1183 local
1184 datatype z = datatype CType.t
1185 datatype z = datatype Size.t
1186 in
1187 fun cReturnTempContents sizes =
1188 (List.rev o #1)
1189 (List.fold
1190 (sizes, ([],0), fn (size, (contents, index)) =>
1191 ((cReturnTempContent (index, size))::contents,
1192 index + Size.toBytes size)))
1193 fun cReturnTempContent size =
1194 List.first(cReturnTempContents [size])
1195 val cReturnTempContents = fn size =>
1196 cReturnTempContents (
1197 case size of
1198 Int s => let datatype z = datatype IntSize.t
1199 in case s of
1200 I8 => [BYTE]
1201 | I16 => [WORD]
1202 | I32 => [LONG]
1203 | I64 => [LONG, LONG]
1204 end
1205 | Pointer => [LONG]
1206 | Real s => let datatype z = datatype RealSize.t
1207 in case s of
1208 R32 => [SNGL]
1209 | R64 => [DBLE]
1210 end
1211 | Word s => let datatype z = datatype WordSize.t
1212 in case s of
1213 W8 => [BYTE]
1214 | W16 => [WORD]
1215 | W32 => [LONG]
1216 end)
1217 end
1218*)
1219 end
1220
1221 local
1222 structure ClassElement =
1223 struct
1224 type t = MemLoc.Class.t
1225 val compare = MemLoc.Class.compare
1226 local
1227 fun make f = fn (a, b) => f (MemLoc.Class.counter a, MemLoc.Class.counter b)
1228 in
1229 val op < = make Int.<
1230 val op > = make Int.>
1231 val op >= = make Int.>=
1232 val op <= = make Int.<=
1233 end
1234 val min = fn (a, b) => if Int.<(MemLoc.Class.counter a, MemLoc.Class.counter b)
1235 then a
1236 else b
1237 val max = fn (a, b) => min (b, a)
1238 val equals = MemLoc.Class.eq
1239 val layout = MemLoc.Class.layout
1240 end
1241 in
1242 structure ClassSet = OrderedUniqueSet(open ClassElement)
1243 end
1244 local
1245 structure MemLocElement =
1246 struct
1247 type t = MemLoc.t
1248 val equals = MemLoc.eq
1249 val layout = MemLoc.layout
1250(*
1251 val compare = MemLoc.compare
1252 local
1253 fun make f = fn (a, b) => f (MemLoc.counter a, MemLoc.counter b)
1254 in
1255 val op < = make Int.<
1256 val op > = make Int.>
1257 val op >= = make Int.>=
1258 val op <= = make Int.<=
1259 end
1260 val min = fn (a, b) => if Int.<(MemLoc.counter a, MemLoc.counter b)
1261 then a
1262 else b
1263 val max = fn (a, b) => min (b, a)
1264 val hash = MemLoc.hash
1265*)
1266 end
1267 in
1268 structure MemLocSet = UnorderedSet(open MemLocElement)
1269(*
1270 structure MemLocSet = OrderedUniqueSet(open MemLocElement)
1271*)
1272(*
1273 structure MemLocSet' = UnorderedSet(open MemLocElement)
1274 structure MemLocSet = HashedUniqueSet(structure Set = MemLocSet'
1275 structure Element = MemLocElement)
1276*)
1277 end
1278
1279 structure Operand =
1280 struct
1281 datatype t
1282 = Register of Register.t
1283 | XmmRegister of XmmRegister.t
1284 | Immediate of Immediate.t
1285 | Label of Label.t
1286 | Address of Address.t
1287 | MemLoc of MemLoc.t
1288
1289 val size
1290 = fn Register r => SOME (Register.size r)
1291 | XmmRegister x => SOME (XmmRegister.size x)
1292 | Immediate _ => NONE
1293 | Label _ => NONE
1294 | Address _ => NONE
1295 | MemLoc m => SOME (MemLoc.size m)
1296
1297 val layout
1298 = let
1299 open Layout
1300 in
1301 fn Register r => Register.layout r
1302 | XmmRegister x => XmmRegister.layout x
1303 | Immediate i => seq [str "$", Immediate.layout i]
1304 | Label l => Label.layout l
1305 | Address a => Address.layout a
1306 | MemLoc m => MemLoc.layout m
1307 end
1308 val toString = Layout.toString o layout
1309
1310 val eq
1311 = fn (Register r1, Register r2) => Register.eq(r1, r2)
1312 | (XmmRegister x1, XmmRegister x2) => XmmRegister.eq(x1, x2)
1313 | (Immediate i1, Immediate i2) => Immediate.eq(i1, i2)
1314 | (Label l1, Label l2) => Label.equals(l1, l2)
1315 | (Address a1, Address a2) => Address.eq(a1, a2)
1316 | (MemLoc m1, MemLoc m2) => MemLoc.eq(m1, m2)
1317 | _ => false
1318
1319 val mayAlias
1320 = fn (Register r1, Register r2) => Register.eq(r1, r2)
1321 | (Register _, _) => false
1322 | (XmmRegister x1, XmmRegister x2) => XmmRegister.eq(x1, x2)
1323 | (XmmRegister _, _) => false
1324 | (Immediate i1, Immediate i2) => Immediate.eq(i1, i2)
1325 | (Immediate _, _) => false
1326 | (Label l1, Label l2) => Label.equals(l1, l2)
1327 | (Label _, _) => false
1328 | (Address _, Address _) => true
1329 | (Address _, MemLoc _) => true
1330 | (Address _, _) => false
1331 | (MemLoc m1, MemLoc m2) => MemLoc.mayAlias(m1, m2)
1332 | (MemLoc _, Address _) => true
1333 | (MemLoc _, _) => false
1334
1335 val register = Register
1336 val deRegister
1337 = fn Register x => SOME x
1338 | _ => NONE
1339 val xmmregister = XmmRegister
1340 val deXmmregister
1341 = fn XmmRegister x => SOME x
1342 | _ => NONE
1343 val immediate = Immediate
1344 val deImmediate
1345 = fn Immediate x => SOME x
1346 | _ => NONE
1347 val immediate_word = immediate o Immediate.word
1348 val immediate_int' = immediate o Immediate.int'
1349 val immediate_int = immediate o Immediate.int
1350 val immediate_zero = immediate Immediate.zero
1351 val immediate_label = immediate o Immediate.label
1352 val label = Label
1353 val deLabel
1354 = fn Label x => SOME x
1355 | _ => NONE
1356 val address = Address
1357 val memloc = MemLoc
1358 fun memloc_label l =
1359 memloc (MemLoc.makeContents { base = Immediate.label l,
1360 size = Size.QUAD,
1361 class = MemLoc.Class.Code })
1362 val deMemloc
1363 = fn MemLoc x => SOME x
1364 | _ => NONE
1365
1366 local
1367 val cReturnTemp = Label.fromString "cReturnTemp"
1368 fun cReturnTempContent (index, size) =
1369 MemLoc.imm
1370 {base = Immediate.label cReturnTemp,
1371 index = Immediate.int index,
1372 scale = Scale.One,
1373 size = size,
1374 class = MemLoc.Class.StaticTemp}
1375 datatype z = datatype CType.t
1376 datatype z = datatype Size.t
1377 in
1378 fun cReturnTemps ty =
1379 if RepType.isUnit ty
1380 then []
1381 else
1382 let
1383 fun w (r, s) =
1384 [{src = register r, dst = cReturnTempContent (0, s)}]
1385 val w8 = w (Register.al, BYTE)
1386 val w16 = w (Register.ax, WORD)
1387 val w32 = w (Register.eax, LONG)
1388 val w64 = w (Register.rax, QUAD)
1389 fun x (x, s) =
1390 [{src = xmmregister x, dst = cReturnTempContent (0, s)}]
1391 val x32 = x (XmmRegister.xmm0S, SNGL)
1392 val x64 = x (XmmRegister.xmm0D, DBLE)
1393 in
1394 case RepType.toCType ty of
1395 CPointer => w64
1396 | Int8 => w8
1397 | Int16 => w16
1398 | Int32 => w32
1399 | Int64 => w64
1400 | Objptr => w64
1401 | Real32 => x32
1402 | Real64 => x64
1403 | Word8 => w8
1404 | Word16 => w16
1405 | Word32 => w32
1406 | Word64 => w64
1407 end
1408 end
1409 end
1410
1411 structure Instruction =
1412 struct
1413 (* Integer binary arithmetic(w/o mult & div)/logic instructions. *)
1414 datatype binal
1415 = ADD (* signed/unsigned addition; p. 58 *)
1416 | ADC (* signed/unsigned addition with carry; p. 56 *)
1417 | SUB (* signed/unsigned subtraction; p. 234 *)
1418 | SBB (* signed/unsigned subtraction with borrow; p. 216 *)
1419 | AND (* logical and; p. 60 *)
1420 | OR (* logical or; p. 176 *)
1421 | XOR (* logical xor; p. 243 *)
1422 val binal_layout
1423 = let
1424 open Layout
1425 in
1426 fn ADD => str "add"
1427 | ADC => str "adc"
1428 | SUB => str "sub"
1429 | SBB => str "sbb"
1430 | AND => str "and"
1431 | OR => str "or"
1432 | XOR => str "xor"
1433 end
1434
1435 (* Integer multiplication and division. *)
1436 datatype md
1437 = IMUL (* signed multiplication (one operand form); p. 114 *)
1438 | MUL (* unsigned multiplication; p. 170 *)
1439 | IDIV (* signed division; p. 112 *)
1440 | DIV (* unsigned division; p. 108 *)
1441 | IMOD (* signed modulus; *)
1442 | MOD (* unsigned modulus; *)
1443 val md_layout
1444 = let
1445 open Layout
1446 in
1447 fn IMUL => str "imul"
1448 | MUL => str "mul"
1449 | IDIV => str "idiv"
1450 | DIV => str "div"
1451 | IMOD => str "imod"
1452 | MOD => str "mod"
1453 end
1454
1455 (* Integer unary arithmetic/logic instructions. *)
1456 datatype unal
1457 = INC (* increment by 1; p. 117 *)
1458 | DEC (* decrement by 1; p. 106 *)
1459 | NEG (* two's complement negation; p. 172 *)
1460 | NOT (* one's complement negation; p. 175 *)
1461 val unal_layout
1462 = let
1463 open Layout
1464 in
1465 fn INC => str "inc"
1466 | DEC => str "dec"
1467 | NEG => str "neg"
1468 | NOT => str "not"
1469 end
1470
1471 (* Integer shift/rotate arithmetic/logic instructions. *)
1472 datatype sral
1473 = SAL (* shift arithmetic left; p. 211 *)
1474 | SHL (* shift logical left; p. 211 *)
1475 | SAR (* shift arithmetic right; p. 214 *)
1476 | SHR (* shift logical right; p. 214 *)
1477 | ROL (* rotate left; p. 206 *)
1478 | RCL (* rotate through carry left; p. 197 *)
1479 | ROR (* rotate right; p. 208 *)
1480 | RCR (* rotate through carry right; p. 199 *)
1481 val sral_layout
1482 = let
1483 open Layout
1484 in
1485 fn SAL => str "sal"
1486 | SHL => str "shl"
1487 | SAR => str "sar"
1488 | SHR => str "shr"
1489 | ROL => str "rol"
1490 | RCL => str "rcl"
1491 | ROR => str "ror"
1492 | RCR => str "rcr"
1493 end
1494
1495 (* Move with extention instructions. *)
1496 datatype movx
1497 = MOVSX (* move with sign extention; p. 167 *)
1498 | MOVZX (* move with zero extention; p. 169 *)
1499 val movx_layout
1500 = let
1501 open Layout
1502 in
1503 fn MOVSX => str "movs"
1504 | MOVZX => str "movz"
1505 end
1506
1507 (* Condition test field; p. 340 *)
1508 datatype condition
1509 = O (* overflow *) | NO (* not overflow *)
1510 | B (* below *) | NB (* not below *)
1511 | AE (* above or equal *) | NAE (* not above or equal *)
1512 | C (* carry *) | NC (* not carry *)
1513 | E (* equal *) | NE (* not equal *)
1514 | Z (* zero *) | NZ (* not zero *)
1515 | BE (* below or equal *) | NBE (* not below or equal *)
1516 | A (* above *) | NA (* not above *)
1517 | S (* sign *) | NS (* not sign *)
1518 | P (* parity *) | NP (* not parity *)
1519 | PE (* parity even *) | PO (* parity odd *)
1520 | L (* less than *)
1521 | NL (* not less than *)
1522 | LE (* less than or equal *)
1523 | NLE (* not less than or equal *)
1524 | G (* greater than *)
1525 | NG (* not greater than *)
1526 | GE (* greater than or equal *)
1527 | NGE (* not greater than or equal *)
1528
1529 val condition_negate
1530 = fn O => NO | NO => O
1531 | B => NB | NB => B
1532 | AE => NAE | NAE => AE
1533 | C => NC | NC => C
1534 | E => NE | NE => E
1535 | Z => NZ | NZ => Z
1536 | BE => NBE | NBE => BE
1537 | A => NA | NA => A
1538 | S => NS | NS => S
1539 | P => NP | NP => P
1540 | PE => PO | PO => PE
1541 | L => NL | NL => L
1542 | LE => NLE | NLE => LE
1543 | G => NG | NG => G
1544 | GE => NGE | NGE => GE
1545
1546 val condition_reverse
1547 = fn B => A | NB => NA
1548 | AE => BE | NAE => NBE
1549 | E => E | NE => NE
1550 | BE => AE | NBE => NAE
1551 | A => B | NA => NB
1552 | L => G | NL => NG
1553 | LE => GE | NLE => NGE
1554 | G => L | NG => NL
1555 | GE => LE | NGE => NLE
1556 | c => c
1557
1558 local
1559 open Layout
1560 in
1561 val rec condition_layout
1562 = fn O => str "o"
1563 | B => str "b"
1564 | AE => str "ae"
1565 | C => str "c"
1566 | E => str "e"
1567 | Z => str "z"
1568 | BE => str "be"
1569 | A => str "a"
1570 | S => str "s"
1571 | P => str "p"
1572 | PE => str "pe"
1573 | PO => str "po"
1574 | L => str "l"
1575 | LE => str "le"
1576 | G => str "g"
1577 | GE => str "ge"
1578 | c => seq [str "n", condition_layout (condition_negate c)]
1579 end
1580 val condition_toString = Layout.toString o condition_layout
1581
1582
1583 (* Scalar SSE binary arithmetic instructions. *)
1584 datatype sse_binas
1585 = SSE_ADDS (* addition; p. 7,10 *)
1586 | SSE_SUBS (* subtraction; p. 371,374 *)
1587 | SSE_MULS (* multiplication; p. 201,204 *)
1588 | SSE_DIVS (* division; p. 97,100 *)
1589 | SSE_MAXS (* maximum; p. 128, 130 *)
1590 | SSE_MINS (* minimum; p. 132, 134 *)
1591 val sse_binas_layout
1592 = let
1593 open Layout
1594 in
1595 fn SSE_ADDS => str "adds"
1596 | SSE_SUBS => str "subs"
1597 | SSE_MULS => str "muls"
1598 | SSE_DIVS => str "divs"
1599 | SSE_MAXS => str "maxs"
1600 | SSE_MINS => str "mins"
1601 end
1602 (* Scalar SSE unary arithmetic instructions. *)
1603 datatype sse_unas
1604 = SSE_SQRTS (* square root; p. 360,362 *)
1605 val sse_unas_layout
1606 = let
1607 open Layout
1608 in
1609 fn SSE_SQRTS => str "sqrts"
1610 end
1611 (* Packed SSE binary logical instructions (used as scalar). *)
1612 datatype sse_binlp
1613 = SSE_ANDNP (* and-not; p. 17,19 *)
1614 | SSE_ANDP (* and; p. 21,23 *)
1615 | SSE_ORP (* or; p. 206,208 *)
1616 | SSE_XORP (* xor; p. 391,393 *)
1617 val sse_binlp_layout
1618 = let
1619 open Layout
1620 in
1621 fn SSE_ANDNP => str "andnp"
1622 | SSE_ANDP => str "andp"
1623 | SSE_ORP => str "orp"
1624 | SSE_XORP => str "xorp"
1625 end
1626
1627 (* amd64 Instructions.
1628 * src operands are not changed by the instruction.
1629 * dst operands are changed by the instruction.
1630 *)
1631 datatype t
1632 (* No operation *)
1633 = NOP
1634 (* Halt *)
1635 | HLT
1636 (* Integer binary arithmetic(w/o mult & div)/logic instructions.
1637 *)
1638 | BinAL of {oper: binal,
1639 src: Operand.t,
1640 dst: Operand.t,
1641 size: Size.t}
1642 (* Psuedo integer multiplication and division.
1643 *)
1644 | pMD of {oper: md,
1645 src: Operand.t,
1646 dst: Operand.t,
1647 size: Size.t}
1648 (* Integer multiplication and division.
1649 *)
1650 | MD of {oper: md,
1651 src: Operand.t,
1652 size: Size.t}
1653 (* Integer signed/unsiged multiplication (two operand form); p. 335
1654 *)
1655 | IMUL2 of {src: Operand.t,
1656 dst: Operand.t,
1657 size: Size.t}
1658 (* Integer unary arithmetic/logic instructions.
1659 *)
1660 | UnAL of {oper: unal,
1661 dst: Operand.t,
1662 size: Size.t}
1663 (* Integer shift/rotate arithmetic/logic instructions.
1664 *)
1665 | SRAL of {oper: sral,
1666 count: Operand.t,
1667 dst: Operand.t,
1668 size: Size.t}
1669 (* Arithmetic compare.
1670 *)
1671 | CMP of {src1: Operand.t,
1672 src2: Operand.t,
1673 size: Size.t}
1674 (* Logical compare.
1675 *)
1676 | TEST of {src1: Operand.t,
1677 src2: Operand.t,
1678 size: Size.t}
1679 (* Set byte on condition.
1680 *)
1681 | SETcc of {condition: condition,
1682 dst: Operand.t,
1683 size: Size.t}
1684 (* Jump.
1685 *)
1686 | JMP of {target: Operand.t,
1687 absolute: bool}
1688 (* Jump if condition is met.
1689 *)
1690 | Jcc of {condition: condition,
1691 target: Operand.t}
1692 (* Call procedure.
1693 *)
1694 | CALL of {target: Operand.t,
1695 absolute: bool}
1696 (* Return from procedure.
1697 *)
1698 | RET of {src: Operand.t option}
1699 (* Move.
1700 *)
1701 | MOV of {src: Operand.t,
1702 dst: Operand.t,
1703 size: Size.t}
1704 (* Conditional move.
1705 *)
1706 | CMOVcc of {condition: condition,
1707 src: Operand.t,
1708 dst: Operand.t,
1709 size: Size.t}
1710 (* Exchange register/memory with register.
1711 *)
1712 | XCHG of {src: Operand.t,
1713 dst: Operand.t,
1714 size: Size.t}
1715 (* Pseudo-push a value onto a stack.
1716 *)
1717 | pPUSH of {src: Operand.t,
1718 base: Operand.t,
1719 size: Size.t}
1720 (* Pseudo-pop a value from a stack.
1721 *)
1722 | pPOP of {dst: Operand.t,
1723 base: Operand.t,
1724 size: Size.t}
1725 (* Push a value onto the stack.
1726 *)
1727 | PUSH of {src: Operand.t,
1728 size: Size.t}
1729 (* Pop a value from the stack.
1730 *)
1731 | POP of {dst: Operand.t,
1732 size: Size.t}
1733 (* Convert X to 2X with sign extension.
1734 *)
1735 | CX of {size: Size.t}
1736 (* Move with extention.
1737 *)
1738 | MOVX of {oper: movx,
1739 src: Operand.t,
1740 srcsize: Size.t,
1741 dst: Operand.t,
1742 dstsize: Size.t}
1743 (* Move with contraction.
1744 *)
1745 | XVOM of {src: Operand.t,
1746 srcsize: Size.t,
1747 dst: Operand.t,
1748 dstsize: Size.t}
1749 (* Load effective address.
1750 *)
1751 | LEA of {src: Operand.t,
1752 dst: Operand.t,
1753 size: Size.t}
1754 (* Scalar SSE binary arithmetic instructions.
1755 *)
1756 | SSE_BinAS of {oper: sse_binas,
1757 src: Operand.t,
1758 dst: Operand.t,
1759 size: Size.t}
1760 (* Scalar SSE unary arithmetic instructions.
1761 *)
1762 | SSE_UnAS of {oper: sse_unas,
1763 src: Operand.t,
1764 dst: Operand.t,
1765 size: Size.t}
1766 (* Packed SSE binary logical instructions (used as scalar).
1767 *)
1768 | SSE_BinLP of {oper: sse_binlp,
1769 src: Operand.t,
1770 dst: Operand.t,
1771 size: Size.t}
1772 (* Scalar SSE move instruction.
1773 *)
1774 | SSE_MOVS of {src: Operand.t,
1775 dst: Operand.t,
1776 size: Size.t}
1777 (* Scalar SSE compare instruction.
1778 *)
1779 | SSE_COMIS of {src1: Operand.t,
1780 src2: Operand.t,
1781 size: Size.t}
1782 (* Scalar SSE unordered compare instruction.
1783 *)
1784 | SSE_UCOMIS of {src1: Operand.t,
1785 src2: Operand.t,
1786 size: Size.t}
1787 (* Scalar SSE floating-point/floating-point convert instruction.
1788 *)
1789 | SSE_CVTSFP2SFP of {src: Operand.t,
1790 srcsize: Size.t,
1791 dst: Operand.t,
1792 dstsize: Size.t}
1793 (* Scalar SSE floating-point/signed-integer convert instruction.
1794 *)
1795 | SSE_CVTSFP2SI of {src: Operand.t,
1796 srcsize: Size.t,
1797 dst: Operand.t,
1798 dstsize: Size.t}
1799 | SSE_CVTSI2SFP of {src: Operand.t,
1800 srcsize: Size.t,
1801 dst: Operand.t,
1802 dstsize: Size.t}
1803 (* Scalar SSE move data instruction.
1804 *)
1805 | SSE_MOVD of {src: Operand.t,
1806 srcsize: Size.t,
1807 dst: Operand.t,
1808 dstsize: Size.t}
1809
1810 val layout
1811 = let
1812 open Layout
1813 fun bin (oper, size, oper1, oper2)
1814 = seq [oper,
1815 size,
1816 str " ",
1817 oper1,
1818 str ",",
1819 oper2]
1820 fun un (oper, size, oper1)
1821 = seq [oper,
1822 size,
1823 str " ",
1824 oper1]
1825 in
1826 fn NOP
1827 => str "nop"
1828 | HLT
1829 => str "hlt"
1830 | BinAL {oper, src, dst, size}
1831 => bin (binal_layout oper,
1832 Size.layout size,
1833 Operand.layout src,
1834 Operand.layout dst)
1835 | pMD {oper, src, dst, size}
1836 => bin (md_layout oper,
1837 Size.layout size,
1838 Operand.layout src,
1839 Operand.layout dst)
1840 | MD {oper, src, size}
1841 => let
1842 val s = un (md_layout oper,
1843 Size.layout size,
1844 Operand.layout src)
1845 in
1846 case size of
1847 Size.BYTE => seq [str "movb %dl,%ah", str ";",
1848 s,
1849 str ";", str "movb %ah,%dl"]
1850 | _ => s
1851 end
1852 | IMUL2 {src, dst, size}
1853 => bin (str "imul",
1854 Size.layout size,
1855 Operand.layout src,
1856 Operand.layout dst)
1857 | UnAL {oper, dst, size}
1858 => un (unal_layout oper,
1859 Size.layout size,
1860 Operand.layout dst)
1861 | SRAL {oper, count, dst, size}
1862 => bin (sral_layout oper,
1863 Size.layout size,
1864 Operand.layout count,
1865 Operand.layout dst)
1866 | CMP {src1, src2, size}
1867 => bin (str "cmp",
1868 Size.layout size,
1869 Operand.layout src2,
1870 Operand.layout src1)
1871 | TEST {src1, src2, size}
1872 => bin (str "test",
1873 Size.layout size,
1874 Operand.layout src2,
1875 Operand.layout src1)
1876 | SETcc {condition, dst, ...}
1877 => seq [str "set",
1878 condition_layout condition,
1879 str " ",
1880 Operand.layout dst]
1881 | JMP {target, absolute}
1882 => seq [str "jmp ",
1883 if absolute then str "*" else empty,
1884 Operand.layout target]
1885 | Jcc {condition, target}
1886 => seq [str "j",
1887 condition_layout condition,
1888 str " ",
1889 Operand.layout target]
1890 | CALL {target, absolute}
1891 => seq [str "call ",
1892 if absolute then str "*" else empty,
1893 Operand.layout target]
1894 | RET {src}
1895 => seq [str "ret",
1896 case src
1897 of NONE => empty
1898 | SOME src => seq [str " ", Operand.layout src]]
1899 | MOV {src, dst, size}
1900 => bin (str "mov",
1901 Size.layout size,
1902 Operand.layout src,
1903 Operand.layout dst)
1904 | CMOVcc {condition, src, dst, size}
1905 => seq [str "cmov",
1906 condition_layout condition,
1907 Size.layout size,
1908 str " ",
1909 Operand.layout src,
1910 str ",",
1911 Operand.layout dst]
1912 | XCHG {src, dst, size}
1913 => bin (str "xchg",
1914 Size.layout size,
1915 Operand.layout src,
1916 Operand.layout dst)
1917 | pPUSH {src, base, size}
1918 => seq [str "ppush",
1919 Size.layout size,
1920 str " [",
1921 Operand.layout base,
1922 str "] ",
1923 Operand.layout src]
1924 | pPOP {dst, base, size}
1925 => seq [str "ppop",
1926 Size.layout size,
1927 str " [",
1928 Operand.layout base,
1929 str " ]",
1930 Operand.layout dst]
1931 | PUSH {src, size}
1932 => seq [str "push",
1933 Size.layout size,
1934 str " ",
1935 Operand.layout src]
1936 | POP {dst, size}
1937 => seq [str "pop",
1938 Size.layout size,
1939 str " ",
1940 Operand.layout dst]
1941 | CX {size}
1942 => (case size
1943 of Size.BYTE => str "cbtw ; movb %ah,%dl"
1944 | Size.WORD => str "cwtd"
1945 | Size.LONG => str "cltd"
1946 | Size.QUAD => str "cqto"
1947 | _ => Error.bug "amd64.Instruction.layout: CX,unsupported conversion")
1948 | MOVX {oper, src, srcsize, dst, dstsize}
1949 => let
1950 val (oper, suffix, src, dst) =
1951 case (oper, src, srcsize, dst, dstsize) of
1952 (MOVZX,
1953 _, Size.LONG,
1954 Operand.Register (Register.T {reg, ...}),
1955 Size.QUAD) =>
1956 (str "mov", str "l",
1957 src,
1958 Operand.Register
1959 (Register.T {reg = reg, part = Register.E}))
1960 | _ =>
1961 (movx_layout oper,
1962 seq [Size.layout srcsize,
1963 Size.layout dstsize],
1964 src, dst)
1965 in
1966 bin (oper, suffix,
1967 Operand.layout src,
1968 Operand.layout dst)
1969 end
1970 | XVOM {src, srcsize, dst, dstsize}
1971 => bin (str "xvom",
1972 seq [Size.layout srcsize,
1973 Size.layout dstsize],
1974 Operand.layout src,
1975 Operand.layout dst)
1976 | LEA {src, dst, size}
1977 => bin (str "lea",
1978 Size.layout size,
1979 Operand.layout src,
1980 Operand.layout dst)
1981 | SSE_BinAS {oper, src, dst, size}
1982 => bin (sse_binas_layout oper,
1983 Size.layout size,
1984 Operand.layout src,
1985 Operand.layout dst)
1986 | SSE_UnAS {oper, src, dst, size}
1987 => bin (sse_unas_layout oper,
1988 Size.layout size,
1989 Operand.layout src,
1990 Operand.layout dst)
1991 | SSE_BinLP {oper, src, dst, size}
1992 => bin (sse_binlp_layout oper,
1993 Size.layout size,
1994 Operand.layout src,
1995 Operand.layout dst)
1996 | SSE_MOVS {src, dst, size}
1997 => bin (str "movs",
1998 Size.layout size,
1999 Operand.layout src,
2000 Operand.layout dst)
2001 | SSE_COMIS {src1, src2, size}
2002 => bin (str "comis",
2003 Size.layout size,
2004 Operand.layout src1,
2005 Operand.layout src2)
2006 | SSE_UCOMIS {src1, src2, size}
2007 => bin (str "ucomis",
2008 Size.layout size,
2009 Operand.layout src1,
2010 Operand.layout src2)
2011 | SSE_CVTSFP2SFP {src, srcsize, dst, dstsize}
2012 => bin (str "cvt",
2013 seq [str "s", Size.layout srcsize,
2014 str "2", str "s", Size.layout dstsize],
2015 Operand.layout src,
2016 Operand.layout dst)
2017 | SSE_CVTSFP2SI {src, srcsize, dst, dstsize, ...}
2018 => bin (str "cvt",
2019 seq [str "s", Size.layout srcsize,
2020 str "2", str "si",
2021 case dstsize of
2022 Size.LONG => empty
2023 | Size.QUAD => Size.layout dstsize
2024 | _ => Error.bug "amd64.Instruction.layout: SSE_CVTSFP2SI,unsupported conversion"],
2025 Operand.layout src,
2026 Operand.layout dst)
2027 | SSE_CVTSI2SFP {src, srcsize, dst, dstsize, ...}
2028 => bin (str "cvt",
2029 seq [str "si",
2030 str "2", str "s", Size.layout dstsize,
2031 case srcsize of
2032 Size.LONG => empty
2033 | Size.QUAD => Size.layout srcsize
2034 | _ => Error.bug "amd64.Instruction.layout: SSE_CVTSI2SFP,unsupported conversion"],
2035 Operand.layout src,
2036 Operand.layout dst)
2037 | SSE_MOVD {src, dst, ...}
2038 => bin (str "movd",
2039 empty,
2040 Operand.layout src,
2041 Operand.layout dst)
2042 end
2043 val toString = Layout.toString o layout
2044
2045 val uses_defs_kills
2046 = fn NOP
2047 => {uses = [], defs = [], kills = []}
2048 | HLT
2049 => {uses = [], defs = [], kills = []}
2050 | BinAL {src, dst, ...}
2051 => {uses = [src, dst], defs = [dst], kills = []}
2052 | pMD {src, dst, ...}
2053 => {uses = [src, dst], defs = [dst], kills = []}
2054 | MD {oper, src, size}
2055 => let
2056 val (hi,lo)
2057 = case size
2058 of Size.BYTE
2059 => (Register.T {reg = Register.RDX, part = Register.L},
2060 Register.T {reg = Register.RAX, part = Register.L})
2061 | Size.WORD
2062 => (Register.T {reg = Register.RDX, part = Register.X},
2063 Register.T {reg = Register.RAX, part = Register.X})
2064 | Size.LONG
2065 => (Register.T {reg = Register.RDX, part = Register.E},
2066 Register.T {reg = Register.RAX, part = Register.E})
2067 | Size.QUAD
2068 => (Register.T {reg = Register.RDX, part = Register.R},
2069 Register.T {reg = Register.RAX, part = Register.R})
2070 | _ => Error.bug "amd64.Instruction.uses_defs: MD, size"
2071 in
2072 if oper = IMUL orelse oper = MUL
2073 then {uses = [src, Operand.register lo],
2074 defs = [Operand.register hi, Operand.register lo],
2075 kills = []}
2076 else {uses = [src, Operand.register hi, Operand.register lo],
2077 defs = [Operand.register hi, Operand.register lo],
2078 kills = []}
2079 end
2080 | IMUL2 {src, dst, ...}
2081 => {uses = [src, dst], defs = [dst], kills = []}
2082 | UnAL {dst, ...}
2083 => {uses = [dst], defs = [dst], kills = []}
2084 | SRAL {count, dst, size, ...}
2085 => if isSome (Operand.deMemloc count)
2086 then let
2087 val reg
2088 = case size
2089 of Size.BYTE
2090 => Register.T {reg = Register.RCX,
2091 part = Register.L}
2092 | Size.WORD
2093 => Register.T {reg = Register.RCX,
2094 part = Register.X}
2095 | Size.LONG
2096 => Register.T {reg = Register.RCX,
2097 part = Register.E}
2098 | Size.QUAD
2099 => Register.T {reg = Register.RCX,
2100 part = Register.R}
2101 | _ => Error.bug "amd64.Instruction.uses_defs: SRAL, size"
2102 in
2103 {uses = [count, dst, Operand.register reg],
2104 defs = [dst],
2105 kills = []}
2106 end
2107 else {uses = [count, dst],
2108 defs = [dst],
2109 kills = []}
2110 | CMP {src1, src2, ...}
2111 => {uses = [src1, src2], defs = [], kills = []}
2112 | TEST {src1, src2, ...}
2113 => {uses = [src1, src2], defs = [], kills = []}
2114 | SETcc {dst, ...}
2115 => {uses = [], defs = [dst], kills = []}
2116 | JMP {target, ...}
2117 => {uses = [target], defs = [], kills = []}
2118 | Jcc {target, ...}
2119 => {uses = [target], defs = [], kills = []}
2120 | CALL {target, ...}
2121 => {uses = [target], defs = [], kills = []}
2122 | RET {src}
2123 => {uses = case src of NONE => [] | SOME src => [src],
2124 defs = [],
2125 kills = []}
2126 | MOV {src, dst, ...}
2127 => {uses = [src], defs = [dst], kills = []}
2128 | CMOVcc {src, dst, ...}
2129 => {uses = [src], defs = [dst], kills = []}
2130 | XCHG {src, dst, ...}
2131 => {uses = [src,dst], defs = [src,dst], kills = []}
2132 | pPUSH {src, base, size, ...}
2133 => {uses = [src,base],
2134 defs = base::
2135 (case base
2136 of Operand.MemLoc base
2137 => [Operand.MemLoc
2138 (MemLoc.simple {base = base,
2139 index = Immediate.zero,
2140 size = size,
2141 scale = Scale.One,
2142 class = MemLoc.Class.CStack})]
2143 | _ => []),
2144 kills = []}
2145 | pPOP {dst, base, size, ...}
2146 => {uses = base::
2147 (case base
2148 of Operand.MemLoc base
2149 => [Operand.MemLoc
2150 (MemLoc.simple {base = base,
2151 index = Immediate.zero,
2152 size = size,
2153 scale = Scale.One,
2154 class = MemLoc.Class.CStack})]
2155 | _ => []),
2156 defs = [dst,base],
2157 kills = []}
2158 | PUSH {src, ...}
2159 => {uses = [src, Operand.register Register.rsp],
2160 defs = [Operand.register Register.rsp,
2161 Operand.address (Address.T {disp = NONE,
2162 base = SOME Register.rsp,
2163 index = NONE,
2164 scale = NONE})],
2165 kills = []}
2166 | POP {dst, ...}
2167 => {uses = [Operand.register Register.rsp,
2168 Operand.address (Address.T {disp = NONE,
2169 base = SOME Register.rsp,
2170 index = NONE,
2171 scale = NONE})],
2172 defs = [dst, Operand.register Register.rsp],
2173 kills = []}
2174 | CX {size}
2175 => let
2176 val (hi,lo)
2177 = case size
2178 of Size.BYTE
2179 => (Register.T {reg = Register.RDX, part = Register.L},
2180 Register.T {reg = Register.RAX, part = Register.L})
2181 | Size.WORD
2182 => (Register.T {reg = Register.RDX, part = Register.X},
2183 Register.T {reg = Register.RAX, part = Register.X})
2184 | Size.LONG
2185 => (Register.T {reg = Register.RDX, part = Register.E},
2186 Register.T {reg = Register.RAX, part = Register.E})
2187 | Size.QUAD
2188 => (Register.T {reg = Register.RDX, part = Register.R},
2189 Register.T {reg = Register.RAX, part = Register.R})
2190 | _ => Error.bug "amd64.Instruction.uses_defs: CX, size"
2191 in
2192 {uses = [Operand.register lo],
2193 defs = [Operand.register hi, Operand.register lo],
2194 kills = []}
2195 end
2196 | MOVX {src, dst, ...}
2197 => {uses = [src], defs = [dst], kills = []}
2198 | XVOM {src, dst, ...}
2199 => {uses = [src], defs = [dst], kills = []}
2200 | LEA {src, dst, ...}
2201 => {uses = [src], defs = [dst], kills = []}
2202 | SSE_BinAS {src, dst, ...}
2203 => {uses = [src, dst], defs = [dst], kills = []}
2204 | SSE_UnAS {src, dst, ...}
2205 => {uses = [src], defs = [dst], kills = []}
2206 | SSE_BinLP {src, dst, ...}
2207 => {uses = [src, dst], defs = [dst], kills = []}
2208 | SSE_MOVS {src, dst, ...}
2209 => {uses = [src], defs = [dst], kills = []}
2210 | SSE_COMIS {src1, src2, ...}
2211 => {uses = [src1, src2], defs = [], kills = []}
2212 | SSE_UCOMIS {src1, src2, ...}
2213 => {uses = [src1, src2], defs = [], kills = []}
2214 | SSE_CVTSFP2SFP {src, dst, ...}
2215 => {uses = [src], defs = [dst], kills = []}
2216 | SSE_CVTSFP2SI {src, dst, ...}
2217 => {uses = [src], defs = [dst], kills = []}
2218 | SSE_CVTSI2SFP {src, dst, ...}
2219 => {uses = [src], defs = [dst], kills = []}
2220 | SSE_MOVD {src, dst, ...}
2221 => {uses = [src], defs = [dst], kills = []}
2222
2223 val hints
2224 = fn pMD {dst, size, ...}
2225 => let
2226 val (hi,lo)
2227 = case size
2228 of Size.BYTE
2229 => (Register.T {reg = Register.RDX, part = Register.L},
2230 Register.T {reg = Register.RAX, part = Register.L})
2231 | Size.WORD
2232 => (Register.T {reg = Register.RDX, part = Register.X},
2233 Register.T {reg = Register.RAX, part = Register.X})
2234 | Size.LONG
2235 => (Register.T {reg = Register.RDX, part = Register.E},
2236 Register.T {reg = Register.RAX, part = Register.E})
2237 | Size.QUAD
2238 => (Register.T {reg = Register.RDX, part = Register.R},
2239 Register.T {reg = Register.RAX, part = Register.R})
2240 | _ => Error.bug "amd64.Instruction.hints: MD, size"
2241
2242 val temp = MemLoc.temp {size = size}
2243 in
2244 [(temp, hi),
2245 (case Operand.deMemloc dst
2246 of SOME memloc => (memloc, lo)
2247 | NONE => (temp, lo))]
2248 end
2249 | MD {src, size, ...}
2250 => let
2251 val (hi,lo)
2252 = case size
2253 of Size.BYTE
2254 => (Register.T {reg = Register.RDX, part = Register.L},
2255 Register.T {reg = Register.RAX, part = Register.L})
2256 | Size.WORD
2257 => (Register.T {reg = Register.RDX, part = Register.X},
2258 Register.T {reg = Register.RAX, part = Register.X})
2259 | Size.LONG
2260 => (Register.T {reg = Register.RDX, part = Register.E},
2261 Register.T {reg = Register.RAX, part = Register.E})
2262 | Size.QUAD
2263 => (Register.T {reg = Register.RDX, part = Register.R},
2264 Register.T {reg = Register.RAX, part = Register.R})
2265 | _ => Error.bug "amd64.Instruction.hints: MD, size"
2266
2267 val temp = MemLoc.temp {size = size}
2268 in
2269 [(temp, hi),
2270 (case Operand.deMemloc src
2271 of SOME memloc => (memloc, lo)
2272 | NONE => (temp, lo))]
2273 end
2274 | SRAL {count, size, ...}
2275 => (case Operand.deMemloc count
2276 of SOME memloc
2277 => let
2278 val reg
2279 = case size
2280 of Size.BYTE
2281 => Register.T {reg = Register.RCX,
2282 part = Register.L}
2283 | Size.WORD
2284 => Register.T {reg = Register.RCX,
2285 part = Register.X}
2286 | Size.LONG
2287 => Register.T {reg = Register.RCX,
2288 part = Register.E}
2289 | Size.QUAD
2290 => Register.T {reg = Register.RCX,
2291 part = Register.R}
2292 | _ => Error.bug "amd64.Instruction.hints: SRAL, size"
2293 in
2294 [(memloc, reg)]
2295 end
2296 | NONE => [])
2297 | pPUSH {base, ...}
2298 => (case Operand.deMemloc base
2299 of SOME base => [(base,Register.rsp)]
2300 | NONE => [])
2301 | pPOP {base, ...}
2302 => (case Operand.deMemloc base
2303 of SOME base => [(base,Register.rsp)]
2304 | NONE => [])
2305 | PUSH {...}
2306 => let
2307 val temp = MemLoc.temp {size = Size.QUAD}
2308 in
2309 [(temp,Register.rsp)]
2310 end
2311 | POP {...}
2312 => let
2313 val temp = MemLoc.temp {size = Size.QUAD}
2314 in
2315 [(temp,Register.rsp)]
2316 end
2317 | _ => []
2318
2319 val srcs_dsts
2320 = fn NOP
2321 => {srcs = NONE, dsts = NONE}
2322 | HLT
2323 => {srcs = NONE, dsts = NONE}
2324 | BinAL {src, dst, ...}
2325 => {srcs = SOME [src, dst], dsts = SOME [dst]}
2326 | pMD {src, dst, ...}
2327 => {srcs = SOME [src, dst], dsts = SOME [dst]}
2328 | MD {oper, src, size, ...}
2329 => let
2330 val (hi,lo)
2331 = case size
2332 of Size.BYTE
2333 => (Register.T {reg = Register.RDX, part = Register.L},
2334 Register.T {reg = Register.RAX, part = Register.L})
2335 | Size.WORD
2336 => (Register.T {reg = Register.RDX, part = Register.X},
2337 Register.T {reg = Register.RAX, part = Register.X})
2338 | Size.LONG
2339 => (Register.T {reg = Register.RDX, part = Register.E},
2340 Register.T {reg = Register.RAX, part = Register.E})
2341 | Size.QUAD
2342 => (Register.T {reg = Register.RDX, part = Register.R},
2343 Register.T {reg = Register.RAX, part = Register.R})
2344 | _ => Error.bug "amd64.Instruction.srcs_dsts: MD, size"
2345 in
2346 if oper = IMUL orelse oper = MUL
2347 then {srcs = SOME [src,
2348 Operand.register lo],
2349 dsts = SOME [Operand.register hi,
2350 Operand.register lo]}
2351 else {srcs = SOME [src,
2352 Operand.register hi,
2353 Operand.register lo],
2354 dsts = SOME [Operand.register hi,
2355 Operand.register lo]}
2356 end
2357 | IMUL2 {src, dst, ...}
2358 => {srcs = SOME [src, dst], dsts = SOME [dst]}
2359 | UnAL {dst, ...}
2360 => {srcs = SOME [dst], dsts = SOME [dst]}
2361 | SRAL {count, dst, size, ...}
2362 => if isSome (Operand.deMemloc count)
2363 then let
2364 val reg
2365 = case size
2366 of Size.BYTE
2367 => Register.T {reg = Register.RCX,
2368 part = Register.L}
2369 | Size.WORD
2370 => Register.T {reg = Register.RCX,
2371 part = Register.X}
2372 | Size.LONG
2373 => Register.T {reg = Register.RCX,
2374 part = Register.E}
2375 | Size.QUAD
2376 => Register.T {reg = Register.RCX,
2377 part = Register.R}
2378 | _ => Error.bug "amd64.Instruction.srcs_dsts: SRAL, size"
2379 in
2380 {srcs = SOME [count, dst, Operand.register reg],
2381 dsts = SOME [dst]}
2382 end
2383 else {srcs = SOME [count, dst],
2384 dsts = SOME [dst]}
2385 | CMP {src1, src2, ...}
2386 => {srcs = SOME [src1, src2], dsts = NONE}
2387 | TEST {src1, src2, ...}
2388 => {srcs = SOME [src1, src2], dsts = NONE}
2389 | SETcc {dst, ...}
2390 => {srcs = NONE, dsts = SOME [dst]}
2391 | JMP {target, ...}
2392 => {srcs = SOME [target], dsts = NONE}
2393 | Jcc {target, ...}
2394 => {srcs = SOME [target], dsts = NONE}
2395 | CALL {target, ...}
2396 => {srcs = SOME [target], dsts = NONE}
2397 | RET {src}
2398 => {srcs = case src of NONE => NONE | SOME src => SOME [src],
2399 dsts = NONE}
2400 | MOV {src, dst, ...}
2401 => {srcs = SOME [src], dsts = SOME [dst]}
2402 | CMOVcc {src, dst, ...}
2403 => {srcs = SOME [src], dsts = SOME [dst]}
2404 | XCHG {src, dst, ...}
2405 => {srcs = SOME [src,dst], dsts = SOME [src,dst]}
2406 | pPUSH {src, base, ...}
2407 => {srcs = SOME [src,base], dsts = SOME [base]}
2408 | pPOP {dst, base, ...}
2409 => {srcs = SOME [base], dsts = SOME [dst,base]}
2410 | PUSH {src, ...}
2411 => {srcs = SOME [src, Operand.register Register.rsp],
2412 dsts = SOME [Operand.register Register.rsp]}
2413 | POP {dst, ...}
2414 => {srcs = SOME [Operand.register Register.rsp],
2415 dsts = SOME [dst, Operand.register Register.rsp]}
2416 | CX {size, ...}
2417 => let
2418 val (hi,lo)
2419 = case size
2420 of Size.BYTE
2421 => (Register.T {reg = Register.RDX, part = Register.L},
2422 Register.T {reg = Register.RAX, part = Register.L})
2423 | Size.WORD
2424 => (Register.T {reg = Register.RDX, part = Register.X},
2425 Register.T {reg = Register.RAX, part = Register.X})
2426 | Size.LONG
2427 => (Register.T {reg = Register.RDX, part = Register.E},
2428 Register.T {reg = Register.RAX, part = Register.E})
2429 | Size.QUAD
2430 => (Register.T {reg = Register.RDX, part = Register.R},
2431 Register.T {reg = Register.RAX, part = Register.R})
2432 | _ => Error.bug "amd64.Instruction.srcs_dsts: CX, size"
2433 in
2434 {srcs = SOME [Operand.register lo],
2435 dsts = SOME [Operand.register hi, Operand.register lo]}
2436 end
2437 | MOVX {src, dst, ...}
2438 => {srcs = SOME [src], dsts = SOME [dst]}
2439 | XVOM {src, dst, ...}
2440 => {srcs = SOME [src], dsts = SOME [dst]}
2441 | LEA {src, dst, ...}
2442 => {srcs = SOME [src], dsts = SOME [dst]}
2443 | SSE_BinAS {src, dst, ...}
2444 => {srcs = SOME [src, dst], dsts = SOME [dst]}
2445 | SSE_UnAS {src, dst, ...}
2446 => {srcs = SOME [src], dsts = SOME [dst]}
2447 | SSE_BinLP {src, dst, ...}
2448 => {srcs = SOME [src, dst], dsts = SOME [dst]}
2449 | SSE_MOVS {src, dst, ...}
2450 => {srcs = SOME [src], dsts = SOME [dst]}
2451 | SSE_COMIS {src1, src2, ...}
2452 => {srcs = SOME [src1, src2], dsts = NONE}
2453 | SSE_UCOMIS {src1, src2, ...}
2454 => {srcs = SOME [src1, src2], dsts = NONE}
2455 | SSE_CVTSFP2SFP {src, dst, ...}
2456 => {srcs = SOME [src], dsts = SOME [dst]}
2457 | SSE_CVTSFP2SI {src, dst, ...}
2458 => {srcs = SOME [src], dsts = SOME [dst]}
2459 | SSE_CVTSI2SFP {src, dst, ...}
2460 => {srcs = SOME [src], dsts = SOME [dst]}
2461 | SSE_MOVD {src, dst, ...}
2462 => {srcs = SOME [src], dsts = SOME [dst]}
2463
2464 fun replace replacer
2465 = fn NOP
2466 => NOP
2467 | HLT
2468 => HLT
2469 | BinAL {oper, src, dst, size}
2470 => BinAL {oper = oper,
2471 src = replacer {use = true, def = false} src,
2472 dst = replacer {use = true, def = true} dst,
2473 size = size}
2474 | pMD {oper, src, dst, size}
2475 => pMD {oper = oper,
2476 src = replacer {use = true, def = false} src,
2477 dst = replacer {use = true, def = true} dst,
2478 size = size}
2479 | MD {oper, src, size}
2480 => MD {oper = oper,
2481 src = replacer {use = true, def = false} src,
2482 size = size}
2483 | IMUL2 {src, dst, size}
2484 => IMUL2 {src = replacer {use = true, def = false} src,
2485 dst = replacer {use = true, def = true} dst,
2486 size = size}
2487 | UnAL {oper, dst, size}
2488 => UnAL {oper = oper,
2489 dst = replacer {use = true, def = true} dst,
2490 size = size}
2491 | SRAL {oper, count, dst, size}
2492 => SRAL {oper = oper,
2493 count = replacer {use = true, def = false} count,
2494 dst = replacer {use = true, def = true} dst,
2495 size = size}
2496 | CMP {src1, src2, size}
2497 => CMP {src1 = replacer {use = true, def = false} src1,
2498 src2 = replacer {use = true, def = false} src2,
2499 size = size}
2500 | TEST {src1, src2, size}
2501 => TEST {src1 = replacer {use = true, def = false} src1,
2502 src2 = replacer {use = true, def = false} src2,
2503 size = size}
2504 | SETcc {condition, dst, size}
2505 => SETcc {condition = condition,
2506 dst = replacer {use = false, def = true} dst,
2507 size = size}
2508 | JMP {target, absolute}
2509 => JMP {target = replacer {use = true, def = false} target,
2510 absolute = absolute}
2511 | Jcc {condition, target}
2512 => Jcc {condition = condition,
2513 target = replacer {use = true, def = false} target}
2514 | CALL {target, absolute}
2515 => CALL {target = replacer {use = true, def = false} target,
2516 absolute = absolute}
2517 | RET {src}
2518 => (case src
2519 of NONE => RET {src = NONE}
2520 | SOME src
2521 => RET {src = SOME (replacer {use = true, def = false} src)})
2522 | MOV {src, dst, size}
2523 => MOV {src = replacer {use = true, def = false} src,
2524 dst = replacer {use = false, def = true} dst,
2525 size = size}
2526 | CMOVcc {condition, src, dst, size}
2527 => CMOVcc {condition = condition,
2528 src = replacer {use = true, def = false} src,
2529 dst = replacer {use = false, def = true} dst,
2530 size = size}
2531 | XCHG {src, dst, size}
2532 => XCHG {src = replacer {use = true, def = true} src,
2533 dst = replacer {use = true, def = true} dst,
2534 size = size}
2535 | pPUSH {src, base, size}
2536 => pPUSH {src = replacer {use = true, def = false} src,
2537 base = replacer {use = true, def = true} base,
2538 size = size}
2539 | pPOP {dst, base, size}
2540 => pPOP {dst = replacer {use = false, def = true} dst,
2541 base = replacer {use = true, def = true} base,
2542 size = size}
2543 | PUSH {src, size}
2544 => PUSH {src = replacer {use = true, def = false} src,
2545 size = size}
2546 | POP {dst, size}
2547 => POP {dst = replacer {use = false, def = true} dst,
2548 size = size}
2549 | CX {size}
2550 => CX {size = size}
2551 | MOVX {oper, src, srcsize, dst, dstsize}
2552 => MOVX {oper = oper,
2553 src = replacer {use = true, def = false} src,
2554 srcsize = srcsize,
2555 dst = replacer {use = false, def = true} dst,
2556 dstsize = dstsize}
2557 | XVOM {src, srcsize, dst, dstsize}
2558 => XVOM {src = replacer {use = true, def = false} src,
2559 srcsize = srcsize,
2560 dst = replacer {use = false, def = true} dst,
2561 dstsize = dstsize}
2562 | LEA {src, dst, size}
2563 => LEA {src = replacer {use = true, def = false} src,
2564 dst = replacer {use = false, def = true} dst,
2565 size = size}
2566 | SSE_BinAS {oper, src, dst, size}
2567 => SSE_BinAS {oper = oper,
2568 src = replacer {use = true, def = false} src,
2569 dst = replacer {use = true, def = true} dst,
2570 size = size}
2571 | SSE_UnAS {oper, src, dst, size}
2572 => SSE_UnAS {oper = oper,
2573 src = replacer {use = true, def = false} src,
2574 dst = replacer {use = false, def = true} dst,
2575 size = size}
2576 | SSE_BinLP {oper, src, dst, size}
2577 => SSE_BinLP {oper = oper,
2578 src = replacer {use = true, def = false} src,
2579 dst = replacer {use = true, def = true} dst,
2580 size = size}
2581 | SSE_MOVS {src, dst, size}
2582 => SSE_MOVS {src = replacer {use = true, def = false} src,
2583 dst = replacer {use = false, def = true} dst,
2584 size = size}
2585 | SSE_COMIS {src1, src2, size}
2586 => SSE_COMIS {src1 = replacer {use = true, def = false} src1,
2587 src2 = replacer {use = true, def = false} src2,
2588 size = size}
2589 | SSE_UCOMIS {src1, src2, size}
2590 => SSE_UCOMIS {src1 = replacer {use = true, def = false} src1,
2591 src2 = replacer {use = true, def = false} src2,
2592 size = size}
2593 | SSE_CVTSFP2SFP {src, srcsize, dst, dstsize}
2594 => SSE_CVTSFP2SFP {src = replacer {use = true, def = false} src,
2595 srcsize = srcsize,
2596 dst = replacer {use = false, def = true} dst,
2597 dstsize = dstsize}
2598 | SSE_CVTSFP2SI {src, srcsize, dst, dstsize}
2599 => SSE_CVTSFP2SI {src = replacer {use = true, def = false} src,
2600 srcsize = srcsize,
2601 dst = replacer {use = false, def = true} dst,
2602 dstsize = dstsize}
2603 | SSE_CVTSI2SFP {src, srcsize, dst, dstsize}
2604 => SSE_CVTSI2SFP {src = replacer {use = true, def = false} src,
2605 srcsize = srcsize,
2606 dst = replacer {use = false, def = true} dst,
2607 dstsize = dstsize}
2608 | SSE_MOVD {src, srcsize, dst, dstsize}
2609 => SSE_MOVD {src = replacer {use = true, def = false} src,
2610 srcsize = srcsize,
2611 dst = replacer {use = false, def = true} dst,
2612 dstsize = dstsize}
2613
2614 val nop = fn () => NOP
2615 val hlt = fn () => HLT
2616 val binal = BinAL
2617 val pmd = pMD
2618 val md = MD
2619 val imul2 = IMUL2
2620 val unal = UnAL
2621 val sral = SRAL
2622 val cmp = CMP
2623 val test = TEST
2624 val setcc = SETcc
2625 val jmp = JMP
2626 val jcc = Jcc
2627 val call = CALL
2628 val ret = RET
2629 val mov = MOV
2630 val cmovcc = CMOVcc
2631 val xchg = XCHG
2632 val ppush = pPUSH
2633 val ppop = pPOP
2634 val push = PUSH
2635 val pop = POP
2636 val cx = CX
2637 val movx = MOVX
2638 val xvom = XVOM
2639 val lea = LEA
2640 val sse_binas = SSE_BinAS
2641 val sse_unas = SSE_UnAS
2642 val sse_binlp = SSE_BinLP
2643 val sse_movs = SSE_MOVS
2644 val sse_comis = SSE_COMIS
2645 val sse_ucomis = SSE_UCOMIS
2646 val sse_cvtsfp2sfp = SSE_CVTSFP2SFP
2647 val sse_cvtsfp2si = SSE_CVTSFP2SI
2648 val sse_cvtsi2sfp = SSE_CVTSI2SFP
2649 val sse_movd = SSE_MOVD
2650 end
2651
2652 structure Directive =
2653 struct
2654 structure Id =
2655 struct
2656 val num : int ref = ref 0
2657 datatype t = T of {num : int,
2658 plist: PropertyList.t}
2659 fun new () = let
2660 val id = T {num = !num,
2661 plist = PropertyList.new ()}
2662 val _ = Int.inc num
2663 in
2664 id
2665 end
2666 val plist = fn T {plist, ...} => plist
2667 val layout
2668 = let
2669 open Layout
2670 in
2671 fn T {num, ...} => seq [str "RegAlloc", Int.layout num]
2672 end
2673 val toString = Layout.toString o layout
2674 end
2675
2676 datatype t
2677 (* Transfers *)
2678 (* Assert that a memloc is in a register with properties;
2679 * used at top of basic blocks to establish passing convention.
2680 *)
2681 = Assume of {assumes: {register: Register.t,
2682 memloc: MemLoc.t,
2683 weight: int,
2684 sync: bool,
2685 reserve: bool} list}
2686 | XmmAssume of {assumes: {register: XmmRegister.t,
2687 memloc: MemLoc.t,
2688 weight: int,
2689 sync: bool,
2690 reserve: bool} list}
2691 (* Ensure that memloc is in the register, possibly reserved;
2692 * used at bot of basic blocks to establish passing convention,
2693 * also used before C calls to set-up %rsp.
2694 *)
2695 | Cache of {caches: {register: Register.t,
2696 memloc: MemLoc.t,
2697 reserve: bool} list}
2698 | XmmCache of {caches: {register: XmmRegister.t,
2699 memloc: MemLoc.t,
2700 reserve: bool} list}
2701 (* Reset the register allocation;
2702 * used at bot of basic blocks that fall-thru
2703 * to a block with multiple incoming paths of control.
2704 *)
2705 | Reset
2706 (* Ensure that memlocs are commited to memory;
2707 * used at bot of basic blocks to establish passing conventions
2708 *)
2709 | Force of {commit_memlocs: MemLocSet.t,
2710 commit_classes: ClassSet.t,
2711 remove_memlocs: MemLocSet.t,
2712 remove_classes: ClassSet.t,
2713 dead_memlocs: MemLocSet.t,
2714 dead_classes: ClassSet.t}
2715 (* C calls *)
2716 (* Prepare for a C call; i.e., clear all caller save registers;
2717 * used before C calls.
2718 *)
2719 | CCall
2720 (* Assert the return value;
2721 * used after C calls.
2722 *)
2723 | Return of {returns: {src: Operand.t, dst: MemLoc.t} list}
2724 (* Misc. *)
2725 (* Assert that the register is not free for the allocator;
2726 * used ???
2727 *)
2728 | Reserve of {registers: Register.t list}
2729 | XmmReserve of {registers: XmmRegister.t list}
2730 (* Assert that the register is free for the allocator;
2731 * used to free registers at fall-thru;
2732 * also used after C calls to free %rsp.
2733 *)
2734 | Unreserve of {registers : Register.t list}
2735 | XmmUnreserve of {registers : XmmRegister.t list}
2736 (* Save the register allocation in id and
2737 * assert that live are used at this point;
2738 * used at bot of basic blocks to delay establishment
2739 * of passing convention to compensation block
2740 *)
2741 | SaveRegAlloc of {live: MemLocSet.t,
2742 id: Id.t}
2743 (* Restore the register allocation from id and
2744 * remove anything tracked that is not live;
2745 * used at bot of basic blocks to delay establishment
2746 * of passing convention to compensation block
2747 *)
2748 | RestoreRegAlloc of {live: MemLocSet.t,
2749 id: Id.t}
2750
2751 val toString
2752 = fn Assume {assumes}
2753 => concat["Assume: ",
2754 "assumes: ",
2755 List.fold
2756 (assumes,
2757 "",
2758 fn ({register, memloc, sync, reserve, ...}, s)
2759 => concat[MemLoc.toString memloc,
2760 " -> ", Register.toString register,
2761 if reserve then " (reserved)" else "",
2762 if sync then " (sync)" else "",
2763 " ",
2764 s])]
2765 | XmmAssume {assumes}
2766 => concat["XmmAssume: ",
2767 "assumes: ",
2768 List.fold
2769 (assumes,
2770 "",
2771 fn ({register, memloc, sync, reserve, ...}, s)
2772 => concat[MemLoc.toString memloc,
2773 " -> ", XmmRegister.toString register,
2774 if reserve then " (reserved)" else "",
2775 if sync then " (sync)" else "",
2776 " ",
2777 s])]
2778 | Cache {caches}
2779 => concat["Cache: ",
2780 "caches: ",
2781 List.fold
2782 (caches,
2783 "",
2784 fn ({register, memloc, reserve}, s)
2785 => concat[MemLoc.toString memloc,
2786 " -> ", Register.toString register,
2787 if reserve then " (reserved)" else "",
2788 " ",
2789 s])]
2790 | XmmCache {caches}
2791 => concat["XmmCache: ",
2792 "caches: ",
2793 List.fold
2794 (caches,
2795 "",
2796 fn ({register, memloc, reserve}, s)
2797 => concat[MemLoc.toString memloc,
2798 " -> ", XmmRegister.toString register,
2799 if reserve then " (reserved)" else "",
2800 " ",
2801 s])]
2802 | Force {commit_memlocs, commit_classes,
2803 remove_memlocs, remove_classes,
2804 dead_memlocs, dead_classes}
2805 => concat["Force: ",
2806 "commit_memlocs: ",
2807 MemLocSet.fold
2808 (commit_memlocs,
2809 "",
2810 fn (memloc,s)
2811 => concat[MemLoc.toString memloc, " ", s]),
2812 "commit_classes: ",
2813 ClassSet.fold
2814 (commit_classes,
2815 "",
2816 fn (class,s)
2817 => concat[MemLoc.Class.toString class, " ", s]),
2818 "remove_memlocs: ",
2819 MemLocSet.fold
2820 (remove_memlocs,
2821 "",
2822 fn (memloc,s)
2823 => concat[MemLoc.toString memloc, " ", s]),
2824 "remove_classes: ",
2825 ClassSet.fold
2826 (remove_classes,
2827 "",
2828 fn (class,s)
2829 => concat[MemLoc.Class.toString class, " ", s]),
2830 "dead_memlocs: ",
2831 MemLocSet.fold
2832 (dead_memlocs,
2833 "",
2834 fn (memloc,s)
2835 => concat[MemLoc.toString memloc, " ", s]),
2836 "dead_classes: ",
2837 ClassSet.fold
2838 (dead_classes,
2839 "",
2840 fn (class,s)
2841 => concat[MemLoc.Class.toString class, " ", s])]
2842 | Reset
2843 => concat["Reset"]
2844 | CCall
2845 => concat["CCall"]
2846 | Return {returns}
2847 => concat["Return: ", List.toString (fn {src,dst} =>
2848 concat ["(", Operand.toString src,
2849 ",", MemLoc.toString dst, ")"]) returns]
2850 | Reserve {registers}
2851 => concat["Reserve: ",
2852 "registers: ",
2853 List.fold(registers,
2854 "",
2855 fn (register,s)
2856 => concat[Register.toString register, " ", s])]
2857 | XmmReserve {registers}
2858 => concat["XmmReserve: ",
2859 "registers: ",
2860 List.fold(registers,
2861 "",
2862 fn (register,s)
2863 => concat[XmmRegister.toString register, " ", s])]
2864 | Unreserve {registers}
2865 => concat["Unreserve: ",
2866 "registers: ",
2867 List.fold(registers,
2868 "",
2869 fn (register,s)
2870 => concat[Register.toString register, " ", s])]
2871 | XmmUnreserve {registers}
2872 => concat["XmmUnreserve: ",
2873 "registers: ",
2874 List.fold(registers,
2875 "",
2876 fn (register,s)
2877 => concat[XmmRegister.toString register, " ", s])]
2878 | SaveRegAlloc {live, id}
2879 => concat["SaveRegAlloc: ",
2880 "live: ",
2881 MemLocSet.fold
2882 (live,
2883 "",
2884 fn (memloc,s)
2885 => concat[MemLoc.toString memloc, " ", s]),
2886 Id.toString id]
2887 | RestoreRegAlloc {live, id}
2888 => concat["RestoreRegAlloc: ",
2889 "live: ",
2890 MemLocSet.fold
2891 (live,
2892 "",
2893 fn (memloc,s)
2894 => concat[MemLoc.toString memloc, " ", s]),
2895 Id.toString id]
2896 val layout = Layout.str o toString
2897
2898 val uses_defs_kills
2899 = fn Assume {assumes}
2900 => List.fold
2901 (assumes,
2902 {uses = [], defs = [], kills = []},
2903 fn ({register, memloc, ...},
2904 {uses, defs, ...})
2905 => {uses = (Operand.memloc memloc)::uses,
2906 defs = (Operand.register register)::defs,
2907 kills = []})
2908 | XmmAssume {assumes}
2909 => List.fold
2910 (assumes,
2911 {uses = [], defs = [], kills = []},
2912 fn ({register, memloc, ...},
2913 {uses, defs, ...})
2914 => {uses = (Operand.memloc memloc)::uses,
2915 defs = (Operand.xmmregister register)::defs,
2916 kills = []})
2917 | Cache {caches}
2918 => List.fold
2919 (caches,
2920 {uses = [], defs = [], kills = []},
2921 fn ({register, memloc, ...},
2922 {uses, defs, ...})
2923 => {uses = (Operand.memloc memloc)::uses,
2924 defs = (Operand.register register)::defs,
2925 kills = []})
2926 | XmmCache {caches}
2927 => List.fold
2928 (caches,
2929 {uses = [], defs = [], kills = []},
2930 fn ({register, memloc, ...},
2931 {uses, defs, ...})
2932 => {uses = (Operand.memloc memloc)::uses,
2933 defs = (Operand.xmmregister register)::defs,
2934 kills = []})
2935 | Reset => {uses = [], defs = [], kills = []}
2936 | Force {commit_memlocs, remove_memlocs, ...}
2937 => {uses = List.map(MemLocSet.toList commit_memlocs, Operand.memloc) @
2938 List.map(MemLocSet.toList remove_memlocs, Operand.memloc),
2939 defs = [],
2940 kills = []}
2941 | CCall => {uses = [], defs = [], kills = []}
2942 | Return {returns}
2943 => let
2944 val uses = List.map(returns, fn {src, ...} => src)
2945 val defs = List.map(returns, fn {dst, ...} => Operand.memloc dst)
2946 in
2947 {uses = uses, defs = defs, kills = []}
2948 end
2949 | Reserve {...} => {uses = [], defs = [], kills = []}
2950 | XmmReserve {...} => {uses = [], defs = [], kills = []}
2951 | Unreserve {...} => {uses = [], defs = [], kills = []}
2952 | XmmUnreserve {...} => {uses = [], defs = [], kills = []}
2953 | SaveRegAlloc {live, ...}
2954 => {uses = List.map(MemLocSet.toList live, Operand.memloc),
2955 defs = [],
2956 kills = []}
2957 | RestoreRegAlloc {...}
2958 => {uses = [], defs = [], kills = []}
2959
2960 val hints
2961 = fn Cache {caches}
2962 => List.map
2963 (caches,
2964 fn {register, memloc, ...}
2965 => (memloc, register))
2966 | _ => []
2967
2968 fun replace replacer
2969 = fn Assume {assumes}
2970 => Assume {assumes
2971 = List.map
2972 (assumes,
2973 fn {register, memloc, weight, sync, reserve}
2974 => {register = register,
2975 memloc = memloc,
2976 weight = weight,
2977 sync = sync,
2978 reserve = reserve})}
2979 | XmmAssume {assumes}
2980 => XmmAssume {assumes
2981 = List.map
2982 (assumes,
2983 fn {register, memloc, weight, sync, reserve}
2984 => {register = register,
2985 memloc = memloc,
2986 weight = weight,
2987 sync = sync,
2988 reserve = reserve})}
2989 | Cache {caches}
2990 => Cache {caches
2991 = List.map
2992 (caches,
2993 fn {register, memloc, reserve}
2994 => {register = case replacer {use = false, def = true}
2995 (Operand.register register)
2996 of Operand.Register register => register
2997 | _ => Error.bug "amd64.Directive.replace: Cache, register",
2998 memloc = case replacer {use = true, def = false}
2999 (Operand.memloc memloc)
3000 of Operand.MemLoc memloc => memloc
3001 | _ => Error.bug "amd64.Directive.replace: Cache, memloc",
3002 reserve = reserve})}
3003 | XmmCache {caches}
3004 => XmmCache {caches
3005 = List.map
3006 (caches,
3007 fn {register, memloc, reserve}
3008 => {register = case replacer {use = false, def = true}
3009 (Operand.xmmregister register)
3010 of Operand.XmmRegister register => register
3011 | _ => Error.bug "amd64.Directive.replace: XmmCache, xmmregister",
3012 memloc = case replacer {use = true, def = false}
3013 (Operand.memloc memloc)
3014 of Operand.MemLoc memloc => memloc
3015 | _ => Error.bug "amd64.Directive.replace: XmmCache, memloc",
3016 reserve = reserve})}
3017 | Reset => Reset
3018 | Force {commit_memlocs, commit_classes,
3019 remove_memlocs, remove_classes,
3020 dead_memlocs, dead_classes}
3021 => Force {commit_memlocs = MemLocSet.map
3022 (commit_memlocs,
3023 fn memloc
3024 => case replacer
3025 {use = true, def = false}
3026 (Operand.memloc memloc)
3027 of Operand.MemLoc memloc => memloc
3028 | _ => Error.bug "amd64.Directive.replace: Force, commit_memlocs"),
3029 commit_classes = commit_classes,
3030 remove_memlocs = MemLocSet.map
3031 (remove_memlocs,
3032 fn memloc
3033 => case replacer
3034 {use = true, def = false}
3035 (Operand.memloc memloc)
3036 of Operand.MemLoc memloc => memloc
3037 | _ => Error.bug "amd64.Directive.replace: Force, remove_memlocs"),
3038 remove_classes = remove_classes,
3039 dead_memlocs = MemLocSet.map
3040 (dead_memlocs,
3041 fn memloc
3042 => case replacer
3043 {use = false, def = false}
3044 (Operand.memloc memloc)
3045 of Operand.MemLoc memloc => memloc
3046 | _ => Error.bug "amd64.Directive.replace: Force, dead_memlocs"),
3047 dead_classes = dead_classes}
3048 | CCall => CCall
3049 | Return {returns}
3050 => Return {returns = List.map
3051 (returns, fn {src,dst} =>
3052 {src = src,
3053 dst =
3054 case replacer {use = true, def = false}
3055 (Operand.memloc dst)
3056 of Operand.MemLoc memloc => memloc
3057 | _ => Error.bug "amd64.Directive.replace: Return, returns"})}
3058 | Reserve {registers} => Reserve {registers = registers}
3059 | XmmReserve {registers} => XmmReserve {registers = registers}
3060 | Unreserve {registers} => Unreserve {registers = registers}
3061 | XmmUnreserve {registers} => XmmUnreserve {registers = registers}
3062 | SaveRegAlloc {live, id} => SaveRegAlloc {live = live, id = id}
3063 | RestoreRegAlloc {live, id} => RestoreRegAlloc {live = live, id = id}
3064
3065 val assume = Assume
3066 val xmmassume = XmmAssume
3067 val cache = Cache
3068 val xmmcache = XmmCache
3069 val reset = fn () => Reset
3070 val force = Force
3071 val ccall = fn () => CCall
3072 val return = Return
3073 val reserve = Reserve
3074 val xmmreserve = XmmReserve
3075 val unreserve = Unreserve
3076 val xmmunreserve = XmmUnreserve
3077 val saveregalloc = SaveRegAlloc
3078 val restoreregalloc = RestoreRegAlloc
3079 end
3080
3081 structure PseudoOp =
3082 struct
3083 datatype t
3084 = Data
3085 | Text
3086 | SymbolStub
3087 | Balign of Immediate.t * Immediate.t option * Immediate.t option
3088 | P2align of Immediate.t * Immediate.t option * Immediate.t option
3089 | Space of Immediate.t * Immediate.t
3090 | Byte of Immediate.t list
3091 | Word of Immediate.t list
3092 | Long of Immediate.t list
3093 | Quad of Immediate.t list
3094 | String of string list
3095 | Global of Label.t
3096 | Hidden of Label.t
3097 | IndirectSymbol of Label.t
3098 | Local of Label.t
3099 | Comm of Label.t * Immediate.t * Immediate.t option
3100
3101 val layout
3102 = let
3103 open Layout
3104 in
3105 fn Data => str ".data"
3106 | Text => str ".text"
3107 | SymbolStub
3108 => str ".section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5"
3109 | Balign (i,fill,max)
3110 => seq [str ".balign ",
3111 Immediate.layout i,
3112 case (fill, max)
3113 of (NONE, NONE) => empty
3114 | (SOME fill, NONE) => seq [str ",",
3115 Immediate.layout fill]
3116 | (NONE, SOME max) => seq [str ",,",
3117 Immediate.layout max]
3118 | (SOME fill, SOME max) => seq [str ",",
3119 Immediate.layout fill,
3120 str ",",
3121 Immediate.layout max]]
3122 | P2align (i,fill,max)
3123 => seq [str ".p2align ",
3124 Immediate.layout i,
3125 case (fill, max)
3126 of (NONE, NONE) => empty
3127 | (SOME fill, NONE) => seq [str ",",
3128 Immediate.layout fill]
3129 | (NONE, SOME max) => seq [str ",,",
3130 Immediate.layout max]
3131 | (SOME fill, SOME max) => seq [str ",",
3132 Immediate.layout fill,
3133 str ",",
3134 Immediate.layout max]]
3135 | Space (i,f)
3136 => seq [str ".space ",
3137 Immediate.layout i,
3138 str ",",
3139 Immediate.layout f]
3140 | Byte bs
3141 => seq [str ".byte ",
3142 seq (separate(List.map (bs, Immediate.layout), ","))]
3143 | Word ws
3144 => seq [str ".word ",
3145 seq (separate(List.map (ws, Immediate.layout), ","))]
3146 | Long ls
3147 => seq [str ".long ",
3148 seq (separate(List.map (ls, Immediate.layout), ","))]
3149 | Quad ls
3150 => seq [str ".quad ",
3151 seq (separate(List.map (ls, Immediate.layout), ","))]
3152 | String ss
3153 => seq [str ".ascii ",
3154 seq (separate(List.map
3155 (ss,
3156 fn s => seq [str "\"",
3157 str (String_escapeASM s),
3158 str "\""]),
3159 ","))]
3160 | Global l
3161 => seq [str ".globl ",
3162 Label.layout l]
3163 | Hidden l
3164 => (* visibility directive depends on target object file *)
3165 let
3166 val elf = seq [str ".hidden ", Label.layout l]
3167 val macho = seq [str ".private_extern ", Label.layout l]
3168 val coff = seq [str "/* ", str ".hidden ", Label.layout l, str " */"]
3169 in
3170 case !Control.Target.os of
3171 MLton.Platform.OS.Cygwin => coff
3172 | MLton.Platform.OS.Darwin => macho
3173 | MLton.Platform.OS.MinGW => coff
3174 | _ => elf
3175 end
3176 | IndirectSymbol l
3177 => seq [str ".indirect_symbol ",
3178 Label.layout l]
3179 | Local l
3180 => seq [str ".local ",
3181 Label.layout l]
3182 | Comm (l, i, a)
3183 => seq [str ".comm ",
3184 Label.layout l,
3185 str ",",
3186 Immediate.layout i,
3187 case a of NONE => empty
3188 | SOME i => seq [str ",", Immediate.layout i]]
3189 end
3190 val toString = Layout.toString o layout
3191
3192 fun replace replacer
3193 = let
3194 val replacerLabel
3195 = fn label
3196 => case Operand.deLabel
3197 (replacer {use = true, def = false}
3198 (Operand.label label))
3199 of SOME label => label
3200 | NONE => Error.bug "amd64.PseudoOp.replace.replacerLabel"
3201 val replacerImmediate
3202 = fn immediate
3203 => case Operand.deImmediate
3204 (replacer {use = true, def = false}
3205 (Operand.immediate immediate))
3206 of SOME immediate => immediate
3207 | NONE => Error.bug "amd64.PseudoOp.replace.replacerImmediate"
3208 in
3209 fn Data => Data
3210 | Text => Text
3211 | SymbolStub => SymbolStub
3212 | Balign (i,fill,max) => Balign (replacerImmediate i,
3213 Option.map(fill, replacerImmediate),
3214 Option.map(max, replacerImmediate))
3215 | P2align (i,fill,max) => P2align (replacerImmediate i,
3216 Option.map(fill, replacerImmediate),
3217 Option.map(max, replacerImmediate))
3218 | Space (i,f) => Space (replacerImmediate i, replacerImmediate f)
3219 | Byte bs => Byte (List.map(bs, replacerImmediate))
3220 | Word ws => Word (List.map(ws, replacerImmediate))
3221 | Long ls => Long (List.map(ls, replacerImmediate))
3222 | Quad ls => Quad (List.map(ls, replacerImmediate))
3223 | String ss => String ss
3224 | Global l => Global (replacerLabel l)
3225 | Hidden l => Hidden (replacerLabel l)
3226 | IndirectSymbol l => IndirectSymbol (replacerLabel l)
3227 | Local l => Local (replacerLabel l)
3228 | Comm (l, i, a) => Comm (replacerLabel l,
3229 replacerImmediate i,
3230 Option.map(a, replacerImmediate))
3231 end
3232
3233 val data = fn () => Data
3234 val text = fn () => Text
3235 val symbol_stub = fn () => SymbolStub
3236 val balign = Balign
3237 val p2align = P2align
3238 val space = Space
3239 val byte = Byte
3240 val word = Word
3241 val long = Long
3242 val quad = Quad
3243 val string = String
3244 val global = Global
3245 val hidden = Hidden
3246 val indirect_symbol = IndirectSymbol
3247 val locall = Local
3248 val comm = Comm
3249 end
3250
3251 structure Assembly =
3252 struct
3253 datatype t
3254 = Comment of string
3255 | Directive of Directive.t
3256 | PseudoOp of PseudoOp.t
3257 | Label of Label.t
3258 | Instruction of Instruction.t
3259
3260 val layout
3261 = let
3262 open Layout
3263 in
3264 fn Comment s => seq [str "/* ", str s, str " */"]
3265 | Directive d => seq [str "# directive: ", Directive.layout d]
3266 | PseudoOp p => seq [PseudoOp.layout p]
3267 | Label l => seq [Label.layout l, str ":"]
3268 | Instruction i => seq [str "\t", Instruction.layout i]
3269 end
3270 val toString = Layout.toString o layout
3271
3272 val uses_defs_kills
3273 = fn Comment _ => {uses = [], defs = [], kills = []}
3274 | Directive d => Directive.uses_defs_kills d
3275 | PseudoOp _ => {uses = [], defs = [], kills = []}
3276 | Label _ => {uses = [], defs = [], kills = []}
3277 | Instruction i => Instruction.uses_defs_kills i
3278
3279 val hints
3280 = fn Comment _ => []
3281 | Directive d => Directive.hints d
3282 | PseudoOp _ => []
3283 | Label _ => []
3284 | Instruction i => Instruction.hints i
3285
3286 fun replace replacer
3287 = fn Comment s => Comment s
3288 | Directive d => Directive (Directive.replace replacer d)
3289 | PseudoOp p => PseudoOp (PseudoOp.replace replacer p)
3290 | Label l => Label (case Operand.deLabel
3291 (replacer {use = false, def = true}
3292 (Operand.label l))
3293 of SOME l => l
3294 | NONE => Error.bug "amd64.Assembly.replace, Label")
3295 | Instruction i => Instruction (Instruction.replace replacer i)
3296
3297 val comment = Comment
3298 val isComment = fn Comment _ => true | _ => false
3299 val directive = Directive
3300 val directive_assume = Directive o Directive.assume
3301 val directive_xmmassume = Directive o Directive.xmmassume
3302 val directive_cache = Directive o Directive.cache
3303 val directive_xmmcache = Directive o Directive.xmmcache
3304 val directive_reset = Directive o Directive.reset
3305 val directive_force = Directive o Directive.force
3306 val directive_ccall = Directive o Directive.ccall
3307 val directive_return = Directive o Directive.return
3308 val directive_reserve = Directive o Directive.reserve
3309 val directive_xmmreserve = Directive o Directive.xmmreserve
3310 val directive_unreserve = Directive o Directive.unreserve
3311 val directive_xmmunreserve = Directive o Directive.xmmunreserve
3312 val directive_saveregalloc = Directive o Directive.saveregalloc
3313 val directive_restoreregalloc = Directive o Directive.restoreregalloc
3314 val pseudoop = PseudoOp
3315 val pseudoop_data = PseudoOp o PseudoOp.data
3316 val pseudoop_text = PseudoOp o PseudoOp.text
3317 val pseudoop_symbol_stub = PseudoOp o PseudoOp.symbol_stub
3318 val pseudoop_balign = PseudoOp o PseudoOp.balign
3319 val pseudoop_p2align = PseudoOp o PseudoOp.p2align
3320 val pseudoop_space = PseudoOp o PseudoOp.space
3321 val pseudoop_byte = PseudoOp o PseudoOp.byte
3322 val pseudoop_word = PseudoOp o PseudoOp.word
3323 val pseudoop_long = PseudoOp o PseudoOp.long
3324 val pseudoop_quad = PseudoOp o PseudoOp.quad
3325 val pseudoop_string = PseudoOp o PseudoOp.string
3326 val pseudoop_global = PseudoOp o PseudoOp.global
3327 val pseudoop_hidden = PseudoOp o PseudoOp.hidden
3328 val pseudoop_indirect_symbol = PseudoOp o PseudoOp.indirect_symbol
3329 val pseudoop_local = PseudoOp o PseudoOp.locall
3330 val pseudoop_comm = PseudoOp o PseudoOp.comm
3331 val label = Label
3332 val instruction = Instruction
3333 val instruction_nop = Instruction o Instruction.nop
3334 val instruction_hlt = Instruction o Instruction.hlt
3335 val instruction_binal = Instruction o Instruction.binal
3336 val instruction_pmd = Instruction o Instruction.pmd
3337 val instruction_md = Instruction o Instruction.md
3338 val instruction_imul2 = Instruction o Instruction.imul2
3339 val instruction_unal = Instruction o Instruction.unal
3340 val instruction_sral = Instruction o Instruction.sral
3341 val instruction_cmp = Instruction o Instruction.cmp
3342 val instruction_test = Instruction o Instruction.test
3343 val instruction_setcc = Instruction o Instruction.setcc
3344 val instruction_jmp = Instruction o Instruction.jmp
3345 val instruction_jcc = Instruction o Instruction.jcc
3346 val instruction_call = Instruction o Instruction.call
3347 val instruction_ret = Instruction o Instruction.ret
3348 val instruction_mov = Instruction o Instruction.mov
3349 val instruction_cmovcc = Instruction o Instruction.cmovcc
3350 val instruction_xchg = Instruction o Instruction.xchg
3351 val instruction_ppush = Instruction o Instruction.ppush
3352 val instruction_ppop = Instruction o Instruction.ppop
3353 val instruction_push = Instruction o Instruction.push
3354 val instruction_pop = Instruction o Instruction.pop
3355 val instruction_cx = Instruction o Instruction.cx
3356 val instruction_movx = Instruction o Instruction.movx
3357 val instruction_xvom = Instruction o Instruction.xvom
3358 val instruction_lea = Instruction o Instruction.lea
3359 val instruction_sse_binas = Instruction o Instruction.sse_binas
3360 val instruction_sse_unas = Instruction o Instruction.sse_unas
3361 val instruction_sse_binlp = Instruction o Instruction.sse_binlp
3362 val instruction_sse_movs = Instruction o Instruction.sse_movs
3363 val instruction_sse_comis = Instruction o Instruction.sse_comis
3364 val instruction_sse_ucomis = Instruction o Instruction.sse_ucomis
3365 val instruction_sse_cvtsfp2sfp = Instruction o Instruction.sse_cvtsfp2sfp
3366 val instruction_sse_cvtsfp2si = Instruction o Instruction.sse_cvtsfp2si
3367 val instruction_sse_cvtsi2sfp = Instruction o Instruction.sse_cvtsi2sfp
3368 val instruction_sse_movd = Instruction o Instruction.sse_movd
3369 end
3370
3371 structure FrameInfo =
3372 struct
3373 datatype t = T of {size: int,
3374 frameLayoutsIndex: int}
3375
3376 fun toString (T {size, frameLayoutsIndex})
3377 = concat ["{",
3378 "size = ", Int.toString size, ", ",
3379 "frameLayoutsIndex = ",
3380 Int.toString frameLayoutsIndex, "}"]
3381 end
3382
3383 structure Entry =
3384 struct
3385 datatype t
3386 = Jump of {label: Label.t}
3387 | Func of {label: Label.t,
3388 live: MemLocSet.t}
3389 | Cont of {label: Label.t,
3390 live: MemLocSet.t,
3391 frameInfo: FrameInfo.t}
3392 | Handler of {frameInfo: FrameInfo.t,
3393 label: Label.t,
3394 live: MemLocSet.t}
3395 | CReturn of {dsts: (Operand.t * Size.t) vector,
3396 frameInfo: FrameInfo.t option,
3397 func: RepType.t CFunction.t,
3398 label: Label.t}
3399
3400 val toString
3401 = fn Jump {label} => concat ["Jump::",
3402 Label.toString label]
3403 | Func {label, live}
3404 => concat ["Func::",
3405 Label.toString label,
3406 " [",
3407 (concat o List.separate)
3408 (MemLocSet.fold
3409 (live,
3410 [],
3411 fn (memloc, l) => (MemLoc.toString memloc)::l),
3412 ", "),
3413 "]"]
3414 | Cont {label, live, frameInfo}
3415 => concat ["Cont::",
3416 Label.toString label,
3417 " [",
3418 (concat o List.separate)
3419 (MemLocSet.fold
3420 (live,
3421 [],
3422 fn (memloc, l) => (MemLoc.toString memloc)::l),
3423 ", "),
3424 "] ",
3425 FrameInfo.toString frameInfo]
3426 | Handler {frameInfo, label, live}
3427 => concat ["Handler::",
3428 Label.toString label,
3429 " [",
3430 (concat o List.separate)
3431 (MemLocSet.fold
3432 (live,
3433 [],
3434 fn (memloc, l) => (MemLoc.toString memloc)::l),
3435 ", "),
3436 "] (",
3437 FrameInfo.toString frameInfo,
3438 ")"]
3439 | CReturn {dsts, frameInfo, func, label}
3440 => concat ["CReturn::",
3441 Label.toString label,
3442 " ",
3443 Vector.toString (fn (dst,_) => Operand.toString dst) dsts,
3444 " ",
3445 (CFunction.Target.toString o CFunction.target) func,
3446 " ",
3447 case frameInfo of
3448 NONE => ""
3449 | SOME f => FrameInfo.toString f]
3450
3451 val uses_defs_kills
3452 = fn CReturn {dsts, func, ...}
3453 => let
3454 val uses =
3455 List.map (Operand.cReturnTemps (CFunction.return func),
3456 fn {dst, ...} => Operand.memloc dst)
3457 in
3458 {uses = uses,
3459 defs = Vector.toListMap(dsts, fn (dst, _) => dst),
3460 kills = []}
3461 end
3462 | _ => {uses = [], defs = [], kills = []}
3463
3464 val label
3465 = fn Jump {label, ...} => label
3466 | Func {label, ...} => label
3467 | Cont {label, ...} => label
3468 | Handler {label, ...} => label
3469 | CReturn {label, ...} => label
3470
3471 val live
3472 = fn Func {live, ...} => live
3473 | Cont {live, ...} => live
3474 | Handler {live, ...} => live
3475 | _ => MemLocSet.empty
3476
3477 val jump = Jump
3478 val func = Func
3479 val isFunc = fn Func _ => true | _ => false
3480 val cont = Cont
3481 val handler = Handler
3482 val creturn = CReturn
3483 end
3484
3485 structure Transfer =
3486 struct
3487 structure Cases =
3488 struct
3489 datatype 'a t = Word of (WordX.t * 'a) list
3490
3491 val word = Word
3492
3493 fun isEmpty cases
3494 = case cases
3495 of Word [] => true
3496 | _ => false
3497
3498 fun isSingle cases
3499 = case cases
3500 of Word [_] => true
3501 | _ => false
3502
3503 fun extract(cases,f)
3504 = let
3505 fun doit [(k,target)] = f (k, target)
3506 | doit _ = Error.bug "amd64.Transfer.Cases.extract"
3507 in
3508 case cases
3509 of Word cases => doit cases
3510 end
3511
3512 fun count(cases, p)
3513 = let
3514 fun doit [] = (0 : int)
3515 | doit ((_,target)::cases) = let
3516 val n = doit cases
3517 in
3518 if p target
3519 then 1 + n
3520 else n
3521 end
3522 in
3523 case cases
3524 of Word cases => doit cases
3525 end
3526
3527 fun keepAll(cases, p)
3528 = let
3529 fun doit l = List.keepAll(l, fn (k,target) => p (k,target))
3530 in
3531 case cases
3532 of Word cases => Word(doit cases)
3533 end
3534
3535 fun forall(cases, f)
3536 = let
3537 fun doit l = List.forall(l, fn (k, target) => f (k, target))
3538 in
3539 case cases
3540 of Word cases => doit cases
3541 end
3542
3543 fun foreach(cases, f)
3544 = let
3545 fun doit l = List.foreach(l, fn (k, target) => f (k, target))
3546 in
3547 case cases
3548 of Word cases => doit cases
3549 end
3550
3551 fun map(cases, f)
3552 = let
3553 fun doit l = List.map(l, fn (k,target) => (k, f (k, target)))
3554 in
3555 case cases
3556 of Word cases => Word(doit cases)
3557 end
3558
3559 fun mapToList(cases, f)
3560 = let
3561 fun doit l = List.map(l, fn (k,target) => f (k, target))
3562 in
3563 case cases
3564 of Word cases => doit cases
3565 end
3566 end
3567
3568 datatype t
3569 = Goto of {target: Label.t}
3570 | Iff of {condition: Instruction.condition,
3571 truee: Label.t,
3572 falsee: Label.t}
3573 | Switch of {test: Operand.t,
3574 cases: Label.t Cases.t,
3575 default: Label.t}
3576 | Tail of {target: Label.t,
3577 live: MemLocSet.t}
3578 | NonTail of {target: Label.t,
3579 live: MemLocSet.t,
3580 return: Label.t,
3581 handler: Label.t option,
3582 size: int}
3583 | Return of {live: MemLocSet.t}
3584 | Raise of {live: MemLocSet.t}
3585 | CCall of {args: (Operand.t * Size.t) list,
3586 frameInfo: FrameInfo.t option,
3587 func: RepType.t CFunction.t,
3588 return: Label.t option}
3589
3590 val toString
3591 = fn Goto {target}
3592 => concat ["GOTO ",
3593 Label.toString target]
3594 | Iff {condition, truee, falsee}
3595 => concat["IF ",
3596 Instruction.condition_toString condition,
3597 " THEN GOTO ",
3598 Label.toString truee,
3599 " ELSE GOTO ",
3600 Label.toString falsee]
3601 | Switch {test, cases, default}
3602 => (concat["SWITCH ",
3603 Operand.toString test]) ^
3604 (concat o Cases.mapToList)
3605 (cases,
3606 fn (w, target) => concat[" (",
3607 WordX.toString w,
3608 " -> GOTO ",
3609 Label.toString target,
3610 ")"]) ^
3611 (concat[" GOTO ",
3612 Label.toString default])
3613 | Tail {target, live}
3614 => concat ["TAIL ",
3615 Label.toString target,
3616 " [",
3617 (concat o List.separate)
3618 (MemLocSet.fold
3619 (live,
3620 [],
3621 fn (memloc, l) => (MemLoc.toString memloc)::l),
3622 ", "),
3623 "]"]
3624 | NonTail {target, live, return, handler, size}
3625 => concat ["NONTAIL ",
3626 Label.toString target,
3627 " [",
3628 (concat o List.separate)
3629 (MemLocSet.fold
3630 (live,
3631 [],
3632 fn (memloc, l) => (MemLoc.toString memloc)::l),
3633 ", "),
3634 "] <",
3635 Label.toString return,
3636 " ",
3637 Int.toString size,
3638 "> {",
3639 case handler
3640 of SOME handler => Label.toString handler
3641 | NONE => "",
3642 "}"]
3643 | Return {live}
3644 => concat ["RETURN",
3645 " [",
3646 (concat o List.separate)
3647 (MemLocSet.fold
3648 (live,
3649 [],
3650 fn (memloc, l) => (MemLoc.toString memloc)::l),
3651 ", "),
3652 "]"]
3653 | Raise {live}
3654 => concat ["RAISE",
3655 " [",
3656 (concat o List.separate)
3657 (MemLocSet.fold
3658 (live,
3659 [],
3660 fn (memloc, l) => (MemLoc.toString memloc)::l),
3661 ", "),
3662 "]"]
3663 | CCall {args, func, return, ...}
3664 => concat ["CCALL ",
3665 (CFunction.Convention.toString o CFunction.convention) func,
3666 " ",
3667 (CFunction.Target.toString o CFunction.target) func,
3668 "(",
3669 (concat o List.separate)
3670 (List.map(args, fn (oper,_) => Operand.toString oper),
3671 ", "),
3672 ") <",
3673 Option.toString Label.toString return,
3674 ">"]
3675
3676 val uses_defs_kills
3677 = fn Switch {test, ...}
3678 => {uses = [test], defs = [], kills = []}
3679 | CCall {args, func, ...}
3680 => let
3681 val defs =
3682 List.map (Operand.cReturnTemps (CFunction.return func),
3683 fn {dst, ...} => Operand.memloc dst)
3684 in
3685 {uses = List.map(args, fn (oper,_) => oper),
3686 defs = defs, kills = []}
3687 end
3688 | _ => {uses = [], defs = [], kills = []}
3689
3690 val nearTargets
3691 = fn Goto {target} => [target]
3692 | Iff {truee,falsee,...} => [truee,falsee]
3693 | Switch {cases,default,...}
3694 => default::(Cases.mapToList
3695 (cases,
3696 fn (_,target) => target))
3697 | NonTail {return,handler,...} => return::(case handler
3698 of NONE => nil
3699 | SOME handler => [handler])
3700 | CCall {return, ...}
3701 => (case return of
3702 NONE => []
3703 | SOME l => [l])
3704 | _ => []
3705
3706 val live
3707 = fn Tail {live,...} => live
3708 | NonTail {live,...} => live
3709 | Return {live,...} => live
3710 | Raise {live,...} => live
3711 | _ => MemLocSet.empty
3712
3713 fun replace replacer
3714 = fn Switch {test, cases, default}
3715 => Switch {test = replacer {use = true, def = false} test,
3716 cases = cases,
3717 default = default}
3718 | CCall {args, frameInfo, func, return}
3719 => CCall {args = List.map(args,
3720 fn (oper,size) => (replacer {use = true,
3721 def = false}
3722 oper,
3723 size)),
3724 frameInfo = frameInfo,
3725 func = func,
3726 return = return}
3727 | transfer => transfer
3728
3729 val goto = Goto
3730 val iff = Iff
3731 val switch = Switch
3732 val tail = Tail
3733 val nontail = NonTail
3734 val return = Return
3735 val raisee = Raise
3736 val ccall = CCall
3737 end
3738
3739 structure ProfileLabel =
3740 struct
3741 open ProfileLabel
3742
3743 fun toAssembly pl =
3744 let
3745 val label = Label.fromString (toString pl)
3746 in
3747 [Assembly.pseudoop_global label,
3748 Assembly.pseudoop_hidden label,
3749 Assembly.label label]
3750 end
3751 fun toAssemblyOpt pl =
3752 case pl of
3753 NONE => []
3754 | SOME pl => toAssembly pl
3755 end
3756
3757 structure Block =
3758 struct
3759 datatype t' = T' of {entry: Entry.t option,
3760 profileLabel: ProfileLabel.t option,
3761 statements: Assembly.t list,
3762 transfer: Transfer.t option}
3763 fun mkBlock' {entry, statements, transfer} =
3764 T' {entry = entry,
3765 profileLabel = NONE,
3766 statements = statements,
3767 transfer = transfer}
3768 fun mkProfileBlock' {profileLabel} =
3769 T' {entry = NONE,
3770 profileLabel = SOME profileLabel,
3771 statements = [],
3772 transfer = NONE}
3773
3774 datatype t = T of {entry: Entry.t,
3775 profileLabel: ProfileLabel.t option,
3776 statements: Assembly.t list,
3777 transfer: Transfer.t}
3778
3779 fun printBlock (T {entry, profileLabel, statements, transfer, ...})
3780 = (print (Entry.toString entry);
3781 print ":\n";
3782 Option.app
3783 (profileLabel, fn profileLabel =>
3784 (print (ProfileLabel.toString profileLabel);
3785 print ":\n"));
3786 List.foreach
3787 (statements, fn asm =>
3788 (print (Assembly.toString asm);
3789 print "\n"));
3790 print (Transfer.toString transfer);
3791 print "\n")
3792
3793 fun printBlock' (T' {entry, profileLabel, statements, transfer, ...})
3794 = (print (if isSome entry
3795 then Entry.toString (valOf entry)
3796 else "---");
3797 print ":\n";
3798 Option.app
3799 (profileLabel, fn profileLabel =>
3800 (print (ProfileLabel.toString profileLabel);
3801 print ":\n"));
3802 List.foreach
3803 (statements, fn asm =>
3804 (print (Assembly.toString asm);
3805 print "\n"));
3806 print (if isSome transfer
3807 then Transfer.toString (valOf transfer)
3808 else "NONE");
3809 print "\n")
3810
3811 val compress': t' list -> t' list =
3812 fn l =>
3813 List.fold
3814 (rev l, [],
3815 fn (b' as T' {entry, profileLabel, statements, transfer}, ac) =>
3816 case transfer of
3817 SOME _ => b' :: ac
3818 | NONE =>
3819 case ac of
3820 [] => Error.bug "amd64.Block.compress': dangling transfer"
3821 | b2' :: ac =>
3822 let
3823 val T' {entry = entry2,
3824 profileLabel = profileLabel2,
3825 statements = statements2,
3826 transfer = transfer2} = b2'
3827 in
3828 case entry2 of
3829 SOME _ =>
3830 Error.bug "amd64.Block.compress': mismatched transfer"
3831 | NONE =>
3832 let
3833 val (pl, ss) =
3834 case (profileLabel, statements) of
3835 (NONE, []) =>
3836 (profileLabel2, statements2)
3837 | _ =>
3838 (profileLabel,
3839 statements
3840 @ (ProfileLabel.toAssemblyOpt
3841 profileLabel2)
3842 @ statements2)
3843 in
3844 T' {entry = entry,
3845 profileLabel = pl,
3846 statements = ss,
3847 transfer = transfer2} :: ac
3848 end
3849 end)
3850
3851 val compress: t' list -> t list =
3852 fn l =>
3853 List.map
3854 (compress' l, fn T' {entry, profileLabel, statements, transfer} =>
3855 case (entry, transfer) of
3856 (SOME e, SOME t) =>
3857 T {entry = e,
3858 profileLabel = profileLabel,
3859 statements = statements,
3860 transfer = t}
3861 | _ => Error.bug "amd64.Block.compress")
3862 end
3863
3864 structure Chunk =
3865 struct
3866 datatype t = T of {data: Assembly.t list,
3867 blocks: Block.t list}
3868 end
3869end
mlton packaging