Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2009,2013-2014,2017 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 Backend (S: BACKEND_STRUCTS): BACKEND = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | structure M = Machine | |
16 | local | |
17 | open Machine | |
18 | in | |
19 | structure Global = Global | |
20 | structure Label = Label | |
21 | structure Live = Live | |
22 | structure ObjptrTycon = ObjptrTycon | |
23 | structure RealX = RealX | |
24 | structure Register = Register | |
25 | structure Runtime = Runtime | |
26 | structure StackOffset = StackOffset | |
27 | structure WordSize = WordSize | |
28 | structure WordX = WordX | |
29 | structure WordXVector = WordXVector | |
30 | end | |
31 | local | |
32 | open Runtime | |
33 | in | |
34 | structure GCField = GCField | |
35 | end | |
36 | ||
37 | structure Rssa = Rssa (open Ssa Machine) | |
38 | structure R = Rssa | |
39 | local | |
40 | open Rssa | |
41 | in | |
42 | structure CType = CType | |
43 | structure Const = Const | |
44 | structure Func = Func | |
45 | structure Function = Function | |
46 | structure Prim = Prim | |
47 | structure Type = Type | |
48 | structure Var = Var | |
49 | end | |
50 | ||
51 | structure AllocateRegisters = AllocateRegisters (structure Machine = Machine | |
52 | structure Rssa = Rssa) | |
53 | structure Chunkify = Chunkify (Rssa) | |
54 | structure ImplementHandlers = ImplementHandlers (structure Rssa = Rssa) | |
55 | structure ImplementProfiling = ImplementProfiling (structure Machine = Machine | |
56 | structure Rssa = Rssa) | |
57 | structure LimitCheck = LimitCheck (structure Rssa = Rssa) | |
58 | structure ParallelMove = ParallelMove () | |
59 | structure SignalCheck = SignalCheck(structure Rssa = Rssa) | |
60 | structure SsaToRssa = SsaToRssa (structure Rssa = Rssa | |
61 | structure Ssa = Ssa) | |
62 | ||
63 | structure VarOperand = | |
64 | struct | |
65 | datatype t = | |
66 | Allocate of {operand: M.Operand.t option ref} | |
67 | | Const of M.Operand.t | |
68 | ||
69 | fun layout i = | |
70 | let | |
71 | open Layout | |
72 | in | |
73 | case i of | |
74 | Allocate {operand, ...} => | |
75 | seq [str "Allocate ", | |
76 | record [("operand", | |
77 | Option.layout M.Operand.layout (!operand))]] | |
78 | | Const oper => seq [str "Const ", M.Operand.layout oper] | |
79 | end | |
80 | ||
81 | val operand: t -> M.Operand.t = | |
82 | fn Allocate {operand, ...} => valOf (!operand) | |
83 | | Const oper => oper | |
84 | end | |
85 | ||
86 | structure IntSet = UniqueSet (val cacheSize: int = 1 | |
87 | val bits: int = 14 | |
88 | structure Element = | |
89 | struct | |
90 | open Int | |
91 | fun hash n = Word.fromInt n | |
92 | end) | |
93 | ||
94 | structure Chunk = | |
95 | struct | |
96 | datatype t = T of {blocks: M.Block.t list ref, | |
97 | chunkLabel: M.ChunkLabel.t} | |
98 | ||
99 | fun label (T {chunkLabel, ...}) = chunkLabel | |
100 | ||
101 | fun new (): t = | |
102 | T {blocks = ref [], | |
103 | chunkLabel = M.ChunkLabel.newNoname ()} | |
104 | ||
105 | fun newBlock (T {blocks, ...}, z) = | |
106 | List.push (blocks, M.Block.T z) | |
107 | end | |
108 | ||
109 | val traceGenBlock = | |
110 | Trace.trace ("Backend.genBlock", | |
111 | Label.layout o R.Block.label, | |
112 | Unit.layout) | |
113 | ||
114 | fun eliminateDeadCode (f: R.Function.t): R.Function.t = | |
115 | let | |
116 | val {args, blocks, name, returns, raises, start} = R.Function.dest f | |
117 | val {get, rem, set, ...} = | |
118 | Property.getSetOnce (Label.plist, Property.initConst false) | |
119 | val get = Trace.trace ("Backend.labelIsReachable", | |
120 | Label.layout, | |
121 | Bool.layout) get | |
122 | val _ = | |
123 | R.Function.dfs (f, fn R.Block.T {label, ...} => | |
124 | (set (label, true) | |
125 | ; fn () => ())) | |
126 | val blocks = | |
127 | Vector.keepAll (blocks, fn R.Block.T {label, ...} => | |
128 | let | |
129 | val res = get label | |
130 | val () = rem label | |
131 | in | |
132 | res | |
133 | end) | |
134 | in | |
135 | R.Function.new {args = args, | |
136 | blocks = blocks, | |
137 | name = name, | |
138 | returns = returns, | |
139 | raises = raises, | |
140 | start = start} | |
141 | end | |
142 | ||
143 | fun toMachine (program: Ssa.Program.t, codegen) = | |
144 | let | |
145 | fun pass (name, doit, program) = | |
146 | Control.passTypeCheck {display = Control.Layouts Rssa.Program.layouts, | |
147 | name = name, | |
148 | stats = R.Program.layoutStats, | |
149 | style = Control.No, | |
150 | suffix = "rssa", | |
151 | thunk = fn () => doit program, | |
152 | typeCheck = R.Program.typeCheck} | |
153 | val program = pass ("toRssa", SsaToRssa.convert, (program, codegen)) | |
154 | fun rssaSimplify p = | |
155 | let | |
156 | open Rssa | |
157 | fun pass' ({name, doit}, sel, p) = | |
158 | let | |
159 | val _ = | |
160 | let open Control | |
161 | in maybeSaveToFile | |
162 | ({name = name, | |
163 | suffix = "pre.rssa"}, | |
164 | Control.No, p, Control.Layouts Program.layouts) | |
165 | end | |
166 | val p = | |
167 | Control.passTypeCheck | |
168 | {display = Control.Layouts | |
169 | (fn (r,output) => | |
170 | Program.layouts (sel r, output)), | |
171 | name = name, | |
172 | stats = Program.layoutStats o sel, | |
173 | style = Control.No, | |
174 | suffix = "post.rssa", | |
175 | thunk = fn () => doit p, | |
176 | typeCheck = Program.typeCheck o sel} | |
177 | in | |
178 | p | |
179 | end | |
180 | fun pass ({name, doit}, p) = | |
181 | pass' ({name = name, doit = doit}, fn p => p, p) | |
182 | fun maybePass ({name, doit, execute}, p) = | |
183 | if List.foldr (!Control.executePasses, execute, fn ((re, new), old) => | |
184 | if Regexp.Compiled.matchesAll (re, name) | |
185 | then new | |
186 | else old) | |
187 | then pass ({name = name, doit = doit}, p) | |
188 | else (Control.messageStr (Control.Pass, name ^ " skipped"); p) | |
189 | val p = maybePass ({name = "rssaShrink1", | |
190 | doit = Program.shrink, | |
191 | execute = true}, p) | |
192 | val p = pass ({name = "insertLimitChecks", | |
193 | doit = LimitCheck.transform}, p) | |
194 | val p = pass ({name = "insertSignalChecks", | |
195 | doit = SignalCheck.transform}, p) | |
196 | val p = pass ({name = "implementHandlers", | |
197 | doit = ImplementHandlers.transform}, p) | |
198 | val p = maybePass ({name = "rssaShrink2", | |
199 | doit = Program.shrink, | |
200 | execute = true}, p) | |
201 | val () = Program.checkHandlers p | |
202 | val (p, makeProfileInfo) = | |
203 | pass' ({name = "implementProfiling", | |
204 | doit = ImplementProfiling.doit}, | |
205 | fn (p,_) => p, p) | |
206 | val p = maybePass ({name = "rssaOrderFunctions", | |
207 | doit = Program.orderFunctions, | |
208 | execute = true}, p) | |
209 | in | |
210 | (p, makeProfileInfo) | |
211 | end | |
212 | val (program, makeProfileInfo) = | |
213 | Control.passTypeCheck | |
214 | {display = Control.Layouts (fn ((program, _), output) => | |
215 | Rssa.Program.layouts (program, output)), | |
216 | name = "rssaSimplify", | |
217 | stats = fn (program,_) => Rssa.Program.layoutStats program, | |
218 | style = Control.No, | |
219 | suffix = "rssa", | |
220 | thunk = fn () => rssaSimplify program, | |
221 | typeCheck = R.Program.typeCheck o #1} | |
222 | val _ = | |
223 | let | |
224 | open Control | |
225 | in | |
226 | if !keepRSSA | |
227 | then saveToFile ({suffix = "rssa"}, | |
228 | No, | |
229 | program, | |
230 | Layouts Rssa.Program.layouts) | |
231 | else () | |
232 | end | |
233 | val program = | |
234 | Control.pass | |
235 | {display = Control.Layouts Machine.Program.layouts, | |
236 | name = "toMachine", | |
237 | stats = fn _ => Layout.empty, | |
238 | style = Control.No, | |
239 | suffix = "machine", | |
240 | thunk = fn () => | |
241 | let | |
242 | val R.Program.T {functions, handlesSignals, main, objectTypes} = program | |
243 | (* Chunk information *) | |
244 | val {get = labelChunk, set = setLabelChunk, ...} = | |
245 | Property.getSetOnce (Label.plist, | |
246 | Property.initRaise ("labelChunk", Label.layout)) | |
247 | val {get = funcChunk: Func.t -> Chunk.t, set = setFuncChunk, ...} = | |
248 | Property.getSetOnce (Func.plist, | |
249 | Property.initRaise ("funcChunk", Func.layout)) | |
250 | val chunks = ref [] | |
251 | fun newChunk () = | |
252 | let | |
253 | val c = Chunk.new () | |
254 | val _ = List.push (chunks, c) | |
255 | in | |
256 | c | |
257 | end | |
258 | val handlers = ref [] | |
259 | (* Set funcChunk and labelChunk. *) | |
260 | val _ = | |
261 | Vector.foreach | |
262 | (Chunkify.chunkify program, fn {funcs, labels} => | |
263 | let | |
264 | val c = newChunk () | |
265 | val _ = Vector.foreach (funcs, fn f => setFuncChunk (f, c)) | |
266 | val _ = Vector.foreach (labels, fn l => setLabelChunk (l, c)) | |
267 | in | |
268 | () | |
269 | end) | |
270 | (* FrameInfo. *) | |
271 | local | |
272 | val frameLabels = ref [] | |
273 | val frameLayouts = ref [] | |
274 | val frameLayoutsCounter = Counter.new 0 | |
275 | val _ = IntSet.reset () | |
276 | val table = HashSet.new {hash = Word.fromInt o #frameOffsetsIndex} | |
277 | val frameOffsets: Bytes.t vector list ref = ref [] | |
278 | val frameOffsetsCounter = Counter.new 0 | |
279 | val {get = frameOffsetsIndex: IntSet.t -> int, ...} = | |
280 | Property.get | |
281 | (IntSet.plist, | |
282 | Property.initFun | |
283 | (fn offsets => | |
284 | let | |
285 | val _ = List.push (frameOffsets, | |
286 | QuickSort.sortVector | |
287 | (Vector.fromListMap | |
288 | (IntSet.toList offsets, Bytes.fromInt), | |
289 | Bytes.<=)) | |
290 | in | |
291 | Counter.next frameOffsetsCounter | |
292 | end)) | |
293 | in | |
294 | fun allFrameInfo () = | |
295 | let | |
296 | (* Reverse lists because the index is from back of list. *) | |
297 | val frameLabels = Vector.fromListRev (!frameLabels) | |
298 | val frameLayouts = Vector.fromListRev (!frameLayouts) | |
299 | val frameOffsets = Vector.fromListRev (!frameOffsets) | |
300 | in | |
301 | (frameLabels, frameLayouts, frameOffsets) | |
302 | end | |
303 | fun getFrameLayoutsIndex {isC: bool, | |
304 | label: Label.t, | |
305 | offsets: Bytes.t list, | |
306 | size: Bytes.t}: int = | |
307 | let | |
308 | val foi = | |
309 | frameOffsetsIndex (IntSet.fromList | |
310 | (List.map (offsets, Bytes.toInt))) | |
311 | fun new () = | |
312 | let | |
313 | val _ = | |
314 | List.push (frameLayouts, | |
315 | {frameOffsetsIndex = foi, | |
316 | isC = isC, | |
317 | size = size}) | |
318 | val _ = List.push (frameLabels, label) | |
319 | in | |
320 | Counter.next frameLayoutsCounter | |
321 | end | |
322 | in | |
323 | (* We need to give each frame its own layout index in two cases. | |
324 | * 1. If we are using the C codegen, in which case we want the | |
325 | * indices in a chunk to be consecutive integers so that gcc | |
326 | * will use a jump table. | |
327 | * 2. If we are profiling, we want every frame to have a | |
328 | * different index so that it can have its own profiling info. | |
329 | * This will be created by the call to makeProfileInfo at the | |
330 | * end of the backend. | |
331 | *) | |
332 | if !Control.codegen = Control.CCodegen | |
333 | orelse !Control.codegen = Control.LLVMCodegen | |
334 | orelse !Control.profile <> Control.ProfileNone | |
335 | then new () | |
336 | else | |
337 | #frameLayoutsIndex | |
338 | (HashSet.lookupOrInsert | |
339 | (table, Word.fromInt foi, | |
340 | fn {frameOffsetsIndex = foi', isC = isC', size = s', ...} => | |
341 | foi = foi' | |
342 | andalso isC = isC' | |
343 | andalso Bytes.equals (size, s'), | |
344 | fn () => {frameLayoutsIndex = new (), | |
345 | frameOffsetsIndex = foi, | |
346 | isC = isC, | |
347 | size = size})) | |
348 | end | |
349 | end | |
350 | val {get = frameInfo: Label.t -> M.FrameInfo.t option, | |
351 | set = setFrameInfo, ...} = | |
352 | Property.getSetOnce (Label.plist, | |
353 | Property.initConst NONE) | |
354 | val setFrameInfo = | |
355 | Trace.trace2 ("Backend.setFrameInfo", | |
356 | Label.layout, Option.layout M.FrameInfo.layout, | |
357 | Unit.layout) | |
358 | setFrameInfo | |
359 | (* The global raise operands. *) | |
360 | local | |
361 | val table: (Type.t vector * M.Live.t vector) list ref = ref [] | |
362 | in | |
363 | fun raiseOperands (ts: Type.t vector): M.Live.t vector = | |
364 | case List.peek (!table, fn (ts', _) => | |
365 | Vector.equals (ts, ts', Type.equals)) of | |
366 | NONE => | |
367 | let | |
368 | val gs = | |
369 | Vector.map (ts, fn ty => | |
370 | M.Live.Global | |
371 | (Global.new {isRoot = false, | |
372 | ty = ty})) | |
373 | val _ = List.push (table, (ts, gs)) | |
374 | in | |
375 | gs | |
376 | end | |
377 | | SOME (_, gs) => gs | |
378 | end | |
379 | val {get = varInfo: Var.t -> {operand: VarOperand.t, | |
380 | ty: Type.t}, | |
381 | set = setVarInfo, ...} = | |
382 | Property.getSetOnce (Var.plist, | |
383 | Property.initRaise ("Backend.info", Var.layout)) | |
384 | val setVarInfo = | |
385 | Trace.trace2 ("Backend.setVarInfo", | |
386 | Var.layout, VarOperand.layout o #operand, Unit.layout) | |
387 | setVarInfo | |
388 | val varInfo = | |
389 | Trace.trace ("Backend.varInfo", | |
390 | Var.layout, | |
391 | fn {operand, ...} => | |
392 | Layout.record [("operand", VarOperand.layout operand)]) | |
393 | varInfo | |
394 | val varOperand: Var.t -> M.Operand.t = | |
395 | VarOperand.operand o #operand o varInfo | |
396 | (* Hash tables for uniquifying globals. *) | |
397 | local | |
398 | fun ('a, 'b) make (equals: 'a * 'a -> bool, | |
399 | info: 'a -> string * Type.t * 'b) = | |
400 | let | |
401 | val set: {a: 'a, | |
402 | global: M.Global.t, | |
403 | hash: word, | |
404 | value: 'b} HashSet.t = HashSet.new {hash = #hash} | |
405 | fun get (a: 'a): M.Operand.t = | |
406 | let | |
407 | val (string, ty, value) = info a | |
408 | val hash = String.hash string | |
409 | in | |
410 | M.Operand.Global | |
411 | (#global | |
412 | (HashSet.lookupOrInsert | |
413 | (set, hash, | |
414 | fn {a = a', ...} => equals (a, a'), | |
415 | fn () => {a = a, | |
416 | hash = hash, | |
417 | global = M.Global.new {isRoot = true, | |
418 | ty = ty}, | |
419 | value = value}))) | |
420 | end | |
421 | fun all () = | |
422 | HashSet.fold | |
423 | (set, [], fn ({global, value, ...}, ac) => | |
424 | (global, value) :: ac) | |
425 | in | |
426 | (all, get) | |
427 | end | |
428 | in | |
429 | val (allReals, globalReal) = | |
430 | make (RealX.equals, | |
431 | fn r => (RealX.toString r, | |
432 | Type.real (RealX.size r), | |
433 | r)) | |
434 | val (allVectors, globalVector) = | |
435 | make (WordXVector.equals, | |
436 | fn v => (WordXVector.toString v, | |
437 | Type.ofWordXVector v, | |
438 | v)) | |
439 | end | |
440 | fun bogusOp (t: Type.t): M.Operand.t = | |
441 | case Type.deReal t of | |
442 | NONE => let | |
443 | val bogusWord = | |
444 | M.Operand.Word | |
445 | (WordX.zero | |
446 | (WordSize.fromBits (Type.width t))) | |
447 | in | |
448 | case Type.deWord t of | |
449 | NONE => M.Operand.Cast (bogusWord, t) | |
450 | | SOME _ => bogusWord | |
451 | end | |
452 | | SOME s => globalReal (RealX.zero s) | |
453 | fun constOperand (c: Const.t): M.Operand.t = | |
454 | let | |
455 | datatype z = datatype Const.t | |
456 | in | |
457 | case c of | |
458 | IntInf _ => | |
459 | Error.bug "Backend.constOperand: IntInf" | |
460 | | Null => M.Operand.Null | |
461 | | Real r => globalReal r | |
462 | | Word w => M.Operand.Word w | |
463 | | WordVector v => globalVector v | |
464 | end | |
465 | fun parallelMove {chunk = _, | |
466 | dsts: M.Operand.t vector, | |
467 | srcs: M.Operand.t vector}: M.Statement.t vector = | |
468 | let | |
469 | val moves = | |
470 | Vector.fold2 (srcs, dsts, [], | |
471 | fn (src, dst, ac) => {src = src, dst = dst} :: ac) | |
472 | fun temp r = | |
473 | M.Operand.Register (Register.new (M.Operand.ty r, NONE)) | |
474 | in | |
475 | Vector.fromList | |
476 | (ParallelMove.move { | |
477 | equals = M.Operand.equals, | |
478 | move = M.Statement.move, | |
479 | moves = moves, | |
480 | interfere = M.Operand.interfere, | |
481 | temp = temp | |
482 | }) | |
483 | end | |
484 | fun runtimeOp (field: GCField.t): M.Operand.t = | |
485 | case field of | |
486 | GCField.Frontier => M.Operand.Frontier | |
487 | | GCField.StackTop => M.Operand.StackTop | |
488 | | _ => | |
489 | M.Operand.Offset {base = M.Operand.GCState, | |
490 | offset = GCField.offset field, | |
491 | ty = Type.ofGCField field} | |
492 | val exnStackOp = runtimeOp GCField.ExnStack | |
493 | val stackBottomOp = runtimeOp GCField.StackBottom | |
494 | val stackTopOp = runtimeOp GCField.StackTop | |
495 | fun translateOperand (oper: R.Operand.t): M.Operand.t = | |
496 | let | |
497 | datatype z = datatype R.Operand.t | |
498 | in | |
499 | case oper of | |
500 | ArrayOffset {base, index, offset, scale, ty} => | |
501 | let | |
502 | val base = translateOperand base | |
503 | in | |
504 | if M.Operand.isLocation base | |
505 | then M.Operand.ArrayOffset {base = base, | |
506 | index = translateOperand index, | |
507 | offset = offset, | |
508 | scale = scale, | |
509 | ty = ty} | |
510 | else bogusOp ty | |
511 | end | |
512 | | Cast (z, t) => M.Operand.Cast (translateOperand z, t) | |
513 | | Const c => constOperand c | |
514 | | EnsuresBytesFree => | |
515 | Error.bug "Backend.translateOperand: EnsuresBytesFree" | |
516 | | GCState => M.Operand.GCState | |
517 | | Offset {base, offset, ty} => | |
518 | let | |
519 | val base = translateOperand base | |
520 | in | |
521 | if M.Operand.isLocation base | |
522 | then M.Operand.Offset {base = base, | |
523 | offset = offset, | |
524 | ty = ty} | |
525 | else bogusOp ty | |
526 | end | |
527 | | ObjptrTycon opt => | |
528 | M.Operand.Word | |
529 | (WordX.fromIntInf | |
530 | (Word.toIntInf (Runtime.typeIndexToHeader | |
531 | (ObjptrTycon.index opt)), | |
532 | WordSize.objptrHeader ())) | |
533 | | Runtime f => runtimeOp f | |
534 | | Var {var, ...} => varOperand var | |
535 | end | |
536 | fun translateOperands ops = Vector.map (ops, translateOperand) | |
537 | fun genStatement (s: R.Statement.t, | |
538 | handlerLinkOffset: {handler: Bytes.t, | |
539 | link: Bytes.t} option) | |
540 | : M.Statement.t vector = | |
541 | let | |
542 | fun handlerOffset () = #handler (valOf handlerLinkOffset) | |
543 | fun linkOffset () = #link (valOf handlerLinkOffset) | |
544 | datatype z = datatype R.Statement.t | |
545 | in | |
546 | case s of | |
547 | Bind {dst = (var, _), src, ...} => | |
548 | Vector.new1 | |
549 | (M.Statement.move {dst = varOperand var, | |
550 | src = translateOperand src}) | |
551 | | Move {dst, src} => | |
552 | Vector.new1 | |
553 | (M.Statement.move {dst = translateOperand dst, | |
554 | src = translateOperand src}) | |
555 | | Object {dst, header, size} => | |
556 | M.Statement.object {dst = varOperand (#1 dst), | |
557 | header = header, | |
558 | size = size} | |
559 | | PrimApp {dst, prim, args} => | |
560 | let | |
561 | datatype z = datatype Prim.Name.t | |
562 | in | |
563 | case Prim.name prim of | |
564 | MLton_touch => Vector.new0 () | |
565 | | _ => | |
566 | Vector.new1 | |
567 | (M.Statement.PrimApp | |
568 | {args = translateOperands args, | |
569 | dst = Option.map (dst, varOperand o #1), | |
570 | prim = prim}) | |
571 | end | |
572 | | ProfileLabel s => Vector.new1 (M.Statement.ProfileLabel s) | |
573 | | SetExnStackLocal => | |
574 | (* ExnStack = stackTop + (offset + LABEL_SIZE) - StackBottom; *) | |
575 | let | |
576 | val tmp1 = | |
577 | M.Operand.Register | |
578 | (Register.new (Type.cpointer (), NONE)) | |
579 | val tmp2 = | |
580 | M.Operand.Register | |
581 | (Register.new (Type.csize (), NONE)) | |
582 | in | |
583 | Vector.new3 | |
584 | (M.Statement.PrimApp | |
585 | {args = (Vector.new2 | |
586 | (stackTopOp, | |
587 | M.Operand.Word | |
588 | (WordX.fromIntInf | |
589 | (Int.toIntInf | |
590 | (Bytes.toInt | |
591 | (Bytes.+ (handlerOffset (), Runtime.labelSize ()))), | |
592 | WordSize.cpointer ())))), | |
593 | dst = SOME tmp1, | |
594 | prim = Prim.cpointerAdd}, | |
595 | M.Statement.PrimApp | |
596 | {args = Vector.new2 (tmp1, stackBottomOp), | |
597 | dst = SOME tmp2, | |
598 | prim = Prim.cpointerDiff}, | |
599 | M.Statement.move | |
600 | {dst = exnStackOp, | |
601 | src = M.Operand.Cast (tmp2, Type.exnStack ())}) | |
602 | end | |
603 | | SetExnStackSlot => | |
604 | (* ExnStack = *(uint* )(stackTop + offset); *) | |
605 | Vector.new1 | |
606 | (M.Statement.move | |
607 | {dst = exnStackOp, | |
608 | src = M.Operand.stackOffset {offset = linkOffset (), | |
609 | ty = Type.exnStack ()}}) | |
610 | | SetHandler h => | |
611 | Vector.new1 | |
612 | (M.Statement.move | |
613 | {dst = M.Operand.stackOffset {offset = handlerOffset (), | |
614 | ty = Type.label h}, | |
615 | src = M.Operand.Label h}) | |
616 | | SetSlotExnStack => | |
617 | (* *(uint* )(stackTop + offset) = ExnStack; *) | |
618 | Vector.new1 | |
619 | (M.Statement.move | |
620 | {dst = M.Operand.stackOffset {offset = linkOffset (), | |
621 | ty = Type.exnStack ()}, | |
622 | src = exnStackOp}) | |
623 | | _ => Error.bug (concat | |
624 | ["Backend.genStatement: strange statement: ", | |
625 | R.Statement.toString s]) | |
626 | end | |
627 | val genStatement = | |
628 | Trace.trace ("Backend.genStatement", | |
629 | R.Statement.layout o #1, Vector.layout M.Statement.layout) | |
630 | genStatement | |
631 | val bugTransfer = fn () => | |
632 | M.Transfer.CCall | |
633 | {args = (Vector.new1 | |
634 | (globalVector | |
635 | (WordXVector.fromString | |
636 | "backend thought control shouldn't reach here"))), | |
637 | frameInfo = NONE, | |
638 | func = Type.BuiltInCFunction.bug (), | |
639 | return = NONE} | |
640 | val {get = labelInfo: Label.t -> {args: (Var.t * Type.t) vector}, | |
641 | set = setLabelInfo, ...} = | |
642 | Property.getSetOnce | |
643 | (Label.plist, Property.initRaise ("labelInfo", Label.layout)) | |
644 | val setLabelInfo = | |
645 | Trace.trace2 ("Backend.setLabelInfo", | |
646 | Label.layout, Layout.ignore, Unit.layout) | |
647 | setLabelInfo | |
648 | fun callReturnStackOffsets (xs: 'a vector, | |
649 | ty: 'a -> Type.t, | |
650 | shift: Bytes.t): StackOffset.t vector = | |
651 | #1 (Vector.mapAndFold | |
652 | (xs, Bytes.zero, | |
653 | fn (x, offset) => | |
654 | let | |
655 | val ty = ty x | |
656 | val offset = Type.align (ty, offset) | |
657 | in | |
658 | (StackOffset.T {offset = Bytes.+ (shift, offset), ty = ty}, | |
659 | Bytes.+ (offset, Type.bytes ty)) | |
660 | end)) | |
661 | val operandLive: M.Operand.t -> M.Live.t = | |
662 | valOf o M.Live.fromOperand | |
663 | val operandsLive: M.Operand.t vector -> M.Live.t vector = | |
664 | fn ops => Vector.map (ops, operandLive) | |
665 | val isGlobal = | |
666 | let | |
667 | val {get: Var.t -> bool, set, rem, ...} = | |
668 | Property.getSet | |
669 | (Var.plist, | |
670 | Property.initRaise ("Backend.toMachine.isGlobal", Var.layout)) | |
671 | val _ = | |
672 | Function.foreachDef (main, fn (x, _) => set (x, false)) | |
673 | val _ = | |
674 | List.foreach | |
675 | (functions, fn f => | |
676 | (Function.foreachUse (f, fn x => set (x, true)) | |
677 | ; Function.foreachDef (f, fn (x, _) => rem x))) | |
678 | in | |
679 | get | |
680 | end | |
681 | fun genFunc (f: Function.t, isMain: bool): unit = | |
682 | let | |
683 | val f = eliminateDeadCode f | |
684 | val {args, blocks, name, raises, returns, start, ...} = | |
685 | Function.dest f | |
686 | val raises = Option.map (raises, fn ts => raiseOperands ts) | |
687 | val returns = | |
688 | Option.map (returns, fn ts => | |
689 | callReturnStackOffsets (ts, fn t => t, Bytes.zero)) | |
690 | val chunk = funcChunk name | |
691 | fun labelArgOperands (l: R.Label.t): M.Operand.t vector = | |
692 | Vector.map (#args (labelInfo l), varOperand o #1) | |
693 | fun newVarInfo (x, ty: Type.t) = | |
694 | let | |
695 | val operand = | |
696 | if isMain andalso isGlobal x | |
697 | then let | |
698 | val _ = | |
699 | Control.diagnostics | |
700 | (fn display => | |
701 | let | |
702 | open Layout | |
703 | in | |
704 | display (seq | |
705 | [str "Global: ", | |
706 | R.Var.layout x, | |
707 | str ": ", | |
708 | R.Type.layout ty]) | |
709 | end) | |
710 | in | |
711 | VarOperand.Const (M.Operand.Global | |
712 | (M.Global.new {isRoot = true, | |
713 | ty = ty})) | |
714 | end | |
715 | else VarOperand.Allocate {operand = ref NONE} | |
716 | in | |
717 | setVarInfo (x, {operand = operand, | |
718 | ty = ty}) | |
719 | end | |
720 | fun newVarInfos xts = Vector.foreach (xts, newVarInfo) | |
721 | (* Set the constant operands, labelInfo, and varInfo. *) | |
722 | val _ = newVarInfos args | |
723 | val _ = | |
724 | Rssa.Function.dfs | |
725 | (f, fn R.Block.T {args, label, statements, transfer, ...} => | |
726 | let | |
727 | val _ = setLabelInfo (label, {args = args}) | |
728 | val _ = newVarInfos args | |
729 | val _ = | |
730 | Vector.foreach | |
731 | (statements, fn s => | |
732 | let | |
733 | fun normal () = R.Statement.foreachDef (s, newVarInfo) | |
734 | in | |
735 | case s of | |
736 | R.Statement.Bind {dst = (var, _), isMutable, src} => | |
737 | if isMutable | |
738 | then normal () | |
739 | else | |
740 | let | |
741 | fun set (z: M.Operand.t, | |
742 | casts: Type.t list) = | |
743 | let | |
744 | val z = | |
745 | List.fold | |
746 | (casts, z, fn (t, z) => | |
747 | M.Operand.Cast (z, t)) | |
748 | in | |
749 | setVarInfo | |
750 | (var, {operand = VarOperand.Const z, | |
751 | ty = M.Operand.ty z}) | |
752 | end | |
753 | fun loop (z: R.Operand.t, casts) = | |
754 | case z of | |
755 | R.Operand.Cast (z, t) => | |
756 | loop (z, t :: casts) | |
757 | | R.Operand.Const c => | |
758 | set (constOperand c, casts) | |
759 | | R.Operand.Var {var = var', ...} => | |
760 | (case #operand (varInfo var') of | |
761 | VarOperand.Const z => | |
762 | set (z, casts) | |
763 | | VarOperand.Allocate _ => | |
764 | normal ()) | |
765 | | _ => normal () | |
766 | in | |
767 | loop (src, []) | |
768 | end | |
769 | | _ => normal () | |
770 | end) | |
771 | val _ = R.Transfer.foreachDef (transfer, newVarInfo) | |
772 | in | |
773 | fn () => () | |
774 | end) | |
775 | (* Allocate stack slots. *) | |
776 | local | |
777 | val varInfo = | |
778 | fn x => | |
779 | let | |
780 | val {operand, ty, ...} = varInfo x | |
781 | in | |
782 | {operand = (case operand of | |
783 | VarOperand.Allocate {operand, ...} => | |
784 | SOME operand | |
785 | | _ => NONE), | |
786 | ty = ty} | |
787 | end | |
788 | in | |
789 | val {handlerLinkOffset, labelInfo = labelRegInfo, ...} = | |
790 | let | |
791 | fun formalsStackOffsets args = | |
792 | callReturnStackOffsets (args, fn (_, ty) => ty, Bytes.zero) | |
793 | in | |
794 | AllocateRegisters.allocate {formalsStackOffsets = formalsStackOffsets, | |
795 | function = f, | |
796 | varInfo = varInfo} | |
797 | end | |
798 | end | |
799 | (* Set the frameInfo for blocks in this function. *) | |
800 | val _ = | |
801 | Vector.foreach | |
802 | (blocks, fn R.Block.T {kind, label, ...} => | |
803 | let | |
804 | fun doit (useOffsets: bool): unit = | |
805 | let | |
806 | val {liveNoFormals, size, ...} = labelRegInfo label | |
807 | val offsets = | |
808 | if useOffsets | |
809 | then | |
810 | Vector.fold | |
811 | (liveNoFormals, [], fn (oper, ac) => | |
812 | case oper of | |
813 | M.Operand.StackOffset (StackOffset.T {offset, ty}) => | |
814 | if Type.isObjptr ty | |
815 | then offset :: ac | |
816 | else ac | |
817 | | _ => ac) | |
818 | else | |
819 | [] | |
820 | val isC = | |
821 | case kind of | |
822 | R.Kind.CReturn _ => true | |
823 | | _ => false | |
824 | val frameLayoutsIndex = | |
825 | getFrameLayoutsIndex {isC = isC, | |
826 | label = label, | |
827 | offsets = offsets, | |
828 | size = size} | |
829 | in | |
830 | setFrameInfo | |
831 | (label, | |
832 | SOME (M.FrameInfo.T | |
833 | {frameLayoutsIndex = frameLayoutsIndex})) | |
834 | end | |
835 | in | |
836 | case R.Kind.frameStyle kind of | |
837 | R.Kind.None => () | |
838 | | R.Kind.OffsetsAndSize => doit true | |
839 | | R.Kind.SizeOnly => doit false | |
840 | end) | |
841 | (* ------------------------------------------------- *) | |
842 | (* genTransfer *) | |
843 | (* ------------------------------------------------- *) | |
844 | fun genTransfer (t: R.Transfer.t, chunk: Chunk.t) | |
845 | : M.Statement.t vector * M.Transfer.t = | |
846 | let | |
847 | fun simple t = (Vector.new0 (), t) | |
848 | in | |
849 | case t of | |
850 | R.Transfer.Arith {args, dst, overflow, prim, success, | |
851 | ...} => | |
852 | simple | |
853 | (M.Transfer.Arith {args = translateOperands args, | |
854 | dst = varOperand dst, | |
855 | overflow = overflow, | |
856 | prim = prim, | |
857 | success = success}) | |
858 | | R.Transfer.CCall {args, func, return} => | |
859 | simple (M.Transfer.CCall | |
860 | {args = translateOperands args, | |
861 | frameInfo = (case return of | |
862 | NONE => NONE | |
863 | | SOME l => frameInfo l), | |
864 | func = func, | |
865 | return = return}) | |
866 | | R.Transfer.Call {func, args, return} => | |
867 | let | |
868 | datatype z = datatype R.Return.t | |
869 | val (contLive, frameSize, return) = | |
870 | case return of | |
871 | Dead => (Vector.new0 (), Bytes.zero, NONE) | |
872 | | Tail => (Vector.new0 (), Bytes.zero, NONE) | |
873 | | NonTail {cont, handler} => | |
874 | let | |
875 | val {liveNoFormals, size, ...} = | |
876 | labelRegInfo cont | |
877 | datatype z = datatype R.Handler.t | |
878 | val handler = | |
879 | case handler of | |
880 | Caller => NONE | |
881 | | Dead => NONE | |
882 | | Handle h => SOME h | |
883 | in | |
884 | (liveNoFormals, | |
885 | size, | |
886 | SOME {return = cont, | |
887 | handler = handler, | |
888 | size = size}) | |
889 | end | |
890 | val dsts = | |
891 | callReturnStackOffsets | |
892 | (args, R.Operand.ty, frameSize) | |
893 | val setupArgs = | |
894 | parallelMove | |
895 | {chunk = chunk, | |
896 | dsts = Vector.map (dsts, M.Operand.StackOffset), | |
897 | srcs = translateOperands args} | |
898 | val live = | |
899 | Vector.concat [operandsLive contLive, | |
900 | Vector.map (dsts, Live.StackOffset)] | |
901 | val transfer = | |
902 | M.Transfer.Call {label = funcToLabel func, | |
903 | live = live, | |
904 | return = return} | |
905 | in | |
906 | (setupArgs, transfer) | |
907 | end | |
908 | | R.Transfer.Goto {dst, args} => | |
909 | (parallelMove {srcs = translateOperands args, | |
910 | dsts = labelArgOperands dst, | |
911 | chunk = labelChunk dst}, | |
912 | M.Transfer.Goto dst) | |
913 | | R.Transfer.Raise srcs => | |
914 | (M.Statement.moves {dsts = Vector.map (valOf raises, | |
915 | Live.toOperand), | |
916 | srcs = translateOperands srcs}, | |
917 | M.Transfer.Raise) | |
918 | | R.Transfer.Return xs => | |
919 | (parallelMove {chunk = chunk, | |
920 | dsts = Vector.map (valOf returns, | |
921 | M.Operand.StackOffset), | |
922 | srcs = translateOperands xs}, | |
923 | M.Transfer.Return) | |
924 | | R.Transfer.Switch switch => | |
925 | let | |
926 | val R.Switch.T {cases, default, size, test} = | |
927 | switch | |
928 | in | |
929 | simple | |
930 | (case (Vector.length cases, default) of | |
931 | (0, NONE) => bugTransfer () | |
932 | | (1, NONE) => | |
933 | M.Transfer.Goto (#2 (Vector.sub (cases, 0))) | |
934 | | (0, SOME dst) => M.Transfer.Goto dst | |
935 | | _ => | |
936 | M.Transfer.Switch | |
937 | (M.Switch.T | |
938 | {cases = cases, | |
939 | default = default, | |
940 | size = size, | |
941 | test = translateOperand test})) | |
942 | end | |
943 | end | |
944 | val genTransfer = | |
945 | Trace.trace ("Backend.genTransfer", | |
946 | R.Transfer.layout o #1, | |
947 | Layout.tuple2 (Vector.layout M.Statement.layout, | |
948 | M.Transfer.layout)) | |
949 | genTransfer | |
950 | fun genBlock (R.Block.T {args, kind, label, statements, transfer, | |
951 | ...}) : unit = | |
952 | let | |
953 | val _ = | |
954 | if Label.equals (label, start) | |
955 | then let | |
956 | val live = #live (labelRegInfo start) | |
957 | val returns = | |
958 | Option.map | |
959 | (returns, fn returns => | |
960 | Vector.map (returns, Live.StackOffset)) | |
961 | in | |
962 | Chunk.newBlock | |
963 | (chunk, | |
964 | {label = funcToLabel name, | |
965 | kind = M.Kind.Func, | |
966 | live = operandsLive live, | |
967 | raises = raises, | |
968 | returns = returns, | |
969 | statements = Vector.new0 (), | |
970 | transfer = M.Transfer.Goto start}) | |
971 | end | |
972 | else () | |
973 | val {live, liveNoFormals, size, ...} = labelRegInfo label | |
974 | val chunk = labelChunk label | |
975 | val statements = | |
976 | Vector.concatV | |
977 | (Vector.map (statements, fn s => | |
978 | genStatement (s, handlerLinkOffset))) | |
979 | val (preTransfer, transfer) = genTransfer (transfer, chunk) | |
980 | val (kind, live, pre) = | |
981 | case kind of | |
982 | R.Kind.Cont _ => | |
983 | let | |
984 | val srcs = callReturnStackOffsets (args, #2, size) | |
985 | in | |
986 | (M.Kind.Cont {args = Vector.map (srcs, | |
987 | Live.StackOffset), | |
988 | frameInfo = valOf (frameInfo label)}, | |
989 | liveNoFormals, | |
990 | parallelMove | |
991 | {chunk = chunk, | |
992 | dsts = Vector.map (args, varOperand o #1), | |
993 | srcs = Vector.map (srcs, M.Operand.StackOffset)}) | |
994 | end | |
995 | | R.Kind.CReturn {func, ...} => | |
996 | let | |
997 | val dst = | |
998 | case Vector.length args of | |
999 | 0 => NONE | |
1000 | | 1 => SOME (operandLive | |
1001 | (varOperand | |
1002 | (#1 (Vector.sub (args, 0))))) | |
1003 | | _ => Error.bug "Backend.genBlock: CReturn" | |
1004 | in | |
1005 | (M.Kind.CReturn {dst = dst, | |
1006 | frameInfo = frameInfo label, | |
1007 | func = func}, | |
1008 | liveNoFormals, | |
1009 | Vector.new0 ()) | |
1010 | end | |
1011 | | R.Kind.Handler => | |
1012 | let | |
1013 | val _ = | |
1014 | List.push | |
1015 | (handlers, {chunkLabel = Chunk.label chunk, | |
1016 | label = label}) | |
1017 | val dsts = Vector.map (args, varOperand o #1) | |
1018 | val handles = | |
1019 | raiseOperands (Vector.map (dsts, M.Operand.ty)) | |
1020 | in | |
1021 | (M.Kind.Handler | |
1022 | {frameInfo = valOf (frameInfo label), | |
1023 | handles = handles}, | |
1024 | liveNoFormals, | |
1025 | M.Statement.moves | |
1026 | {dsts = dsts, | |
1027 | srcs = Vector.map (handles, Live.toOperand)}) | |
1028 | end | |
1029 | | R.Kind.Jump => (M.Kind.Jump, live, Vector.new0 ()) | |
1030 | val (first, statements) = | |
1031 | if !Control.profile = Control.ProfileTimeLabel | |
1032 | then | |
1033 | case (if Vector.isEmpty statements | |
1034 | then NONE | |
1035 | else (case Vector.first statements of | |
1036 | s as M.Statement.ProfileLabel _ => | |
1037 | SOME s | |
1038 | | _ => NONE)) of | |
1039 | NONE => | |
1040 | Error.bug | |
1041 | (concat ["Backend.genBlock: ", | |
1042 | "missing ProfileLabel in ", | |
1043 | Label.toString label]) | |
1044 | | SOME s => | |
1045 | (Vector.new1 s, | |
1046 | Vector.dropPrefix (statements, 1)) | |
1047 | else (Vector.new0 (), statements) | |
1048 | val statements = | |
1049 | Vector.concat [first, pre, statements, preTransfer] | |
1050 | val returns = | |
1051 | Option.map (returns, fn returns => | |
1052 | Vector.map (returns, Live.StackOffset)) | |
1053 | in | |
1054 | Chunk.newBlock (chunk, | |
1055 | {kind = kind, | |
1056 | label = label, | |
1057 | live = operandsLive live, | |
1058 | raises = raises, | |
1059 | returns = returns, | |
1060 | statements = statements, | |
1061 | transfer = transfer}) | |
1062 | end | |
1063 | val genBlock = traceGenBlock genBlock | |
1064 | val _ = Vector.foreach (blocks, genBlock) | |
1065 | val _ = | |
1066 | if isMain | |
1067 | then () | |
1068 | else Vector.foreach (blocks, R.Block.clear) | |
1069 | in | |
1070 | () | |
1071 | end | |
1072 | val genFunc = | |
1073 | Trace.trace2 ("Backend.genFunc", | |
1074 | Func.layout o Function.name, Bool.layout, Unit.layout) | |
1075 | genFunc | |
1076 | (* Generate the main function first. | |
1077 | * Need to do this in order to set globals. | |
1078 | *) | |
1079 | val _ = genFunc (main, true) | |
1080 | val _ = List.foreach (functions, fn f => genFunc (f, false)) | |
1081 | val chunks = !chunks | |
1082 | fun chunkToMachine (Chunk.T {chunkLabel, blocks}) = | |
1083 | let | |
1084 | val blocks = Vector.fromList (!blocks) | |
1085 | val regMax = CType.memo (fn _ => ref ~1) | |
1086 | val regsNeedingIndex = | |
1087 | Vector.fold | |
1088 | (blocks, [], fn (b, ac) => | |
1089 | M.Block.foldDefs | |
1090 | (b, ac, fn (z, ac) => | |
1091 | case z of | |
1092 | M.Operand.Register r => | |
1093 | (case Register.indexOpt r of | |
1094 | NONE => r :: ac | |
1095 | | SOME i => | |
1096 | let | |
1097 | val z = regMax (Type.toCType (Register.ty r)) | |
1098 | val _ = | |
1099 | if i > !z | |
1100 | then z := i | |
1101 | else () | |
1102 | in | |
1103 | ac | |
1104 | end) | |
1105 | | _ => ac)) | |
1106 | val _ = | |
1107 | List.foreach | |
1108 | (regsNeedingIndex, fn r => | |
1109 | let | |
1110 | val z = regMax (Type.toCType (Register.ty r)) | |
1111 | val i = 1 + !z | |
1112 | val _ = z := i | |
1113 | val _ = Register.setIndex (r, i) | |
1114 | in | |
1115 | () | |
1116 | end) | |
1117 | in | |
1118 | Machine.Chunk.T {chunkLabel = chunkLabel, | |
1119 | blocks = blocks, | |
1120 | regMax = ! o regMax} | |
1121 | end | |
1122 | val mainName = R.Function.name main | |
1123 | val main = {chunkLabel = Chunk.label (funcChunk mainName), | |
1124 | label = funcToLabel mainName} | |
1125 | val chunks = List.revMap (chunks, chunkToMachine) | |
1126 | (* The clear is necessary because properties have been attached to Funcs | |
1127 | * and Labels, and they appear as labels in the resulting program. | |
1128 | *) | |
1129 | val _ = List.foreach (chunks, fn M.Chunk.T {blocks, ...} => | |
1130 | Vector.foreach (blocks, Label.clear o M.Block.label)) | |
1131 | val (frameLabels, frameLayouts, frameOffsets) = allFrameInfo () | |
1132 | val maxFrameSize: Bytes.t = | |
1133 | List.fold | |
1134 | (chunks, Bytes.zero, fn (M.Chunk.T {blocks, ...}, max) => | |
1135 | Vector.fold | |
1136 | (blocks, max, fn (M.Block.T {kind, statements, transfer, ...}, max) => | |
1137 | let | |
1138 | fun doOperand (z: M.Operand.t, max: Bytes.t): Bytes.t = | |
1139 | let | |
1140 | datatype z = datatype M.Operand.t | |
1141 | in | |
1142 | case z of | |
1143 | ArrayOffset {base, index, ...} => | |
1144 | doOperand (base, doOperand (index, max)) | |
1145 | | Cast (z, _) => doOperand (z, max) | |
1146 | | Contents {oper, ...} => doOperand (oper, max) | |
1147 | | Offset {base, ...} => doOperand (base, max) | |
1148 | | StackOffset (StackOffset.T {offset, ty}) => | |
1149 | Bytes.max (Bytes.+ (offset, Type.bytes ty), max) | |
1150 | | _ => max | |
1151 | end | |
1152 | val max = | |
1153 | case M.Kind.frameInfoOpt kind of | |
1154 | NONE => max | |
1155 | | SOME (M.FrameInfo.T {frameLayoutsIndex, ...}) => | |
1156 | Bytes.max | |
1157 | (max, | |
1158 | #size (Vector.sub (frameLayouts, frameLayoutsIndex))) | |
1159 | val max = | |
1160 | Vector.fold | |
1161 | (statements, max, fn (s, max) => | |
1162 | M.Statement.foldOperands (s, max, doOperand)) | |
1163 | val max = | |
1164 | M.Transfer.foldOperands (transfer, max, doOperand) | |
1165 | in | |
1166 | max | |
1167 | end)) | |
1168 | val maxFrameSize = Bytes.alignWord32 maxFrameSize | |
1169 | val profileInfo = makeProfileInfo {frames = frameLabels} | |
1170 | val program = | |
1171 | Machine.Program.T | |
1172 | {chunks = chunks, | |
1173 | frameLayouts = frameLayouts, | |
1174 | frameOffsets = frameOffsets, | |
1175 | handlesSignals = handlesSignals, | |
1176 | main = main, | |
1177 | maxFrameSize = maxFrameSize, | |
1178 | objectTypes = objectTypes, | |
1179 | profileInfo = profileInfo, | |
1180 | reals = allReals (), | |
1181 | vectors = allVectors ()} | |
1182 | ||
1183 | local | |
1184 | open Machine | |
1185 | fun pass' ({name, doit}, sel, p) = | |
1186 | let | |
1187 | val _ = | |
1188 | let open Control | |
1189 | in maybeSaveToFile | |
1190 | ({name = name, | |
1191 | suffix = "pre.machine"}, | |
1192 | Control.No, p, Control.Layouts Program.layouts) | |
1193 | end | |
1194 | val p = | |
1195 | Control.passTypeCheck | |
1196 | {display = Control.Layouts | |
1197 | (fn (r,output) => | |
1198 | Program.layouts (sel r, output)), | |
1199 | name = name, | |
1200 | stats = fn _ => Layout.empty, | |
1201 | style = Control.No, | |
1202 | suffix = "post.machine", | |
1203 | thunk = fn () => doit p, | |
1204 | typeCheck = Program.typeCheck o sel} | |
1205 | in | |
1206 | p | |
1207 | end | |
1208 | fun pass ({name, doit}, p) = | |
1209 | pass' ({name = name, doit = doit}, fn p => p, p) | |
1210 | fun maybePass ({name, doit, execute}, p) = | |
1211 | if List.foldr (!Control.executePasses, execute, fn ((re, new), old) => | |
1212 | if Regexp.Compiled.matchesAll (re, name) | |
1213 | then new | |
1214 | else old) | |
1215 | then pass ({name = name, doit = doit}, p) | |
1216 | else (Control.messageStr (Control.Pass, name ^ " skipped"); p) | |
1217 | ||
1218 | fun shuffle p = | |
1219 | let | |
1220 | fun shuffle v = | |
1221 | let | |
1222 | val a = Array.fromVector v | |
1223 | val () = Array.shuffle a | |
1224 | in | |
1225 | Array.toVector a | |
1226 | end | |
1227 | val Machine.Program.T | |
1228 | {chunks, frameLayouts, frameOffsets, | |
1229 | handlesSignals, main, maxFrameSize, | |
1230 | objectTypes, profileInfo, | |
1231 | reals, vectors} = p | |
1232 | val chunks = Vector.fromList chunks | |
1233 | val chunks = shuffle chunks | |
1234 | val chunks = | |
1235 | Vector.map | |
1236 | (chunks, fn Machine.Chunk.T {blocks, chunkLabel, regMax} => | |
1237 | Machine.Chunk.T | |
1238 | {blocks = shuffle blocks, | |
1239 | chunkLabel = chunkLabel, | |
1240 | regMax = regMax}) | |
1241 | val chunks = Vector.toList chunks | |
1242 | in | |
1243 | Machine.Program.T | |
1244 | {chunks = chunks, | |
1245 | frameLayouts = frameLayouts, | |
1246 | frameOffsets = frameOffsets, | |
1247 | handlesSignals = handlesSignals, | |
1248 | main = main, | |
1249 | maxFrameSize = maxFrameSize, | |
1250 | objectTypes = objectTypes, | |
1251 | profileInfo = profileInfo, | |
1252 | reals = reals, | |
1253 | vectors = vectors} | |
1254 | end | |
1255 | in | |
1256 | val program = maybePass ({name = "machineShuffle", | |
1257 | doit = shuffle, | |
1258 | execute = false}, program) | |
1259 | end | |
1260 | in | |
1261 | program | |
1262 | end} | |
1263 | in | |
1264 | program | |
1265 | end | |
1266 | end |