Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009 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 | ||
10 | functor x86Translate(S: X86_TRANSLATE_STRUCTS): X86_TRANSLATE = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | val tracerTop = x86.tracerTop | |
16 | ||
17 | fun argsToString(ss: string list): string | |
18 | = "(" ^ (concat (List.separate(ss, ", "))) ^ ")" | |
19 | ||
20 | structure Machine = x86MLton.Machine | |
21 | ||
22 | local | |
23 | open Machine | |
24 | in | |
25 | structure Label = Label | |
26 | structure Live = Live | |
27 | structure Register = Register | |
28 | structure Scale = Scale | |
29 | structure StackOffset = StackOffset | |
30 | structure Type = Type | |
31 | structure WordSize = WordSize | |
32 | structure WordX = WordX | |
33 | end | |
34 | ||
35 | datatype z = datatype WordSize.prim | |
36 | ||
37 | structure Global = | |
38 | struct | |
39 | open Machine.Global | |
40 | ||
41 | fun toX86Operand (g: t) : (x86.Operand.t * x86.Size.t) vector = | |
42 | let | |
43 | val ty = Machine.Type.toCType (ty g) | |
44 | val index = index g | |
45 | val base = | |
46 | x86.Immediate.label | |
47 | (if isRoot g | |
48 | then x86MLton.global_base ty | |
49 | else x86MLton.globalObjptrNonRoot_base) | |
50 | val origin = | |
51 | x86.MemLoc.imm | |
52 | {base = base, | |
53 | index = x86.Immediate.int index, | |
54 | scale = x86.Scale.fromCType ty, | |
55 | size = x86.Size.BYTE, | |
56 | class = x86MLton.Classes.Globals} | |
57 | val sizes = x86.Size.fromCType ty | |
58 | in | |
59 | (#1 o Vector.mapAndFold) | |
60 | (sizes, 0, fn (size,offset) => | |
61 | (((x86.Operand.memloc o x86.MemLoc.shift) | |
62 | {origin = origin, | |
63 | disp = x86.Immediate.int offset, | |
64 | scale = x86.Scale.One, | |
65 | size = size}, size), offset + x86.Size.toBytes size)) | |
66 | end | |
67 | end | |
68 | ||
69 | structure Operand = | |
70 | struct | |
71 | open Machine.Operand | |
72 | ||
73 | fun get (f: ('a * 'b) -> 'c) (i: int) (v: ('a * 'b) vector) = | |
74 | f (Vector.sub (v, i)) | |
75 | fun getOp0 v = | |
76 | get #1 0 v | |
77 | ||
78 | val rec toX86Operand : t -> (x86.Operand.t * x86.Size.t) vector = | |
79 | fn ArrayOffset {base, index, offset, scale, ty} | |
80 | => let | |
81 | val base = toX86Operand base | |
82 | val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/base", | |
83 | fn () => Vector.length base = 1) | |
84 | val base = getOp0 base | |
85 | val index = toX86Operand index | |
86 | val _ = Assert.assert("x86Translate.Operand.toX86Operand: Array/index", | |
87 | fn () => Vector.length index = 1) | |
88 | val index = getOp0 index | |
89 | val scale = | |
90 | case scale of | |
91 | Scale.One => x86.Scale.One | |
92 | | Scale.Two => x86.Scale.Two | |
93 | | Scale.Four => x86.Scale.Four | |
94 | | Scale.Eight => x86.Scale.Eight | |
95 | val ty = Type.toCType ty | |
96 | val origin = | |
97 | case (x86.Operand.deMemloc base, | |
98 | x86.Operand.deImmediate index, | |
99 | x86.Operand.deMemloc index) of | |
100 | (SOME base, SOME index, _) => | |
101 | x86.MemLoc.simple | |
102 | {base = base, | |
103 | index = index, | |
104 | scale = scale, | |
105 | size = x86.Size.BYTE, | |
106 | class = x86MLton.Classes.Heap} | |
107 | | (SOME base, _, SOME index) => | |
108 | x86.MemLoc.complex | |
109 | {base = base, | |
110 | index = index, | |
111 | scale = scale, | |
112 | size = x86.Size.BYTE, | |
113 | class = x86MLton.Classes.Heap} | |
114 | | _ => Error.bug (concat ["x86Translate.Operand.toX86Operand: ", | |
115 | "strange Offset: base: ", | |
116 | x86.Operand.toString base, | |
117 | " index: ", | |
118 | x86.Operand.toString index]) | |
119 | val origin = | |
120 | if Bytes.isZero offset | |
121 | then origin | |
122 | else x86.MemLoc.shift | |
123 | {origin = origin, | |
124 | disp = x86.Immediate.int (Bytes.toInt offset), | |
125 | scale = x86.Scale.One, | |
126 | size = x86.Size.BYTE} | |
127 | val sizes = x86.Size.fromCType ty | |
128 | in | |
129 | (#1 o Vector.mapAndFold) | |
130 | (sizes, 0, fn (size,offset) => | |
131 | (((x86.Operand.memloc o x86.MemLoc.shift) | |
132 | {origin = origin, | |
133 | disp = x86.Immediate.int offset, | |
134 | scale = x86.Scale.One, | |
135 | size = size}, size), offset + x86.Size.toBytes size)) | |
136 | end | |
137 | | Cast (z, _) => toX86Operand z | |
138 | | Contents {oper, ty} => | |
139 | let | |
140 | val ty = Type.toCType ty | |
141 | val base = toX86Operand oper | |
142 | val _ = Assert.assert("x86Translate.Operand.toX86Operand: Contents/base", | |
143 | fn () => Vector.length base = 1) | |
144 | val base = getOp0 base | |
145 | val origin = | |
146 | case x86.Operand.deMemloc base of | |
147 | SOME base => | |
148 | x86.MemLoc.simple | |
149 | {base = base, | |
150 | index = x86.Immediate.zero, | |
151 | scale = x86.Scale.One, | |
152 | size = x86.Size.BYTE, | |
153 | class = x86MLton.Classes.Heap} | |
154 | | _ => Error.bug (concat | |
155 | ["x86Translate.Operand.toX86Operand: ", | |
156 | "strange Contents: base: ", | |
157 | x86.Operand.toString base]) | |
158 | val sizes = x86.Size.fromCType ty | |
159 | in | |
160 | (#1 o Vector.mapAndFold) | |
161 | (sizes, 0, fn (size,offset) => | |
162 | (((x86.Operand.memloc o x86.MemLoc.shift) | |
163 | {origin = origin, | |
164 | disp = x86.Immediate.int offset, | |
165 | scale = x86.Scale.One, | |
166 | size = size}, size), offset + x86.Size.toBytes size)) | |
167 | end | |
168 | | Frontier => | |
169 | let | |
170 | val frontier = x86MLton.gcState_frontierContentsOperand () | |
171 | in | |
172 | Vector.new1 (frontier, valOf (x86.Operand.size frontier)) | |
173 | end | |
174 | | GCState => | |
175 | Vector.new1 (x86.Operand.immediate_label x86MLton.gcState_label, | |
176 | x86MLton.pointerSize) | |
177 | | Global g => Global.toX86Operand g | |
178 | | Label l => | |
179 | Vector.new1 (x86.Operand.immediate_label l, x86MLton.pointerSize) | |
180 | | Null => | |
181 | Vector.new1 (x86.Operand.immediate_zero, x86MLton.wordSize) | |
182 | | Offset {base = GCState, offset, ty} => | |
183 | let | |
184 | val offset = Bytes.toInt offset | |
185 | val ty = Type.toCType ty | |
186 | val offset = x86MLton.gcState_offset {offset = offset, ty = ty} | |
187 | in | |
188 | Vector.new1 (offset, valOf (x86.Operand.size offset)) | |
189 | end | |
190 | | Offset {base, offset, ty} => | |
191 | let | |
192 | val offset = Bytes.toInt offset | |
193 | val ty = Type.toCType ty | |
194 | val base = toX86Operand base | |
195 | val _ = Assert.assert("x86Translate.Operand.toX86Operand: Offset/base", | |
196 | fn () => Vector.length base = 1) | |
197 | val base = getOp0 base | |
198 | val origin = | |
199 | case x86.Operand.deMemloc base of | |
200 | SOME base => | |
201 | x86.MemLoc.simple | |
202 | {base = base, | |
203 | index = x86.Immediate.int offset, | |
204 | scale = x86.Scale.One, | |
205 | size = x86.Size.BYTE, | |
206 | class = x86MLton.Classes.Heap} | |
207 | | _ => Error.bug (concat ["x86Translate.Operand.toX86Operand: ", | |
208 | "strange Offset: base: ", | |
209 | x86.Operand.toString base]) | |
210 | val sizes = x86.Size.fromCType ty | |
211 | in | |
212 | (#1 o Vector.mapAndFold) | |
213 | (sizes, 0, fn (size,offset) => | |
214 | (((x86.Operand.memloc o x86.MemLoc.shift) | |
215 | {origin = origin, | |
216 | disp = x86.Immediate.int offset, | |
217 | scale = x86.Scale.One, | |
218 | size = size}, size), offset + x86.Size.toBytes size)) | |
219 | end | |
220 | | Real _ => Error.bug "x86Translate.Operand.toX86Operand: Real unimplemented" | |
221 | | Register r => | |
222 | let | |
223 | val ty = Machine.Type.toCType (Register.ty r) | |
224 | val index = Machine.Register.index r | |
225 | val base = x86.Immediate.label (x86MLton.local_base ty) | |
226 | val origin = | |
227 | x86.MemLoc.imm | |
228 | {base = base, | |
229 | index = x86.Immediate.int index, | |
230 | scale = x86.Scale.fromCType ty, | |
231 | size = x86.Size.BYTE, | |
232 | class = x86MLton.Classes.Locals} | |
233 | val sizes = x86.Size.fromCType ty | |
234 | in | |
235 | (#1 o Vector.mapAndFold) | |
236 | (sizes, 0, fn (size,offset) => | |
237 | (((x86.Operand.memloc o x86.MemLoc.shift) | |
238 | {origin = origin, | |
239 | disp = x86.Immediate.int offset, | |
240 | scale = x86.Scale.One, | |
241 | size = size}, size), offset + x86.Size.toBytes size)) | |
242 | end | |
243 | | StackOffset (StackOffset.T {offset, ty}) => | |
244 | let | |
245 | val offset = Bytes.toInt offset | |
246 | val ty = Type.toCType ty | |
247 | val origin = | |
248 | x86.MemLoc.simple | |
249 | {base = x86MLton.gcState_stackTopContents (), | |
250 | index = x86.Immediate.int offset, | |
251 | scale = x86.Scale.One, | |
252 | size = x86.Size.BYTE, | |
253 | class = x86MLton.Classes.Stack} | |
254 | val sizes = x86.Size.fromCType ty | |
255 | in | |
256 | (#1 o Vector.mapAndFold) | |
257 | (sizes, 0, fn (size,offset) => | |
258 | (((x86.Operand.memloc o x86.MemLoc.shift) | |
259 | {origin = origin, | |
260 | disp = x86.Immediate.int offset, | |
261 | scale = x86.Scale.One, | |
262 | size = size}, size), offset + x86.Size.toBytes size)) | |
263 | end | |
264 | | StackTop => | |
265 | let | |
266 | val stackTop = x86MLton.gcState_stackTopContentsOperand () | |
267 | in | |
268 | Vector.new1 (stackTop, valOf (x86.Operand.size stackTop)) | |
269 | end | |
270 | | Word w => | |
271 | let | |
272 | fun single size = | |
273 | Vector.new1 (x86.Operand.immediate_word w, size) | |
274 | in | |
275 | case WordSize.prim (WordX.size w) of | |
276 | W8 => single x86.Size.BYTE | |
277 | | W16 => single x86.Size.WORD | |
278 | | W32 => single x86.Size.LONG | |
279 | | W64 => | |
280 | let | |
281 | val lo = WordX.resize (w, WordSize.word32) | |
282 | val w = WordX.rshift (w, | |
283 | WordX.fromIntInf (32, WordSize.word64), | |
284 | {signed = true}) | |
285 | val hi = WordX.resize (w, WordSize.word32) | |
286 | in | |
287 | Vector.new2 | |
288 | ((x86.Operand.immediate_word lo, x86.Size.LONG), | |
289 | (x86.Operand.immediate_word hi, x86.Size.LONG)) | |
290 | end | |
291 | end | |
292 | end | |
293 | ||
294 | type transInfo = x86MLton.transInfo | |
295 | ||
296 | structure Entry = | |
297 | struct | |
298 | structure Kind = Machine.Kind | |
299 | ||
300 | fun toX86Blocks {label, kind, | |
301 | transInfo as {frameInfoToX86, live, liveInfo, | |
302 | ...}: transInfo} | |
303 | = ( | |
304 | x86Liveness.LiveInfo.setLiveOperands | |
305 | (liveInfo, label, live label); | |
306 | case kind | |
307 | of Kind.Jump | |
308 | => let | |
309 | in | |
310 | AppendList.single | |
311 | (x86.Block.mkBlock' | |
312 | {entry = SOME (x86.Entry.jump {label = label}), | |
313 | statements = [], | |
314 | transfer = NONE}) | |
315 | end | |
316 | | Kind.Func | |
317 | => let | |
318 | val args | |
319 | = List.fold | |
320 | (live label, | |
321 | x86.MemLocSet.empty, | |
322 | fn (operand, args) | |
323 | => case x86.Operand.deMemloc operand | |
324 | of SOME memloc => x86.MemLocSet.add(args, memloc) | |
325 | | NONE => args) | |
326 | in | |
327 | AppendList.single | |
328 | (x86.Block.mkBlock' | |
329 | {entry = SOME (x86.Entry.func {label = label, | |
330 | live = args}), | |
331 | statements = [], | |
332 | transfer = NONE}) | |
333 | end | |
334 | | Kind.Cont {args, frameInfo, ...} | |
335 | => let | |
336 | val frameInfo = frameInfoToX86 frameInfo | |
337 | val args = | |
338 | Vector.fold | |
339 | (args, x86.MemLocSet.empty, | |
340 | fn (operand,args) => | |
341 | Vector.fold | |
342 | (Operand.toX86Operand (Live.toOperand operand), args, | |
343 | fn ((operand,_),args) => | |
344 | case x86.Operand.deMemloc operand of | |
345 | SOME memloc => x86.MemLocSet.add(args, memloc) | |
346 | | NONE => args)) | |
347 | in | |
348 | AppendList.single | |
349 | (x86.Block.mkBlock' | |
350 | {entry = SOME (x86.Entry.cont {label = label, | |
351 | live = args, | |
352 | frameInfo = frameInfo}), | |
353 | statements = [], | |
354 | transfer = NONE}) | |
355 | end | |
356 | | Kind.Handler {frameInfo, ...} | |
357 | => let | |
358 | in | |
359 | AppendList.single | |
360 | (x86.Block.mkBlock' | |
361 | {entry = SOME (x86.Entry.handler | |
362 | {frameInfo = frameInfoToX86 frameInfo, | |
363 | label = label, | |
364 | live = x86.MemLocSet.empty}), | |
365 | statements = [], | |
366 | transfer = NONE}) | |
367 | end | |
368 | | Kind.CReturn {dst, frameInfo, func} | |
369 | => let | |
370 | val dsts = | |
371 | case dst of | |
372 | NONE => Vector.new0 () | |
373 | | SOME dst => Operand.toX86Operand (Live.toOperand dst) | |
374 | in | |
375 | x86MLton.creturn | |
376 | {dsts = dsts, | |
377 | frameInfo = Option.map (frameInfo, frameInfoToX86), | |
378 | func = func, | |
379 | label = label, | |
380 | transInfo = transInfo} | |
381 | end) | |
382 | end | |
383 | ||
384 | structure Statement = | |
385 | struct | |
386 | open Machine.Statement | |
387 | ||
388 | fun comments statement | |
389 | = if !Control.Native.commented > 0 | |
390 | then let | |
391 | val comment = (Layout.toString o layout) statement | |
392 | in | |
393 | (AppendList.single | |
394 | (x86.Block.mkBlock' | |
395 | {entry = NONE, | |
396 | statements = [x86.Assembly.comment | |
397 | (concat ["begin: ", | |
398 | comment])], | |
399 | transfer = NONE}), | |
400 | AppendList.single | |
401 | (x86.Block.mkBlock' | |
402 | {entry = NONE, | |
403 | statements = [x86.Assembly.comment | |
404 | (concat ["end: ", | |
405 | comment])], | |
406 | transfer = NONE})) | |
407 | end | |
408 | else (AppendList.empty,AppendList.empty) | |
409 | ||
410 | fun toX86Blocks {statement, | |
411 | transInfo as {...} : transInfo} | |
412 | = (case statement | |
413 | of Noop | |
414 | => AppendList.empty | |
415 | | Move {src, dst} | |
416 | => let | |
417 | val (comment_begin, | |
418 | comment_end) = comments statement | |
419 | ||
420 | val dsts = Operand.toX86Operand dst | |
421 | val srcs = Operand.toX86Operand src | |
422 | (* Operand.toX86Operand returns multi-word | |
423 | * operands in and they will be moved in order, | |
424 | * so it suffices to check for aliasing between | |
425 | * the first dst and second src. | |
426 | *) | |
427 | val (dsts,srcs) = | |
428 | if Vector.length srcs > 1 | |
429 | andalso x86.Operand.mayAlias | |
430 | (#1 (Vector.sub (dsts, 0)), | |
431 | #1 (Vector.sub (srcs, 1))) | |
432 | then (Vector.rev dsts, Vector.rev srcs) | |
433 | else (dsts,srcs) | |
434 | in | |
435 | AppendList.appends | |
436 | [comment_begin, | |
437 | AppendList.single | |
438 | (x86.Block.mkBlock' | |
439 | {entry = NONE, | |
440 | statements | |
441 | = (Vector.toList o Vector.map2) | |
442 | (dsts,srcs,fn ((dst,_),(src,srcsize)) => | |
443 | (* dst = src *) | |
444 | case x86.Size.class srcsize | |
445 | of x86.Size.INT => x86.Assembly.instruction_mov | |
446 | {dst = dst, | |
447 | src = src, | |
448 | size = srcsize} | |
449 | | x86.Size.FLT => x86.Assembly.instruction_pfmov | |
450 | {dst = dst, | |
451 | src = src, | |
452 | size = srcsize} | |
453 | | _ => Error.bug "x86Translate.Statement.toX86Blocks: Move"), | |
454 | transfer = NONE}), | |
455 | comment_end] | |
456 | end | |
457 | | PrimApp {dst, prim, args} | |
458 | => let | |
459 | val (comment_begin, comment_end) = comments statement | |
460 | val args = (Vector.concatV o Vector.map) | |
461 | (args, Operand.toX86Operand) | |
462 | val dsts = | |
463 | case dst of | |
464 | NONE => Vector.new0 () | |
465 | | SOME dst => Operand.toX86Operand dst | |
466 | in | |
467 | AppendList.appends | |
468 | [comment_begin, | |
469 | (x86MLton.prim {prim = prim, | |
470 | args = args, | |
471 | dsts = dsts, | |
472 | transInfo = transInfo}), | |
473 | comment_end] | |
474 | end | |
475 | | ProfileLabel l => | |
476 | AppendList.single | |
477 | (x86.Block.mkProfileBlock' | |
478 | {profileLabel = l})) | |
479 | end | |
480 | ||
481 | structure Transfer = | |
482 | struct | |
483 | open Machine.Transfer | |
484 | ||
485 | fun goto l | |
486 | = AppendList.single | |
487 | (x86.Block.mkBlock' | |
488 | {entry = NONE, | |
489 | statements = [], | |
490 | transfer = SOME (x86.Transfer.goto | |
491 | {target = l})}) | |
492 | ||
493 | fun iff (test, a, b) | |
494 | = let | |
495 | val (test,testsize) = | |
496 | Vector.sub (Operand.toX86Operand test, 0) | |
497 | in | |
498 | if Label.equals(a, b) | |
499 | then AppendList.single | |
500 | (x86.Block.mkBlock' | |
501 | {entry = NONE, | |
502 | statements = [], | |
503 | transfer = SOME (x86.Transfer.goto {target = a})}) | |
504 | else AppendList.single | |
505 | ((* if (test) goto a | |
506 | * goto b | |
507 | *) | |
508 | x86.Block.mkBlock' | |
509 | {entry = NONE, | |
510 | statements | |
511 | = [x86.Assembly.instruction_test | |
512 | {src1 = test, | |
513 | src2 = test, | |
514 | size = testsize}], | |
515 | transfer | |
516 | = SOME (x86.Transfer.iff | |
517 | {condition = x86.Instruction.NZ, | |
518 | truee = a, | |
519 | falsee = b})}) | |
520 | end | |
521 | ||
522 | fun cmp (test, k, a, b) | |
523 | = let | |
524 | val (test,testsize) = | |
525 | Vector.sub (Operand.toX86Operand test, 0) | |
526 | in | |
527 | if Label.equals(a, b) | |
528 | then AppendList.single | |
529 | (x86.Block.mkBlock' | |
530 | {entry = NONE, | |
531 | statements = [], | |
532 | transfer = SOME (x86.Transfer.goto {target = a})}) | |
533 | else AppendList.single | |
534 | ((* if (test = k) goto a | |
535 | * goto b | |
536 | *) | |
537 | x86.Block.mkBlock' | |
538 | {entry = NONE, | |
539 | statements | |
540 | = [x86.Assembly.instruction_cmp | |
541 | {src1 = test, | |
542 | src2 = x86.Operand.immediate k, | |
543 | size = testsize}], | |
544 | transfer | |
545 | = SOME (x86.Transfer.iff | |
546 | {condition = x86.Instruction.E, | |
547 | truee = a, | |
548 | falsee = b})}) | |
549 | end | |
550 | ||
551 | fun switch(test, cases, default) | |
552 | = let | |
553 | val test = Operand.toX86Operand test | |
554 | val (test,_) = Vector.sub(test, 0) | |
555 | in | |
556 | AppendList.single | |
557 | (x86.Block.mkBlock' | |
558 | {entry = NONE, | |
559 | statements = [], | |
560 | transfer = SOME (x86.Transfer.switch | |
561 | {test = test, | |
562 | cases = cases, | |
563 | default = default})}) | |
564 | end | |
565 | ||
566 | fun doSwitchWord (test, cases, default) | |
567 | = (case (cases, default) | |
568 | of ([], NONE) | |
569 | => Error.bug "x86Translate.Transfer.doSwitchWord" | |
570 | | ([(_,l)], NONE) => goto l | |
571 | | ([], SOME l) => goto l | |
572 | | ([(w1,l1),(w2,l2)], NONE) => | |
573 | if WordX.isZero w1 andalso WordX.isOne w2 | |
574 | then iff(test,l2,l1) | |
575 | else if WordX.isZero w2 andalso WordX.isOne w1 | |
576 | then iff(test,l1,l2) | |
577 | else cmp(test,x86.Immediate.word w1,l1,l2) | |
578 | | ([(k',l')], SOME l) | |
579 | => cmp(test,x86.Immediate.word k',l',l) | |
580 | | ((_,l)::cases, NONE) | |
581 | => switch(test, x86.Transfer.Cases.word cases, l) | |
582 | | (cases, SOME l) | |
583 | => switch(test, x86.Transfer.Cases.word cases, l)) | |
584 | ||
585 | fun comments transfer | |
586 | = if !Control.Native.commented > 0 | |
587 | then let | |
588 | val comment = (Layout.toString o layout) transfer | |
589 | in | |
590 | AppendList.single | |
591 | (x86.Block.mkBlock' | |
592 | {entry = NONE, | |
593 | statements = [x86.Assembly.comment comment], | |
594 | transfer = NONE}) | |
595 | end | |
596 | else AppendList.empty | |
597 | ||
598 | ||
599 | fun toX86Blocks {returns, transfer, | |
600 | transInfo as {frameInfoToX86, ...}: transInfo} | |
601 | = (case transfer | |
602 | of Arith {prim, args, dst, overflow, success, ...} | |
603 | => let | |
604 | val args = (Vector.concatV o Vector.map) | |
605 | (args, Operand.toX86Operand) | |
606 | val dsts = Operand.toX86Operand dst | |
607 | in | |
608 | AppendList.append | |
609 | (comments transfer, | |
610 | x86MLton.arith {prim = prim, | |
611 | args = args, | |
612 | dsts = dsts, | |
613 | overflow = overflow, | |
614 | success = success, | |
615 | transInfo = transInfo}) | |
616 | end | |
617 | | CCall {args, frameInfo, func, return} | |
618 | => let | |
619 | val args = (Vector.concatV o Vector.map) | |
620 | (args, Operand.toX86Operand) | |
621 | in | |
622 | AppendList.append | |
623 | (comments transfer, | |
624 | x86MLton.ccall {args = args, | |
625 | frameInfo = (Option.map | |
626 | (frameInfo, frameInfoToX86)), | |
627 | func = func, | |
628 | return = return, | |
629 | transInfo = transInfo}) | |
630 | end | |
631 | | Return | |
632 | => AppendList.append | |
633 | (comments transfer, | |
634 | AppendList.single | |
635 | (x86.Block.mkBlock' | |
636 | {entry = NONE, | |
637 | statements = [], | |
638 | transfer | |
639 | = SOME (x86.Transfer.return | |
640 | {live | |
641 | = Vector.fold | |
642 | ((case returns of | |
643 | NONE => Error.bug "x86Translate.Transfer.toX86Blocsk: Return" | |
644 | | SOME zs => zs), | |
645 | x86.MemLocSet.empty, | |
646 | fn (operand, live) => | |
647 | Vector.fold | |
648 | (Operand.toX86Operand operand, live, | |
649 | fn ((operand,_),live) => | |
650 | case x86.Operand.deMemloc operand of | |
651 | SOME memloc => x86.MemLocSet.add(live, memloc) | |
652 | | NONE => live))})})) | |
653 | | Raise | |
654 | => AppendList.append | |
655 | (comments transfer, | |
656 | AppendList.single | |
657 | (x86.Block.mkBlock' | |
658 | {entry = NONE, | |
659 | statements = [], | |
660 | transfer | |
661 | = SOME (x86.Transfer.raisee | |
662 | {live | |
663 | = x86.MemLocSet.add | |
664 | (x86.MemLocSet.add | |
665 | (x86.MemLocSet.empty, | |
666 | x86MLton.gcState_stackBottomContents ()), | |
667 | x86MLton.gcState_exnStackContents ())})})) | |
668 | | Switch (Machine.Switch.T {cases, default, test, ...}) | |
669 | => AppendList.append | |
670 | (comments transfer, | |
671 | doSwitchWord (test, Vector.toList cases, default)) | |
672 | | Goto label | |
673 | => (AppendList.append | |
674 | (comments transfer, | |
675 | AppendList.single | |
676 | ((* goto label *) | |
677 | x86.Block.mkBlock' | |
678 | {entry = NONE, | |
679 | statements = [], | |
680 | transfer = SOME (x86.Transfer.goto {target = label})}))) | |
681 | | Call {label, live, return, ...} | |
682 | => let | |
683 | val live = | |
684 | Vector.fold | |
685 | (live, x86.MemLocSet.empty, fn (operand, live) => | |
686 | Vector.fold | |
687 | (Operand.toX86Operand (Live.toOperand operand), live, | |
688 | fn ((operand, _), live) => | |
689 | case x86.Operand.deMemloc operand of | |
690 | NONE => live | |
691 | | SOME memloc => x86.MemLocSet.add (live, memloc))) | |
692 | val com = comments transfer | |
693 | val transfer = | |
694 | case return of | |
695 | NONE => x86.Transfer.tail {target = label, | |
696 | live = live} | |
697 | | SOME {return, handler, size} => | |
698 | x86.Transfer.nontail {target = label, | |
699 | live = live, | |
700 | return = return, | |
701 | handler = handler, | |
702 | size = Bytes.toInt size} | |
703 | in | |
704 | AppendList.append | |
705 | (com, | |
706 | AppendList.single | |
707 | (x86.Block.mkBlock' {entry = NONE, | |
708 | statements = [], | |
709 | transfer = SOME transfer})) | |
710 | end) | |
711 | end | |
712 | ||
713 | structure Block = | |
714 | struct | |
715 | open Machine.Block | |
716 | ||
717 | fun toX86Blocks {block = T {label, | |
718 | live, | |
719 | kind, | |
720 | returns, | |
721 | statements, | |
722 | transfer, | |
723 | ...}, | |
724 | transInfo as {...} : transInfo} | |
725 | = let | |
726 | val pseudo_blocks | |
727 | = AppendList.append | |
728 | (AppendList.snoc | |
729 | (Entry.toX86Blocks {label = label, | |
730 | kind = kind, | |
731 | transInfo = transInfo}, | |
732 | x86.Block.mkBlock' | |
733 | {entry = NONE, | |
734 | statements | |
735 | = if !Control.Native.commented > 0 | |
736 | then let | |
737 | val comment = | |
738 | concat ["Live: ", | |
739 | argsToString | |
740 | (Vector.toListMap | |
741 | (live, fn l => | |
742 | Operand.toString (Live.toOperand l)))] | |
743 | in | |
744 | [x86.Assembly.comment comment] | |
745 | end | |
746 | else [], | |
747 | transfer = NONE}), | |
748 | Vector.foldr(statements, | |
749 | (Transfer.toX86Blocks | |
750 | {returns = (Option.map | |
751 | (returns, fn v => | |
752 | Vector.map (v, Live.toOperand))), | |
753 | transfer = transfer, | |
754 | transInfo = transInfo}), | |
755 | fn (statement,l) | |
756 | => AppendList.append | |
757 | (Statement.toX86Blocks | |
758 | {statement = statement, | |
759 | transInfo = transInfo}, l))) | |
760 | ||
761 | val pseudo_blocks = AppendList.toList pseudo_blocks | |
762 | ||
763 | val blocks = x86.Block.compress pseudo_blocks | |
764 | in | |
765 | blocks | |
766 | end | |
767 | end | |
768 | ||
769 | structure Chunk = | |
770 | struct | |
771 | open Machine.Chunk | |
772 | ||
773 | fun toX86Chunk {chunk = T {blocks, ...}, | |
774 | frameInfoToX86, | |
775 | liveInfo} | |
776 | = let | |
777 | val data = ref [] | |
778 | val addData = fn l => List.push (data, l) | |
779 | val {get = live : Label.t -> x86.Operand.t list, | |
780 | set = setLive, | |
781 | rem = remLive, ...} | |
782 | = Property.getSetOnce | |
783 | (Label.plist, Property.initRaise ("live", Label.layout)) | |
784 | val _ = Vector.foreach | |
785 | (blocks, fn Block.T {label, live, ...} => | |
786 | setLive (label, | |
787 | (Vector.toList o #1 o Vector.unzip o | |
788 | Vector.concatV o Vector.map) | |
789 | (live, Operand.toX86Operand o Live.toOperand))) | |
790 | val transInfo = {addData = addData, | |
791 | frameInfoToX86 = frameInfoToX86, | |
792 | live = live, | |
793 | liveInfo = liveInfo} | |
794 | val x86Blocks | |
795 | = List.concat (Vector.toListMap | |
796 | (blocks, | |
797 | fn block | |
798 | => Block.toX86Blocks | |
799 | {block = block, | |
800 | transInfo = transInfo})) | |
801 | val _ = Vector.foreach (blocks, fn Block.T {label, ...} => | |
802 | remLive label) | |
803 | val data = List.concatRev (!data) | |
804 | val data = | |
805 | if List.isEmpty data | |
806 | then [] | |
807 | else (x86.Assembly.pseudoop_data())::data | |
808 | in | |
809 | x86.Chunk.T {data = data, blocks = x86Blocks} | |
810 | end | |
811 | end | |
812 | ||
813 | fun translateChunk {chunk: x86MLton.Machine.Chunk.t, | |
814 | frameInfoToX86, | |
815 | liveInfo: x86Liveness.LiveInfo.t}: | |
816 | {chunk: x86.Chunk.t} | |
817 | = {chunk = Chunk.toX86Chunk {chunk = chunk, | |
818 | frameInfoToX86 = frameInfoToX86, | |
819 | liveInfo = liveInfo}} | |
820 | ||
821 | val (translateChunk, translateChunk_msg) | |
822 | = tracerTop | |
823 | "translateChunk" | |
824 | translateChunk | |
825 | ||
826 | fun translateChunk_totals () | |
827 | = (translateChunk_msg (); | |
828 | Control.indent (); | |
829 | Control.unindent ()) | |
830 | ||
831 | end |