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 / backend / machine.fun
CommitLineData
7f918cf1
CE		 1(* Copyright (C) 2009,2014,2016-2017 Matthew Fluet.
2 * Copyright (C) 1999-2007 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 Machine (S: MACHINE_STRUCTS): MACHINE =
11struct
12
13open S
14
15structure ObjptrTycon = ObjptrTycon ()
16structure Runtime = Runtime ()
17structure Scale = Scale ()
18structure RepType = RepType (structure CFunction = CFunction
19 structure CType = CType
20 structure Label = Label
21 structure ObjptrTycon = ObjptrTycon
22 structure Prim = Prim
23 structure RealSize = RealSize
24 structure Runtime = Runtime
25 structure Scale = Scale
26 structure WordSize = WordSize
27 structure WordX = WordX
28 structure WordXVector = WordXVector)
29structure ObjectType = RepType.ObjectType
30
31structure Type = RepType
32
33structure ChunkLabel = Id (val noname = "ChunkLabel")
34
35structure Register =
36 struct
37 datatype t = T of {index: int option ref,
38 ty: Type.t}
39
40 local
41 fun make f (T r) = f r
42 in
43 val indexOpt = ! o (make #index)
44 val ty = make #ty
45 end
46
47 fun layout (T {index, ty, ...}) =
48 let
49 open Layout
50 in
51 seq [str (concat ["R", Type.name ty]),
52 paren (case !index of
53 NONE => str "NONE"
54 | SOME i => Int.layout i),
55 str ": ",
56 Type.layout ty]
57 end
58
59 val toString = Layout.toString o layout
60
61 fun index (r as T {index, ...}) =
62 case !index of
63 NONE =>
64 Error.bug (concat ["Machine.Register: register ",
65 toString r, " missing index"])
66 | SOME i => i
67
68 fun setIndex (r as T {index, ...}, i) =
69 case !index of
70 NONE => index := SOME i
71 | SOME _ =>
72 Error.bug (concat ["Machine.Register: register ",
73 toString r, " index already set"])
74
75 fun new (ty, i) = T {index = ref i,
76 ty = ty}
77
78 fun equals (r, r') =
79 (case (indexOpt r, indexOpt r') of
80 (SOME i, SOME i') => i = i'
81 | _ => false)
82 andalso CType.equals (Type.toCType (ty r), Type.toCType (ty r'))
83
84 val equals =
85 Trace.trace2 ("Machine.Register.equals", layout, layout, Bool.layout) equals
86
87 val isSubtype: t * t -> bool =
88 fn (T {index = i, ty = t}, T {index = i', ty = t'}) =>
89 (case (!i, !i') of
90 (SOME i, SOME i') => i = i'
91 | _ => false)
92 andalso Type.isSubtype (t, t')
93 andalso CType.equals (Type.toCType t, Type.toCType t')
94 end
95
96structure Global =
97 struct
98 datatype t = T of {index: int,
99 isRoot: bool,
100 ty: Type.t}
101
102 fun layout (T {index, isRoot, ty, ...}) =
103 let
104 open Layout
105 in
106 seq [str "glob ",
107 record [("index", Int.layout index),
108 ("isRoot", Bool.layout isRoot),
109 ("ty", Type.layout ty)]]
110 end
111
112 local
113 fun make f (T r) = f r
114 in
115 val index = make #index
116 val isRoot = make #isRoot
117 val ty = make #ty
118 end
119
120 val nonRootCounter = Counter.new 0
121 fun numberOfNonRoot () = Counter.value nonRootCounter
122
123 val memo = CType.memo (fn _ => Counter.new 0)
124 fun numberOfType t = Counter.value (memo t)
125
126 fun new {isRoot, ty} =
127 let
128 val isRoot = isRoot orelse not (Type.isObjptr ty)
129 val counter =
130 if isRoot
131 then memo (Type.toCType ty)
132 else nonRootCounter
133 val g = T {index = Counter.next counter,
134 isRoot = isRoot,
135 ty = ty}
136 in
137 g
138 end
139
140 fun equals (T {index = i, isRoot = r, ty},
141 T {index = i', isRoot = r', ty = ty'}) =
142 i = i'
143 andalso r = r'
144 andalso Type.equals (ty, ty')
145
146 val isSubtype: t * t -> bool =
147 fn (T {index = i, isRoot = r, ty},
148 T {index = i', isRoot = r', ty = ty'}) =>
149 i = i'
150 andalso r = r'
151 andalso Type.isSubtype (ty, ty')
152 andalso CType.equals (Type.toCType ty, Type.toCType ty')
153 end
154
155structure StackOffset =
156 struct
157 datatype t = T of {offset: Bytes.t,
158 ty: Type.t}
159
160 local
161 fun make f (T r) = f r
162 in
163 val ty = make #ty
164 end
165
166 fun layout (T {offset, ty}): Layout.t =
167 let
168 open Layout
169 in
170 seq [str (concat ["S", Type.name ty]),
171 paren (Bytes.layout offset),
172 str ": ", Type.layout ty]
173 end
174
175 val equals: t * t -> bool =
176 fn (T {offset = b, ty}, T {offset = b', ty = ty'}) =>
177 Bytes.equals (b, b') andalso Type.equals (ty, ty')
178
179 val isSubtype: t * t -> bool =
180 fn (T {offset = b, ty = t}, T {offset = b', ty = t'}) =>
181 Bytes.equals (b, b') andalso Type.isSubtype (t, t')
182
183 val interfere: t * t -> bool =
184 fn (T {offset = b, ty = ty}, T {offset = b', ty = ty'}) =>
185 let
186 val max = Bytes.+ (b, Type.bytes ty)
187 val max' = Bytes.+ (b', Type.bytes ty')
188 in
189 Bytes.> (max, b') andalso Bytes.> (max', b)
190 end
191
192 fun shift (T {offset, ty}, size): t =
193 T {offset = Bytes.- (offset, size),
194 ty = ty}
195 end
196
197structure Operand =
198 struct
199 datatype t =
200 ArrayOffset of {base: t,
201 index: t,
202 offset: Bytes.t,
203 scale: Scale.t,
204 ty: Type.t}
205 | Cast of t * Type.t
206 | Contents of {oper: t,
207 ty: Type.t}
208 | Frontier
209 | GCState
210 | Global of Global.t
211 | Label of Label.t
212 | Null
213 | Offset of {base: t,
214 offset: Bytes.t,
215 ty: Type.t}
216 | Register of Register.t
217 | Real of RealX.t
218 | StackOffset of StackOffset.t
219 | StackTop
220 | Word of WordX.t
221
222 val ty =
223 fn ArrayOffset {ty, ...} => ty
224 | Cast (_, ty) => ty
225 | Contents {ty, ...} => ty
226 | Frontier => Type.cpointer ()
227 | GCState => Type.gcState ()
228 | Global g => Global.ty g
229 | Label l => Type.label l
230 | Null => Type.cpointer ()
231 | Offset {ty, ...} => ty
232 | Real r => Type.real (RealX.size r)
233 | Register r => Register.ty r
234 | StackOffset s => StackOffset.ty s
235 | StackTop => Type.cpointer ()
236 | Word w => Type.ofWordX w
237
238 fun layout (z: t): Layout.t =
239 let
240 open Layout
241 fun constrain (ty: Type.t): Layout.t =
242 if !Control.showTypes
243 then seq [str ": ", Type.layout ty]
244 else empty
245 in
246 case z of
247 ArrayOffset {base, index, offset, scale, ty} =>
248 seq [str (concat ["X", Type.name ty, " "]),
249 tuple [layout base, layout index, Scale.layout scale,
250 Bytes.layout offset],
251 constrain ty]
252 | Cast (z, ty) =>
253 seq [str "Cast ", tuple [layout z, Type.layout ty]]
254 | Contents {oper, ty} =>
255 seq [str (concat ["C", Type.name ty, " "]),
256 paren (layout oper)]
257 | Frontier => str "<Frontier>"
258 | GCState => str "<GCState>"
259 | Global g => Global.layout g
260 | Label l => Label.layout l
261 | Null => str "NULL"
262 | Offset {base, offset, ty} =>
263 seq [str (concat ["O", Type.name ty, " "]),
264 tuple [layout base, Bytes.layout offset],
265 constrain ty]
266 | Real r => RealX.layout r
267 | Register r => Register.layout r
268 | StackOffset so => StackOffset.layout so
269 | StackTop => str "<StackTop>"
270 | Word w => WordX.layout w
271 end
272
273 val toString = Layout.toString o layout
274
275 val rec equals =
276 fn (ArrayOffset {base = b, index = i, ...},
277 ArrayOffset {base = b', index = i', ...}) =>
278 equals (b, b') andalso equals (i, i')
279 | (Cast (z, t), Cast (z', t')) =>
280 Type.equals (t, t') andalso equals (z, z')
281 | (Contents {oper = z, ...}, Contents {oper = z', ...}) =>
282 equals (z, z')
283 | (GCState, GCState) => true
284 | (Global g, Global g') => Global.equals (g, g')
285 | (Label l, Label l') => Label.equals (l, l')
286 | (Offset {base = b, offset = i, ...},
287 Offset {base = b', offset = i', ...}) =>
288 equals (b, b') andalso Bytes.equals (i, i')
289 | (Real r, Real r') => RealX.equals (r, r')
290 | (Register r, Register r') => Register.equals (r, r')
291 | (StackOffset so, StackOffset so') => StackOffset.equals (so, so')
292 | (Word w, Word w') => WordX.equals (w, w')
293 | _ => false
294
295 val stackOffset = StackOffset o StackOffset.T
296
297 fun interfere (write: t, read: t): bool =
298 let
299 fun inter read = interfere (write, read)
300 in
301 case (read, write) of
302 (Cast (z, _), _) => interfere (write, z)
303 | (_, Cast (z, _)) => interfere (z, read)
304 | (ArrayOffset {base, index, ...}, _) =>
305 inter base orelse inter index
306 | (Contents {oper, ...}, _) => inter oper
307 | (Global g, Global g') => Global.equals (g, g')
308 | (Offset {base, ...}, _) => inter base
309 | (Register r, Register r') => Register.equals (r, r')
310 | (StackOffset so, StackOffset so') =>
311 StackOffset.interfere (so, so')
312 | _ => false
313 end
314
315 val rec isLocation =
316 fn ArrayOffset _ => true
317 | Cast (z, _) => isLocation z
318 | Contents _ => true
319 | GCState => true
320 | Global _ => true
321 | Offset _ => true
322 | Register _ => true
323 | StackOffset _ => true
324 | _ => false
325 end
326
327structure Switch = Switch (open Atoms
328 structure Type = Type
329 structure Use = Operand)
330
331structure Statement =
332 struct
333 datatype t =
334 Move of {dst: Operand.t,
335 src: Operand.t}
336 | Noop
337 | PrimApp of {args: Operand.t vector,
338 dst: Operand.t option,
339 prim: Type.t Prim.t}
340 | ProfileLabel of ProfileLabel.t
341
342 val layout =
343 let
344 open Layout
345 in
346 fn Move {dst, src} =>
347 mayAlign [Operand.layout dst,
348 seq [str " = ", Operand.layout src]]
349 | Noop => str "Noop"
350 | PrimApp {args, dst, prim, ...} =>
351 let
352 val rest =
353 seq [Prim.layout prim, str " ",
354 Vector.layout Operand.layout args]
355 in
356 case dst of
357 NONE => rest
358 | SOME z =>
359 mayAlign [Operand.layout z,
360 seq [str " = ", rest]]
361 end
362 | ProfileLabel l =>
363 seq [str "ProfileLabel ", ProfileLabel.layout l]
364 end
365
366 fun move (arg as {dst, src}) =
367 if Operand.equals (dst, src)
368 then Noop
369 else Move arg
370
371 val move =
372 Trace.trace ("Machine.Statement.move",
373 fn {dst, src} =>
374 Layout.record [("dst", Operand.layout dst),
375 ("src", Operand.layout src)],
376 layout)
377 move
378
379 fun moves {srcs, dsts} =
380 Vector.fromListRev
381 (Vector.fold2 (srcs, dsts, [], fn (src, dst, ac) =>
382 move {src = src, dst = dst} :: ac))
383
384 fun object {dst, header, size} =
385 let
386 datatype z = datatype Operand.t
387 fun bytes (b: Bytes.t): Operand.t =
388 Word (WordX.fromIntInf (Bytes.toIntInf b, WordSize.csize ()))
389 val temp = Register (Register.new (Type.cpointer (), NONE))
390 in
391 Vector.new4
392 (Move {dst = Contents {oper = Frontier,
393 ty = Type.objptrHeader ()},
394 src = Word (WordX.fromIntInf (Word.toIntInf header,
395 WordSize.objptrHeader ()))},
396 PrimApp {args = Vector.new2 (Frontier,
397 bytes (Runtime.normalMetaDataSize ())),
398 dst = SOME temp,
399 prim = Prim.cpointerAdd},
400 (* CHECK; if objptr <> cpointer, need non-trivial coercion here. *)
401 Move {dst = dst, src = Cast (temp, Operand.ty dst)},
402 PrimApp {args = Vector.new2 (Frontier, bytes size),
403 dst = SOME Frontier,
404 prim = Prim.cpointerAdd})
405 end
406
407 fun foldOperands (s, ac, f) =
408 case s of
409 Move {dst, src} => f (dst, f (src, ac))
410 | PrimApp {args, dst, ...} =>
411 Vector.fold (args, Option.fold (dst, ac, f), f)
412 | _ => ac
413
414 fun foldDefs (s, a, f) =
415 case s of
416 Move {dst, ...} => f (dst, a)
417 | PrimApp {dst, ...} => (case dst of
418 NONE => a
419 | SOME z => f (z, a))
420 | _ => a
421 end
422
423structure FrameInfo =
424 struct
425 datatype t = T of {frameLayoutsIndex: int}
426
427 fun layout (T {frameLayoutsIndex, ...}) =
428 Layout.record [("frameLayoutsIndex", Int.layout frameLayoutsIndex)]
429
430 fun equals (T {frameLayoutsIndex = i}, T {frameLayoutsIndex = i'}) =
431 i = i'
432 end
433
434structure Live =
435 struct
436 datatype t =
437 Global of Global.t
438 | Register of Register.t
439 | StackOffset of StackOffset.t
440
441 val layout: t -> Layout.t =
442 fn Global g => Global.layout g
443 | Register r => Register.layout r
444 | StackOffset s => StackOffset.layout s
445
446 val equals: t * t -> bool =
447 fn (Global g, Global g') => Global.equals (g, g')
448 | (Register r, Register r') => Register.equals (r, r')
449 | (StackOffset s, StackOffset s') => StackOffset.equals (s, s')
450 | _ => false
451
452 val ty =
453 fn Global g => Global.ty g
454 | Register r => Register.ty r
455 | StackOffset s => StackOffset.ty s
456
457 val isSubtype: t * t -> bool =
458 fn (Global g, Global g') => Global.isSubtype (g, g')
459 | (Register r, Register r') => Register.isSubtype (r, r')
460 | (StackOffset s, StackOffset s') => StackOffset.isSubtype (s, s')
461 | _ => false
462
463 val interfere: t * t -> bool =
464 fn (l, l') =>
465 equals (l, l')
466 orelse (case (l, l') of
467 (StackOffset s, StackOffset s') =>
468 StackOffset.interfere (s, s')
469 | _ => false)
470
471 val fromOperand: Operand.t -> t option =
472 fn Operand.Global g => SOME (Global g)
473 | Operand.Register r => SOME (Register r)
474 | Operand.StackOffset s => SOME (StackOffset s)
475 | _ => NONE
476
477 val toOperand: t -> Operand.t =
478 fn Global g => Operand.Global g
479 | Register r => Operand.Register r
480 | StackOffset s => Operand.StackOffset s
481 end
482
483structure Transfer =
484 struct
485 datatype t =
486 Arith of {args: Operand.t vector,
487 dst: Operand.t,
488 overflow: Label.t,
489 prim: Type.t Prim.t,
490 success: Label.t}
491 | CCall of {args: Operand.t vector,
492 frameInfo: FrameInfo.t option,
493 func: Type.t CFunction.t,
494 return: Label.t option}
495 | Call of {label: Label.t,
496 live: Live.t vector,
497 return: {return: Label.t,
498 handler: Label.t option,
499 size: Bytes.t} option}
500 | Goto of Label.t
501 | Raise
502 | Return
503 | Switch of Switch.t
504
505 fun layout t =
506 let
507 open Layout
508 in
509 case t of
510 Arith {prim, args, dst, overflow, success, ...} =>
511 seq [str "Arith ",
512 record [("prim", Prim.layout prim),
513 ("args", Vector.layout Operand.layout args),
514 ("dst", Operand.layout dst),
515 ("overflow", Label.layout overflow),
516 ("success", Label.layout success)]]
517 | CCall {args, frameInfo, func, return} =>
518 seq [str "CCall ",
519 record
520 [("args", Vector.layout Operand.layout args),
521 ("frameInfo", Option.layout FrameInfo.layout frameInfo),
522 ("func", CFunction.layout (func, Type.layout)),
523 ("return", Option.layout Label.layout return)]]
524 | Call {label, live, return} =>
525 seq [str "Call ",
526 record [("label", Label.layout label),
527 ("live", Vector.layout Live.layout live),
528 ("return", Option.layout
529 (fn {return, handler, size} =>
530 record [("return", Label.layout return),
531 ("handler",
532 Option.layout Label.layout handler),
533 ("size", Bytes.layout size)])
534 return)]]
535 | Goto l => seq [str "Goto ", Label.layout l]
536 | Raise => str "Raise"
537 | Return => str "Return "
538 | Switch s => Switch.layout s
539 end
540
541 fun foldOperands (t, ac, f) =
542 case t of
543 Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
544 | CCall {args, ...} => Vector.fold (args, ac, f)
545 | Switch s =>
546 Switch.foldLabelUse
547 (s, ac, {label = fn (_, a) => a,
548 use = f})
549 | _ => ac
550
551 fun foldDefs (t, a, f) =
552 case t of
553 Arith {dst, ...} => f (dst, a)
554 | _ => a
555 end
556
557structure Kind =
558 struct
559 datatype t =
560 Cont of {args: Live.t vector,
561 frameInfo: FrameInfo.t}
562 | CReturn of {dst: Live.t option,
563 frameInfo: FrameInfo.t option,
564 func: Type.t CFunction.t}
565 | Func
566 | Handler of {frameInfo: FrameInfo.t,
567 handles: Live.t vector}
568 | Jump
569
570 fun layout k =
571 let
572 open Layout
573 in
574 case k of
575 Cont {args, frameInfo} =>
576 seq [str "Cont ",
577 record [("args", Vector.layout Live.layout args),
578 ("frameInfo", FrameInfo.layout frameInfo)]]
579 | CReturn {dst, frameInfo, func} =>
580 seq [str "CReturn ",
581 record
582 [("dst", Option.layout Live.layout dst),
583 ("frameInfo", Option.layout FrameInfo.layout frameInfo),
584 ("func", CFunction.layout (func, Type.layout))]]
585 | Func => str "Func"
586 | Handler {frameInfo, handles} =>
587 seq [str "Handler ",
588 record [("frameInfo", FrameInfo.layout frameInfo),
589 ("handles",
590 Vector.layout Live.layout handles)]]
591 | Jump => str "Jump"
592 end
593
594 val frameInfoOpt =
595 fn Cont {frameInfo, ...} => SOME frameInfo
596 | CReturn {frameInfo, ...} => frameInfo
597 | Handler {frameInfo, ...} => SOME frameInfo
598 | _ => NONE
599 end
600
601structure Block =
602 struct
603 datatype t = T of {kind: Kind.t,
604 label: Label.t,
605 live: Live.t vector,
606 raises: Live.t vector option,
607 returns: Live.t vector option,
608 statements: Statement.t vector,
609 transfer: Transfer.t}
610
611 fun clear (T {label, ...}) = Label.clear label
612
613 local
614 fun make g (T r) = g r
615 in
616 val kind = make #kind
617 val label = make #label
618 end
619
620 fun layout (T {kind, label, live, raises, returns, statements, transfer}) =
621 let
622 open Layout
623 in
624 align [seq [Label.layout label,
625 str ": ",
626 record [("kind", Kind.layout kind),
627 ("live", Vector.layout Live.layout live),
628 ("raises",
629 Option.layout (Vector.layout Live.layout)
630 raises),
631 ("returns",
632 Option.layout (Vector.layout Live.layout)
633 returns)]],
634 indent (align
635 [align (Vector.toListMap
636 (statements, Statement.layout)),
637 Transfer.layout transfer],
638 4)]
639 end
640
641 fun layouts (block, output' : Layout.t -> unit) = output' (layout block)
642
643 fun foldDefs (T {kind, statements, transfer, ...}, a, f) =
644 let
645 val a =
646 case kind of
647 Kind.CReturn {dst, ...} =>
648 (case dst of
649 NONE => a
650 | SOME z => f (Live.toOperand z, a))
651 | _ => a
652 val a =
653 Vector.fold (statements, a, fn (s, a) =>
654 Statement.foldDefs (s, a, f))
655 val a = Transfer.foldDefs (transfer, a, f)
656 in
657 a
658 end
659 end
660
661structure Chunk =
662 struct
663 datatype t = T of {blocks: Block.t vector,
664 chunkLabel: ChunkLabel.t,
665 regMax: CType.t -> int}
666
667 fun layouts (T {blocks, ...}, output : Layout.t -> unit) =
668 Vector.foreach (blocks, fn block => Block.layouts (block, output))
669
670 fun clear (T {blocks, ...}) =
671 Vector.foreach (blocks, Block.clear)
672 end
673
674structure ProfileInfo =
675 struct
676 datatype t =
677 T of {frameSources: int vector,
678 labels: {label: ProfileLabel.t,
679 sourceSeqsIndex: int} vector,
680 names: string vector,
681 sourceSeqs: int vector vector,
682 sources: {nameIndex: int,
683 successorsIndex: int} vector}
684
685 val empty = T {frameSources = Vector.new0 (),
686 labels = Vector.new0 (),
687 names = Vector.new0 (),
688 sourceSeqs = Vector.new0 (),
689 sources = Vector.new0 ()}
690
691 fun clear (T {labels, ...}) =
692 Vector.foreach (labels, ProfileLabel.clear o #label)
693
694 fun layout (T {frameSources, labels, names, sourceSeqs, sources}) =
695 Layout.record
696 [("frameSources", Vector.layout Int.layout frameSources),
697 ("labels",
698 Vector.layout (fn {label, sourceSeqsIndex} =>
699 Layout.record
700 [("label", ProfileLabel.layout label),
701 ("sourceSeqsIndex",
702 Int.layout sourceSeqsIndex)])
703 labels),
704 ("names", Vector.layout String.layout names),
705 ("sourceSeqs", Vector.layout (Vector.layout Int.layout) sourceSeqs),
706 ("sources",
707 Vector.layout (fn {nameIndex, successorsIndex} =>
708 Layout.record [("nameIndex", Int.layout nameIndex),
709 ("successorsIndex",
710 Int.layout successorsIndex)])
711 sources)]
712
713 fun layouts (pi, output) = output (layout pi)
714
715 fun isOK (T {frameSources, labels, names, sourceSeqs, sources}): bool =
716 let
717 val namesLength = Vector.length names
718 val sourceSeqsLength = Vector.length sourceSeqs
719 val sourcesLength = Vector.length sources
720 in
721 !Control.profile = Control.ProfileNone
722 orelse
723 (Vector.forall (frameSources, fn i =>
724 0 <= i andalso i < sourceSeqsLength)
725 andalso (Vector.forall
726 (labels, fn {sourceSeqsIndex = i, ...} =>
727 0 <= i andalso i < sourceSeqsLength))
728 andalso (Vector.forall
729 (sourceSeqs, fn v =>
730 Vector.forall
731 (v, fn i => 0 <= i andalso i < sourcesLength)))
732 andalso (Vector.forall
733 (sources, fn {nameIndex, successorsIndex} =>
734 0 <= nameIndex
735 andalso nameIndex < namesLength
736 andalso 0 <= successorsIndex
737 andalso successorsIndex < sourceSeqsLength)))
738 end
739
740 fun modify (T {frameSources, labels, names, sourceSeqs, sources})
741 : {newProfileLabel: ProfileLabel.t -> ProfileLabel.t,
742 delProfileLabel: ProfileLabel.t -> unit,
743 getProfileInfo: unit -> t} =
744 let
745 val {get: ProfileLabel.t -> int, set, ...} =
746 Property.getSet
747 (ProfileLabel.plist,
748 Property.initRaise ("ProfileInfo.extend", ProfileLabel.layout))
749 val _ =
750 Vector.foreach
751 (labels, fn {label, sourceSeqsIndex} =>
752 set (label, sourceSeqsIndex))
753 val new = ref []
754 fun newProfileLabel l =
755 let
756 val i = get l
757 val l' = ProfileLabel.new ()
758 val _ = set (l', i)
759 val _ = List.push (new, {label = l', sourceSeqsIndex = i})
760 in
761 l'
762 end
763 fun delProfileLabel l = set (l, ~1)
764 fun getProfileInfo () =
765 let
766 val labels = Vector.concat
767 [labels, Vector.fromList (!new)]
768 val labels = Vector.keepAll
769 (labels, fn {label, ...} =>
770 get label <> ~1)
771 val pi = T {frameSources = frameSources,
772 labels = Vector.concat
773 [labels, Vector.fromList (!new)],
774 names = names,
775 sourceSeqs = sourceSeqs,
776 sources = sources}
777 in
778 Assert.assert ("Machine.getProfileInfo", fn () => isOK pi);
779 pi
780 end
781 in
782 {newProfileLabel = newProfileLabel,
783 delProfileLabel = delProfileLabel,
784 getProfileInfo = getProfileInfo}
785 end
786 end
787
788structure Program =
789 struct
790 datatype t = T of {chunks: Chunk.t list,
791 frameLayouts: {frameOffsetsIndex: int,
792 isC: bool,
793 size: Bytes.t} vector,
794 frameOffsets: Bytes.t vector vector,
795 handlesSignals: bool,
796 main: {chunkLabel: ChunkLabel.t,
797 label: Label.t},
798 maxFrameSize: Bytes.t,
799 objectTypes: ObjectType.t vector,
800 profileInfo: ProfileInfo.t option,
801 reals: (Global.t * RealX.t) list,
802 vectors: (Global.t * WordXVector.t) list}
803
804 fun clear (T {chunks, profileInfo, ...}) =
805 (List.foreach (chunks, Chunk.clear)
806 ; Option.app (profileInfo, ProfileInfo.clear))
807
808 fun frameSize (T {frameLayouts, ...},
809 FrameInfo.T {frameLayoutsIndex, ...}) =
810 #size (Vector.sub (frameLayouts, frameLayoutsIndex))
811
812 fun layouts (T {chunks, frameLayouts, frameOffsets, handlesSignals,
813 main = {label, ...},
814 maxFrameSize, objectTypes, profileInfo, ...},
815 output': Layout.t -> unit) =
816 let
817 open Layout
818 val output = output'
819 in
820 output (record
821 [("handlesSignals", Bool.layout handlesSignals),
822 ("main", Label.layout label),
823 ("maxFrameSize", Bytes.layout maxFrameSize),
824 ("frameOffsets",
825 Vector.layout (Vector.layout Bytes.layout) frameOffsets),
826 ("frameLayouts",
827 Vector.layout (fn {frameOffsetsIndex, isC, size} =>
828 record [("frameOffsetsIndex",
829 Int.layout frameOffsetsIndex),
830 ("isC", Bool.layout isC),
831 ("size", Bytes.layout size)])
832 frameLayouts)])
833 ; Option.app (profileInfo, fn pi =>
834 (output (str "\nProfileInfo:")
835 ; ProfileInfo.layouts (pi, output)))
836 ; output (str "\nObjectTypes:")
837 ; Vector.foreachi (objectTypes, fn (i, ty) =>
838 output (seq [str "opt_", Int.layout i,
839 str " = ", ObjectType.layout ty]))
840 ; output (str "\n")
841 ; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
842 end
843
844 structure Alloc =
845 struct
846 datatype t = T of Live.t list
847
848 fun layout (T ds) = List.layout Live.layout ds
849
850 fun forall (T ds, f) = List.forall (ds, f o Live.toOperand)
851
852 fun defineLive (T ls, l) = T (l :: ls)
853
854 fun define (T ds, z) =
855 case Live.fromOperand z of
856 NONE => T ds
857 | SOME d => T (d :: ds)
858
859 val new: Live.t list -> t = T
860
861 fun doesDefine (T ls, l': Live.t): bool =
862 let
863 val oper' = Live.toOperand l'
864 in
865 case List.peek (ls, fn l =>
866 Operand.interfere (Live.toOperand l, oper')) of
867 NONE => false
868 | SOME l => Live.isSubtype (l, l')
869 end
870
871 val doesDefine =
872 Trace.trace2
873 ("Machine.Program.Alloc.doesDefine",
874 layout, Live.layout, Bool.layout)
875 doesDefine
876 end
877
878 fun typeCheck (program as
879 T {chunks, frameLayouts, frameOffsets,
880 maxFrameSize, objectTypes, profileInfo, reals,
881 vectors, ...}) =
882 let
883 val _ =
884 if !Control.profile = Control.ProfileTimeLabel
885 then
886 List.foreach
887 (chunks, fn Chunk.T {blocks, ...} =>
888 Vector.foreach
889 (blocks, fn Block.T {kind, label, statements, ...} =>
890 if (case kind of
891 Kind.Func => true
892 | _ => false)
893 orelse (0 < Vector.length statements
894 andalso (case Vector.first statements of
895 Statement.ProfileLabel _ => true
896 | _ => false))
897 then ()
898 else print (concat ["missing profile info: ",
899 Label.toString label, "\n"])))
900 else ()
901 val profileLabelIsOk =
902 case profileInfo of
903 NONE =>
904 if !Control.profile = Control.ProfileNone
905 then fn _ => false
906 else Error.bug
907 "Machine.Program.typeCheck.profileLabelIsOk: profileInfo = NONE"
908 | SOME (ProfileInfo.T {frameSources,
909 labels = profileLabels, ...}) =>
910 if !Control.profile = Control.ProfileNone
911 orelse (Vector.length frameSources
912 <> Vector.length frameLayouts)
913 then Error.bug
914 "Machine.Program.typeCheck.profileLabelIsOk: profileInfo = SOME"
915 else
916 let
917 val {get = profileLabelCount, ...} =
918 Property.get
919 (ProfileLabel.plist,
920 Property.initFun (fn _ => ref 0))
921 val _ =
922 Vector.foreach
923 (profileLabels, fn {label, ...} =>
924 let
925 val r = profileLabelCount label
926 in
927 if 0 = !r
928 then r := 1
929 else Error.bug
930 "Machine.Program.typeCheck.profileLabelIsOk: duplicate profile label"
931 end)
932 in
933 fn l =>
934 let
935 val r = profileLabelCount l
936 in
937 if 1 = !r
938 then (r := 2; true)
939 else false
940 end
941 end
942 fun getFrameInfo (FrameInfo.T {frameLayoutsIndex, ...}) =
943 Vector.sub (frameLayouts, frameLayoutsIndex)
944 val _ =
945 Vector.foreach
946 (frameLayouts, fn {frameOffsetsIndex, size, ...} =>
947 Err.check
948 ("frameLayouts",
949 fn () => (0 <= frameOffsetsIndex
950 andalso frameOffsetsIndex < Vector.length frameOffsets
951 andalso Bytes.<= (size, maxFrameSize)
952 andalso Bytes.<= (size, Runtime.maxFrameSize)
953 andalso Bytes.isWord32Aligned size),
954 fn () => Layout.record [("frameOffsetsIndex",
955 Int.layout frameOffsetsIndex),
956 ("size", Bytes.layout size)]))
957 val _ =
958 Vector.foreach
959 (objectTypes, fn ty =>
960 Err.check ("objectType",
961 fn () => ObjectType.isOk ty,
962 fn () => ObjectType.layout ty))
963 fun tyconTy (opt: ObjptrTycon.t): ObjectType.t =
964 Vector.sub (objectTypes, ObjptrTycon.index opt)
965 open Layout
966 fun globals (name, gs, isOk, layout) =
967 List.foreach
968 (gs, fn (g, s) =>
969 let
970 val ty = Global.ty g
971 in
972 Err.check
973 (concat ["global ", name],
974 fn () => isOk (ty, s),
975 fn () => seq [layout s, str ": ", Type.layout ty])
976 end)
977 val _ =
978 globals ("real", reals,
979 fn (t, r) => Type.equals (t, Type.real (RealX.size r)),
980 RealX.layout)
981 val _ =
982 globals ("vector", vectors,
983 fn (t, v) =>
984 Type.equals (t, Type.ofWordXVector v),
985 WordXVector.layout)
986 (* Check for no duplicate labels. *)
987 local
988 val {get, ...} =
989 Property.get (Label.plist,
990 Property.initFun (fn _ => ref false))
991 in
992 val _ =
993 List.foreach
994 (chunks, fn Chunk.T {blocks, ...} =>
995 Vector.foreach
996 (blocks, fn Block.T {label, ...} =>
997 let
998 val r = get label
999 in
1000 if !r
1001 then Error.bug "Machine.Program.typeCheck: duplicate label"
1002 else r := true
1003 end))
1004 end
1005 val {get = labelBlock: Label.t -> Block.t,
1006 set = setLabelBlock, ...} =
1007 Property.getSetOnce (Label.plist,
1008 Property.initRaise ("block", Label.layout))
1009 val _ =
1010 List.foreach
1011 (chunks, fn Chunk.T {blocks, ...} =>
1012 Vector.foreach
1013 (blocks, fn b as Block.T {label, ...} =>
1014 setLabelBlock (label, b)))
1015 fun checkOperand (x: Operand.t, alloc: Alloc.t): unit =
1016 let
1017 datatype z = datatype Operand.t
1018 fun ok () =
1019 case x of
1020 ArrayOffset {base, index, offset, scale, ty} =>
1021 (checkOperand (base, alloc)
1022 ; checkOperand (index, alloc)
1023 ; (Operand.isLocation base
1024 andalso
1025 (Type.arrayOffsetIsOk {base = Operand.ty base,
1026 index = Operand.ty index,
1027 offset = offset,
1028 tyconTy = tyconTy,
1029 result = ty,
1030 scale = scale})))
1031 | Cast (z, t) =>
1032 (checkOperand (z, alloc)
1033 ; (Type.castIsOk
1034 {from = Operand.ty z,
1035 to = t,
1036 tyconTy = tyconTy}))
1037 | Contents {oper, ...} =>
1038 (checkOperand (oper, alloc)
1039 ; Type.isCPointer (Operand.ty oper))
1040 | Frontier => true
1041 | GCState => true
1042 | Global _ =>
1043 (* We don't check that globals are defined because
1044 * they aren't captured by liveness info. It would
1045 * be nice to fix this.
1046 *)
1047 true
1048 | Label l =>
1049 (let val _ = labelBlock l
1050 in true
1051 end handle _ => false)
1052 | Null => true
1053 | Offset {base, offset, ty} =>
1054 (checkOperand (base, alloc)
1055 ; (Operand.isLocation base
1056 andalso
1057 (case base of
1058 Operand.GCState => true
1059 | _ =>
1060 Type.offsetIsOk {base = Operand.ty base,
1061 offset = offset,
1062 tyconTy = tyconTy,
1063 result = ty})))
1064 | Real _ => true
1065 | Register r => Alloc.doesDefine (alloc, Live.Register r)
1066 | StackOffset (so as StackOffset.T {offset, ty, ...}) =>
1067 Bytes.<= (Bytes.+ (offset, Type.bytes ty),
1068 maxFrameSize)
1069 andalso Alloc.doesDefine (alloc, Live.StackOffset so)
1070 andalso (case Type.deLabel ty of
1071 NONE => true
1072 | SOME l =>
1073 let
1074 val Block.T {kind, ...} =
1075 labelBlock l
1076 fun doit fi =
1077 let
1078 val {size, ...} =
1079 getFrameInfo fi
1080 in
1081 Bytes.equals
1082 (size,
1083 Bytes.+ (offset,
1084 Runtime.labelSize ()))
1085 end
1086 in
1087 case kind of
1088 Kind.Cont {frameInfo, ...} =>
1089 doit frameInfo
1090 | Kind.CReturn {frameInfo, ...} =>
1091 (case frameInfo of
1092 NONE => true
1093 | SOME fi => doit fi)
1094 | Kind.Func => true
1095 | Kind.Handler {frameInfo, ...} =>
1096 doit frameInfo
1097 | Kind.Jump => true
1098 end)
1099 | StackTop => true
1100 | Word _ => true
1101 in
1102 Err.check ("operand", ok, fn () => Operand.layout x)
1103 end
1104 fun checkOperands (v, a) =
1105 Vector.foreach (v, fn z => checkOperand (z, a))
1106 fun check' (x, name, isOk, layout) =
1107 Err.check (name, fn () => isOk x, fn () => layout x)
1108 val labelKind = Block.kind o labelBlock
1109 fun checkKind (k: Kind.t, alloc: Alloc.t): Alloc.t option =
1110 let
1111 datatype z = datatype Kind.t
1112 exception No
1113 fun frame (FrameInfo.T {frameLayoutsIndex},
1114 useSlots: bool,
1115 isC: bool): bool =
1116 let
1117 val {frameOffsetsIndex, isC = isC', ...} =
1118 Vector.sub (frameLayouts, frameLayoutsIndex)
1119 handle Subscript => raise No
1120 in
1121 isC = isC'
1122 andalso
1123 (not useSlots
1124 orelse
1125 let
1126 val Alloc.T zs = alloc
1127 val liveOffsets =
1128 List.fold
1129 (zs, [], fn (z, liveOffsets) =>
1130 case z of
1131 Live.StackOffset (StackOffset.T {offset, ty}) =>
1132 if Type.isObjptr ty
1133 then offset :: liveOffsets
1134 else liveOffsets
1135 | _ => raise No)
1136 val liveOffsets = Array.fromList liveOffsets
1137 val () = QuickSort.sortArray (liveOffsets, Bytes.<=)
1138 val liveOffsets = Vector.fromArray liveOffsets
1139 val liveOffsets' =
1140 Vector.sub (frameOffsets, frameOffsetsIndex)
1141 handle Subscript => raise No
1142 in
1143 Vector.equals (liveOffsets, liveOffsets',
1144 Bytes.equals)
1145 end)
1146 end handle No => false
1147 fun slotsAreInFrame (fi: FrameInfo.t): bool =
1148 let
1149 val {size, ...} = getFrameInfo fi
1150 in
1151 Alloc.forall
1152 (alloc, fn z =>
1153 case z of
1154 Operand.StackOffset (StackOffset.T {offset, ty}) =>
1155 Bytes.<= (Bytes.+ (offset, Type.bytes ty), size)
1156 | _ => false)
1157 end
1158 in
1159 case k of
1160 Cont {args, frameInfo} =>
1161 if frame (frameInfo, true, false)
1162 andalso slotsAreInFrame frameInfo
1163 then SOME (Vector.fold
1164 (args, alloc, fn (z, alloc) =>
1165 Alloc.defineLive (alloc, z)))
1166 else NONE
1167 | CReturn {dst, frameInfo, func, ...} =>
1168 let
1169 val ok =
1170 (case dst of
1171 NONE => true
1172 | SOME z =>
1173 Type.isSubtype (CFunction.return func,
1174 Live.ty z))
1175 andalso
1176 (if CFunction.mayGC func
1177 then (case frameInfo of
1178 NONE => false
1179 | SOME fi =>
1180 (frame (fi, true, true)
1181 andalso slotsAreInFrame fi))
1182 else if !Control.profile = Control.ProfileNone
1183 then true
1184 else (case frameInfo of
1185 NONE => false
1186 | SOME fi => frame (fi, false, true)))
1187 in
1188 if ok
1189 then SOME (case dst of
1190 NONE => alloc
1191 | SOME z => Alloc.defineLive (alloc, z))
1192 else NONE
1193 end
1194 | Func => SOME alloc
1195 | Handler {frameInfo, ...} =>
1196 if frame (frameInfo, false, false)
1197 then SOME alloc
1198 else NONE
1199 | Jump => SOME alloc
1200 end
1201 fun checkStatement (s: Statement.t, alloc: Alloc.t)
1202 : Alloc.t option =
1203 let
1204 datatype z = datatype Statement.t
1205 in
1206 case s of
1207 Move {dst, src} =>
1208 let
1209 val _ = checkOperand (src, alloc)
1210 val alloc = Alloc.define (alloc, dst)
1211 val _ = checkOperand (dst, alloc)
1212 in
1213 if Type.isSubtype (Operand.ty src, Operand.ty dst)
1214 andalso Operand.isLocation dst
1215 then SOME alloc
1216 else NONE
1217 end
1218 | Noop => SOME alloc
1219 | PrimApp {args, dst, prim, ...} =>
1220 let
1221 val _ = checkOperands (args, alloc)
1222 val alloc =
1223 case dst of
1224 NONE => SOME alloc
1225 | SOME z =>
1226 let
1227 val alloc = Alloc.define (alloc, z)
1228 val _ = checkOperand (z, alloc)
1229 in
1230 SOME alloc
1231 end
1232 val ok =
1233 Type.checkPrimApp
1234 {args = Vector.map (args, Operand.ty),
1235 prim = prim,
1236 result = Option.map (dst, Operand.ty)}
1237 in
1238 if ok
1239 then alloc
1240 else NONE
1241 end
1242 | ProfileLabel l =>
1243 if profileLabelIsOk l
1244 then SOME alloc
1245 else NONE
1246 end
1247 fun liveIsOk (live: Live.t vector,
1248 a: Alloc.t): bool =
1249 Vector.forall (live, fn z => Alloc.doesDefine (a, z))
1250 fun liveSubset (live: Live.t vector,
1251 live': Live.t vector): bool =
1252 Vector.forall
1253 (live, fn z => Vector.exists (live', fn z' =>
1254 Live.equals (z, z')))
1255 fun goto (Block.T {live,
1256 raises = raises',
1257 returns = returns', ...},
1258 raises: Live.t vector option,
1259 returns: Live.t vector option,
1260 alloc: Alloc.t): bool =
1261 liveIsOk (live, alloc)
1262 andalso
1263 (case (raises, raises') of
1264 (_, NONE) => true
1265 | (SOME gs, SOME gs') =>
1266 Vector.equals (gs', gs, Live.isSubtype)
1267 | _ => false)
1268 andalso
1269 (case (returns, returns') of
1270 (_, NONE) => true
1271 | (SOME os, SOME os') =>
1272 Vector.equals (os', os, Live.isSubtype)
1273 | _ => false)
1274 fun checkCont (cont: Label.t, size: Bytes.t, alloc: Alloc.t) =
1275 let
1276 val Block.T {kind, live, ...} = labelBlock cont
1277 in
1278 if Vector.forall (live, fn z => Alloc.doesDefine (alloc, z))
1279 then
1280 (case kind of
1281 Kind.Cont {args, frameInfo, ...} =>
1282 (if Bytes.equals (size,
1283 #size (getFrameInfo frameInfo))
1284 then
1285 SOME
1286 (live,
1287 SOME
1288 (Vector.map
1289 (args, fn z =>
1290 case z of
1291 Live.StackOffset s =>
1292 Live.StackOffset
1293 (StackOffset.shift (s, size))
1294 | _ => z)))
1295 else NONE)
1296 | _ => NONE)
1297 else NONE
1298 end
1299 fun callIsOk {alloc: Alloc.t,
1300 dst: Label.t,
1301 live: Live.t vector,
1302 raises: Live.t vector option,
1303 return,
1304 returns: Live.t vector option} =
1305 let
1306 val {raises, returns, size} =
1307 case return of
1308 NONE =>
1309 {raises = raises,
1310 returns = returns,
1311 size = Bytes.zero}
1312 | SOME {handler, return, size} =>
1313 let
1314 val (contLive, returns) =
1315 Err.check'
1316 ("cont",
1317 fn () => checkCont (return, size, alloc),
1318 fn () => Label.layout return)
1319 fun checkHandler () =
1320 case handler of
1321 NONE => SOME raises
1322 | SOME h =>
1323 let
1324 val Block.T {kind, live, ...} =
1325 labelBlock h
1326 in
1327 if liveSubset (live, contLive)
1328 then
1329 (case kind of
1330 Kind.Handler {handles, ...} =>
1331 SOME (SOME handles)
1332 | _ => NONE)
1333 else NONE
1334 end
1335 val raises =
1336 Err.check'
1337 ("handler", checkHandler,
1338 fn () => Option.layout Label.layout handler)
1339 in
1340 {raises = raises,
1341 returns = returns,
1342 size = size}
1343 end
1344 val b = labelBlock dst
1345 val alloc =
1346 Alloc.T
1347 (Vector.fold
1348 (live, [], fn (z, ac) =>
1349 case z of
1350 Live.StackOffset (StackOffset.T {offset, ty}) =>
1351 if Bytes.< (offset, size)
1352 then ac
1353 else (Live.StackOffset
1354 (StackOffset.T
1355 {offset = Bytes.- (offset, size),
1356 ty = ty})) :: ac
1357 | _ => ac))
1358 in
1359 goto (b, raises, returns, alloc)
1360 end
1361 fun transferOk
1362 (t: Transfer.t,
1363 raises: Live.t vector option,
1364 returns: Live.t vector option,
1365 alloc: Alloc.t): bool =
1366 let
1367 fun jump (l: Label.t, a: Alloc.t) =
1368 let
1369 val b as Block.T {kind, ...} = labelBlock l
1370 in
1371 (case kind of
1372 Kind.Jump => true
1373 | _ => false)
1374 andalso goto (b, raises, returns, a)
1375 end
1376 datatype z = datatype Transfer.t
1377 in
1378 case t of
1379 Arith {args, dst, overflow, prim, success, ...} =>
1380 let
1381 val _ = checkOperands (args, alloc)
1382 val alloc = Alloc.define (alloc, dst)
1383 val _ = checkOperand (dst, alloc)
1384 in
1385 Prim.mayOverflow prim
1386 andalso jump (overflow, alloc)
1387 andalso jump (success, alloc)
1388 andalso
1389 Type.checkPrimApp
1390 {args = Vector.map (args, Operand.ty),
1391 prim = prim,
1392 result = SOME (Operand.ty dst)}
1393 end
1394 | CCall {args, frameInfo = fi, func, return} =>
1395 let
1396 val _ = checkOperands (args, alloc)
1397 in
1398 CFunction.isOk (func, {isUnit = Type.isUnit})
1399 andalso
1400 Vector.equals (args, CFunction.args func,
1401 fn (z, t) =>
1402 Type.isSubtype (Operand.ty z, t))
1403 andalso
1404 case return of
1405 NONE => true
1406 | SOME l =>
1407 let
1408 val Block.T {live, ...} = labelBlock l
1409 in
1410 liveIsOk (live, alloc)
1411 andalso
1412 case labelKind l of
1413 Kind.CReturn
1414 {frameInfo = fi', func = f, ...} =>
1415 CFunction.equals (func, f)
1416 andalso (Option.equals
1417 (fi, fi', FrameInfo.equals))
1418 | _ => false
1419 end
1420 end
1421 | Call {label, live, return} =>
1422 Vector.forall
1423 (live, fn z => Alloc.doesDefine (alloc, z))
1424 andalso
1425 callIsOk {alloc = alloc,
1426 dst = label,
1427 live = live,
1428 raises = raises,
1429 return = return,
1430 returns = returns}
1431 | Goto l => jump (l, alloc)
1432 | Raise =>
1433 (case raises of
1434 NONE => false
1435 | SOME zs =>
1436 Vector.forall
1437 (zs, fn z => Alloc.doesDefine (alloc, z)))
1438 | Return =>
1439 (case returns of
1440 NONE => false
1441 | SOME zs =>
1442 Vector.forall
1443 (zs, fn z => Alloc.doesDefine (alloc, z)))
1444 | Switch s =>
1445 Switch.isOk
1446 (s, {checkUse = fn z => checkOperand (z, alloc),
1447 labelIsOk = fn l => jump (l, alloc)})
1448 end
1449 val transferOk =
1450 Trace.trace
1451 ("Machine.Program.typeCheck.transferOk",
1452 fn (t, _, _, a) =>
1453 Layout.tuple [Transfer.layout t, Alloc.layout a],
1454 Bool.layout)
1455 transferOk
1456 fun blockOk (Block.T {kind, live, raises, returns, statements,
1457 transfer, ...}): bool =
1458 let
1459 val live = Vector.toList live
1460 val _ =
1461 Err.check
1462 ("live",
1463 fn () =>
1464 let
1465 fun loop zs =
1466 case zs of
1467 [] => true
1468 | z :: zs =>
1469 List.forall
1470 (zs, fn z' =>
1471 not (Live.interfere (z, z')))
1472 in
1473 loop live
1474 end,
1475 fn () => List.layout Live.layout live)
1476 val alloc = Alloc.new live
1477 val alloc =
1478 Err.check'
1479 ("kind",
1480 fn () => checkKind (kind, alloc),
1481 fn () => Kind.layout kind)
1482 val alloc =
1483 Vector.fold
1484 (statements, alloc, fn (s, alloc) =>
1485 Err.check'
1486 ("statement",
1487 fn () => checkStatement (s, alloc),
1488 fn () => Statement.layout s))
1489 val _ =
1490 Err.check
1491 ("transfer",
1492 fn () => transferOk (transfer, raises, returns, alloc),
1493 fn () => Transfer.layout transfer)
1494 in
1495 true
1496 end
1497 val _ =
1498 List.foreach
1499 (chunks,
1500 fn Chunk.T {blocks, ...} =>
1501 let
1502 in
1503 Vector.foreach
1504 (blocks, fn b =>
1505 check' (b, "block", blockOk, Block.layout))
1506 end)
1507 val _ = clear program
1508 in
1509 ()
1510 end handle Err.E e => (Layout.outputl (Err.layout e, Out.error)
1511 ; Error.bug "Machine.typeCheck")
1512
1513 fun clearLabelNames (T {chunks, ...}): unit =
1514 List.foreach
1515 (chunks, fn Chunk.T {blocks, ...} =>
1516 Vector.foreach
1517 (blocks, fn Block.T {label, ...} =>
1518 Label.clearPrintName label))
1519 end
1520
1521end
mlton packaging