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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor Machine (S: MACHINE_STRUCTS): MACHINE =
15 structure ObjptrTycon = ObjptrTycon ()
16 structure Runtime = Runtime ()
17 structure Scale = Scale ()
18 structure RepType = RepType (structure CFunction = CFunction
19 structure CType = CType
20 structure Label = Label
21 structure ObjptrTycon = ObjptrTycon
23 structure RealSize = RealSize
24 structure Runtime = Runtime
25 structure Scale = Scale
26 structure WordSize = WordSize
27 structure WordX = WordX
28 structure WordXVector = WordXVector)
29 structure ObjectType = RepType.ObjectType
31 structure Type = RepType
33 structure ChunkLabel = Id (val noname = "ChunkLabel")
37 datatype t = T of {index: int option ref,
41 fun make f (T r) = f r
43 val indexOpt = ! o (make #index)
47 fun layout (T {index, ty, ...}) =
51 seq [str (concat ["R", Type.name ty]),
54 | SOME i => Int.layout i),
59 val toString = Layout.toString o layout
61 fun index (r as T {index, ...}) =
64 Error.bug (concat ["Machine.Register: register ",
65 toString r, " missing index"])
68 fun setIndex (r as T {index, ...}, i) =
70 NONE => index := SOME i
72 Error.bug (concat ["Machine.Register: register ",
73 toString r, " index already set"])
75 fun new (ty, i) = T {index = ref i,
79 (case (indexOpt r, indexOpt r') of
80 (SOME i, SOME i') => i = i'
82 andalso CType.equals (Type.toCType (ty r), Type.toCType (ty r'))
85 Trace.trace2 ("Machine.Register.equals", layout, layout, Bool.layout) equals
87 val isSubtype: t * t -> bool =
88 fn (T {index = i, ty = t}, T {index = i', ty = t'}) =>
90 (SOME i, SOME i') => i = i'
92 andalso Type.isSubtype (t, t')
93 andalso CType.equals (Type.toCType t, Type.toCType t')
98 datatype t = T of {index: int,
102 fun layout (T {index, isRoot, ty, ...}) =
107 record [("index", Int.layout index),
108 ("isRoot", Bool.layout isRoot),
109 ("ty", Type.layout ty)]]
113 fun make f (T r) = f r
115 val index = make #index
116 val isRoot = make #isRoot
120 val nonRootCounter = Counter.new 0
121 fun numberOfNonRoot () = Counter.value nonRootCounter
123 val memo = CType.memo (fn _ => Counter.new 0)
124 fun numberOfType t = Counter.value (memo t)
126 fun new {isRoot, ty} =
128 val isRoot = isRoot orelse not (Type.isObjptr ty)
131 then memo (Type.toCType ty)
133 val g = T {index = Counter.next counter,
140 fun equals (T {index = i, isRoot = r, ty},
141 T {index = i', isRoot = r', ty = ty'}) =
144 andalso Type.equals (ty, ty')
146 val isSubtype: t * t -> bool =
147 fn (T {index = i, isRoot = r, ty},
148 T {index = i', isRoot = r', ty = ty'}) =>
151 andalso Type.isSubtype (ty, ty')
152 andalso CType.equals (Type.toCType ty, Type.toCType ty')
155 structure StackOffset =
157 datatype t = T of {offset: Bytes.t,
161 fun make f (T r) = f r
166 fun layout (T {offset, ty}): Layout.t =
170 seq [str (concat ["S", Type.name ty]),
171 paren (Bytes.layout offset),
172 str ": ", Type.layout ty]
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')
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')
183 val interfere: t * t -> bool =
184 fn (T {offset = b, ty = ty}, T {offset = b', ty = ty'}) =>
186 val max = Bytes.+ (b, Type.bytes ty)
187 val max' = Bytes.+ (b', Type.bytes ty')
189 Bytes.> (max, b') andalso Bytes.> (max', b)
192 fun shift (T {offset, ty}, size): t =
193 T {offset = Bytes.- (offset, size),
200 ArrayOffset of {base: t,
206 | Contents of {oper: t,
213 | Offset of {base: t,
216 | Register of Register.t
218 | StackOffset of StackOffset.t
223 fn ArrayOffset {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
238 fun layout (z: t): Layout.t =
241 fun constrain (ty: Type.t): Layout.t =
242 if !Control.showTypes
243 then seq [str ": ", Type.layout ty]
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],
253 seq [str "Cast ", tuple [layout z, Type.layout ty]]
254 | Contents {oper, ty} =>
255 seq [str (concat ["C", Type.name ty, " "]),
257 | Frontier => str "<Frontier>"
258 | GCState => str "<GCState>"
259 | Global g => Global.layout g
260 | Label l => Label.layout l
262 | Offset {base, offset, ty} =>
263 seq [str (concat ["O", Type.name ty, " "]),
264 tuple [layout base, Bytes.layout offset],
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
273 val toString = Layout.toString o layout
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', ...}) =>
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')
295 val stackOffset = StackOffset o StackOffset.T
297 fun interfere (write: t, read: t): bool =
299 fun inter read = interfere (write, read)
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')
316 fn ArrayOffset _ => true
317 | Cast (z, _) => isLocation z
323 | StackOffset _ => true
327 structure Switch = Switch (open Atoms
328 structure Type = Type
329 structure Use = Operand)
331 structure Statement =
334 Move of {dst: Operand.t,
337 | PrimApp of {args: Operand.t vector,
338 dst: Operand.t option,
340 | ProfileLabel of ProfileLabel.t
346 fn Move {dst, src} =>
347 mayAlign [Operand.layout dst,
348 seq [str " = ", Operand.layout src]]
350 | PrimApp {args, dst, prim, ...} =>
353 seq [Prim.layout prim, str " ",
354 Vector.layout Operand.layout args]
359 mayAlign [Operand.layout z,
360 seq [str " = ", rest]]
363 seq [str "ProfileLabel ", ProfileLabel.layout l]
366 fun move (arg as {dst, src}) =
367 if Operand.equals (dst, src)
372 Trace.trace ("Machine.Statement.move",
374 Layout.record [("dst", Operand.layout dst),
375 ("src", Operand.layout src)],
379 fun moves {srcs, dsts} =
381 (Vector.fold2 (srcs, dsts, [], fn (src, dst, ac) =>
382 move {src = src, dst = dst} :: ac))
384 fun object {dst, header, size} =
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))
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 ())),
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),
404 prim = Prim.cpointerAdd})
407 fun foldOperands (s, ac, f) =
409 Move {dst, src} => f (dst, f (src, ac))
410 | PrimApp {args, dst, ...} =>
411 Vector.fold (args, Option.fold (dst, ac, f), f)
414 fun foldDefs (s, a, f) =
416 Move {dst, ...} => f (dst, a)
417 | PrimApp {dst, ...} => (case dst of
419 | SOME z => f (z, a))
423 structure FrameInfo =
425 datatype t = T of {frameLayoutsIndex: int}
427 fun layout (T {frameLayoutsIndex, ...}) =
428 Layout.record [("frameLayoutsIndex", Int.layout frameLayoutsIndex)]
430 fun equals (T {frameLayoutsIndex = i}, T {frameLayoutsIndex = i'}) =
438 | Register of Register.t
439 | StackOffset of StackOffset.t
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
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')
453 fn Global g => Global.ty g
454 | Register r => Register.ty r
455 | StackOffset s => StackOffset.ty s
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')
463 val interfere: t * t -> bool =
466 orelse (case (l, l') of
467 (StackOffset s, StackOffset s') =>
468 StackOffset.interfere (s, s')
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)
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
486 Arith of {args: Operand.t vector,
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,
497 return: {return: Label.t,
498 handler: Label.t option,
499 size: Bytes.t} option}
510 Arith {prim, args, dst, overflow, success, ...} =>
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} =>
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} =>
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),
532 Option.layout Label.layout handler),
533 ("size", Bytes.layout size)])
535 | Goto l => seq [str "Goto ", Label.layout l]
536 | Raise => str "Raise"
537 | Return => str "Return "
538 | Switch s => Switch.layout s
541 fun foldOperands (t, ac, f) =
543 Arith {args, dst, ...} => Vector.fold (args, f (dst, ac), f)
544 | CCall {args, ...} => Vector.fold (args, ac, f)
547 (s, ac, {label = fn (_, a) => a,
551 fun foldDefs (t, a, f) =
553 Arith {dst, ...} => f (dst, a)
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}
566 | Handler of {frameInfo: FrameInfo.t,
567 handles: Live.t vector}
575 Cont {args, frameInfo} =>
577 record [("args", Vector.layout Live.layout args),
578 ("frameInfo", FrameInfo.layout frameInfo)]]
579 | CReturn {dst, frameInfo, func} =>
582 [("dst", Option.layout Live.layout dst),
583 ("frameInfo", Option.layout FrameInfo.layout frameInfo),
584 ("func", CFunction.layout (func, Type.layout))]]
586 | Handler {frameInfo, handles} =>
588 record [("frameInfo", FrameInfo.layout frameInfo),
590 Vector.layout Live.layout handles)]]
595 fn Cont {frameInfo, ...} => SOME frameInfo
596 | CReturn {frameInfo, ...} => frameInfo
597 | Handler {frameInfo, ...} => SOME frameInfo
603 datatype t = T of {kind: Kind.t,
606 raises: Live.t vector option,
607 returns: Live.t vector option,
608 statements: Statement.t vector,
609 transfer: Transfer.t}
611 fun clear (T {label, ...}) = Label.clear label
614 fun make g (T r) = g r
616 val kind = make #kind
617 val label = make #label
620 fun layout (T {kind, label, live, raises, returns, statements, transfer}) =
624 align [seq [Label.layout label,
626 record [("kind", Kind.layout kind),
627 ("live", Vector.layout Live.layout live),
629 Option.layout (Vector.layout Live.layout)
632 Option.layout (Vector.layout Live.layout)
635 [align (Vector.toListMap
636 (statements, Statement.layout)),
637 Transfer.layout transfer],
641 fun layouts (block, output' : Layout.t -> unit) = output' (layout block)
643 fun foldDefs (T {kind, statements, transfer, ...}, a, f) =
647 Kind.CReturn {dst, ...} =>
650 | SOME z => f (Live.toOperand z, a))
653 Vector.fold (statements, a, fn (s, a) =>
654 Statement.foldDefs (s, a, f))
655 val a = Transfer.foldDefs (transfer, a, f)
663 datatype t = T of {blocks: Block.t vector,
664 chunkLabel: ChunkLabel.t,
665 regMax: CType.t -> int}
667 fun layouts (T {blocks, ...}, output : Layout.t -> unit) =
668 Vector.foreach (blocks, fn block => Block.layouts (block, output))
670 fun clear (T {blocks, ...}) =
671 Vector.foreach (blocks, Block.clear)
674 structure ProfileInfo =
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}
685 val empty = T {frameSources = Vector.new0 (),
686 labels = Vector.new0 (),
687 names = Vector.new0 (),
688 sourceSeqs = Vector.new0 (),
689 sources = Vector.new0 ()}
691 fun clear (T {labels, ...}) =
692 Vector.foreach (labels, ProfileLabel.clear o #label)
694 fun layout (T {frameSources, labels, names, sourceSeqs, sources}) =
696 [("frameSources", Vector.layout Int.layout frameSources),
698 Vector.layout (fn {label, sourceSeqsIndex} =>
700 [("label", ProfileLabel.layout label),
702 Int.layout sourceSeqsIndex)])
704 ("names", Vector.layout String.layout names),
705 ("sourceSeqs", Vector.layout (Vector.layout Int.layout) sourceSeqs),
707 Vector.layout (fn {nameIndex, successorsIndex} =>
708 Layout.record [("nameIndex", Int.layout nameIndex),
710 Int.layout successorsIndex)])
713 fun layouts (pi, output) = output (layout pi)
715 fun isOK (T {frameSources, labels, names, sourceSeqs, sources}): bool =
717 val namesLength = Vector.length names
718 val sourceSeqsLength = Vector.length sourceSeqs
719 val sourcesLength = Vector.length sources
721 !Control.profile = Control.ProfileNone
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
731 (v, fn i => 0 <= i andalso i < sourcesLength)))
732 andalso (Vector.forall
733 (sources, fn {nameIndex, successorsIndex} =>
735 andalso nameIndex < namesLength
736 andalso 0 <= successorsIndex
737 andalso successorsIndex < sourceSeqsLength)))
740 fun modify (T {frameSources, labels, names, sourceSeqs, sources})
741 : {newProfileLabel: ProfileLabel.t -> ProfileLabel.t,
742 delProfileLabel: ProfileLabel.t -> unit,
743 getProfileInfo: unit -> t} =
745 val {get: ProfileLabel.t -> int, set, ...} =
748 Property.initRaise ("ProfileInfo.extend", ProfileLabel.layout))
751 (labels, fn {label, sourceSeqsIndex} =>
752 set (label, sourceSeqsIndex))
754 fun newProfileLabel l =
757 val l' = ProfileLabel.new ()
759 val _ = List.push (new, {label = l', sourceSeqsIndex = i})
763 fun delProfileLabel l = set (l, ~1)
764 fun getProfileInfo () =
766 val labels = Vector.concat
767 [labels, Vector.fromList (!new)]
768 val labels = Vector.keepAll
769 (labels, fn {label, ...} =>
771 val pi = T {frameSources = frameSources,
772 labels = Vector.concat
773 [labels, Vector.fromList (!new)],
775 sourceSeqs = sourceSeqs,
778 Assert.assert ("Machine.getProfileInfo", fn () => isOK pi);
782 {newProfileLabel = newProfileLabel,
783 delProfileLabel = delProfileLabel,
784 getProfileInfo = getProfileInfo}
790 datatype t = T of {chunks: Chunk.t list,
791 frameLayouts: {frameOffsetsIndex: int,
793 size: Bytes.t} vector,
794 frameOffsets: Bytes.t vector vector,
795 handlesSignals: bool,
796 main: {chunkLabel: ChunkLabel.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}
804 fun clear (T {chunks, profileInfo, ...}) =
805 (List.foreach (chunks, Chunk.clear)
806 ; Option.app (profileInfo, ProfileInfo.clear))
808 fun frameSize (T {frameLayouts, ...},
809 FrameInfo.T {frameLayoutsIndex, ...}) =
810 #size (Vector.sub (frameLayouts, frameLayoutsIndex))
812 fun layouts (T {chunks, frameLayouts, frameOffsets, handlesSignals,
814 maxFrameSize, objectTypes, profileInfo, ...},
815 output': Layout.t -> unit) =
821 [("handlesSignals", Bool.layout handlesSignals),
822 ("main", Label.layout label),
823 ("maxFrameSize", Bytes.layout maxFrameSize),
825 Vector.layout (Vector.layout Bytes.layout) frameOffsets),
827 Vector.layout (fn {frameOffsetsIndex, isC, size} =>
828 record [("frameOffsetsIndex",
829 Int.layout frameOffsetsIndex),
830 ("isC", Bool.layout isC),
831 ("size", Bytes.layout size)])
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]))
841 ; List.foreach (chunks, fn chunk => Chunk.layouts (chunk, output))
846 datatype t = T of Live.t list
848 fun layout (T ds) = List.layout Live.layout ds
850 fun forall (T ds, f) = List.forall (ds, f o Live.toOperand)
852 fun defineLive (T ls, l) = T (l :: ls)
854 fun define (T ds, z) =
855 case Live.fromOperand z of
857 | SOME d => T (d :: ds)
859 val new: Live.t list -> t = T
861 fun doesDefine (T ls, l': Live.t): bool =
863 val oper' = Live.toOperand l'
865 case List.peek (ls, fn l =>
866 Operand.interfere (Live.toOperand l, oper')) of
868 | SOME l => Live.isSubtype (l, l')
873 ("Machine.Program.Alloc.doesDefine",
874 layout, Live.layout, Bool.layout)
878 fun typeCheck (program as
879 T {chunks, frameLayouts, frameOffsets,
880 maxFrameSize, objectTypes, profileInfo, reals,
884 if !Control.profile = Control.ProfileTimeLabel
887 (chunks, fn Chunk.T {blocks, ...} =>
889 (blocks, fn Block.T {kind, label, statements, ...} =>
893 orelse (0 < Vector.length statements
894 andalso (case Vector.first statements of
895 Statement.ProfileLabel _ => true
898 else print (concat ["missing profile info: ",
899 Label.toString label, "\n"])))
901 val profileLabelIsOk =
904 if !Control.profile = Control.ProfileNone
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)
914 "Machine.Program.typeCheck.profileLabelIsOk: profileInfo = SOME"
917 val {get = profileLabelCount, ...} =
920 Property.initFun (fn _ => ref 0))
923 (profileLabels, fn {label, ...} =>
925 val r = profileLabelCount label
930 "Machine.Program.typeCheck.profileLabelIsOk: duplicate profile label"
935 val r = profileLabelCount l
942 fun getFrameInfo (FrameInfo.T {frameLayoutsIndex, ...}) =
943 Vector.sub (frameLayouts, frameLayoutsIndex)
946 (frameLayouts, fn {frameOffsetsIndex, size, ...} =>
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)]))
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)
966 fun globals (name, gs, isOk, layout) =
973 (concat ["global ", name],
974 fn () => isOk (ty, s),
975 fn () => seq [layout s, str ": ", Type.layout ty])
978 globals ("real", reals,
979 fn (t, r) => Type.equals (t, Type.real (RealX.size r)),
982 globals ("vector", vectors,
984 Type.equals (t, Type.ofWordXVector v),
986 (* Check for no duplicate labels. *)
989 Property.get (Label.plist,
990 Property.initFun (fn _ => ref false))
994 (chunks, fn Chunk.T {blocks, ...} =>
996 (blocks, fn Block.T {label, ...} =>
1001 then Error.bug "Machine.Program.typeCheck: duplicate label"
1005 val {get = labelBlock: Label.t -> Block.t,
1006 set = setLabelBlock, ...} =
1007 Property.getSetOnce (Label.plist,
1008 Property.initRaise ("block", Label.layout))
1011 (chunks, fn Chunk.T {blocks, ...} =>
1013 (blocks, fn b as Block.T {label, ...} =>
1014 setLabelBlock (label, b)))
1015 fun checkOperand (x: Operand.t, alloc: Alloc.t): unit =
1017 datatype z = datatype Operand.t
1020 ArrayOffset {base, index, offset, scale, ty} =>
1021 (checkOperand (base, alloc)
1022 ; checkOperand (index, alloc)
1023 ; (Operand.isLocation base
1025 (Type.arrayOffsetIsOk {base = Operand.ty base,
1026 index = Operand.ty index,
1032 (checkOperand (z, alloc)
1034 {from = Operand.ty z,
1036 tyconTy = tyconTy}))
1037 | Contents {oper, ...} =>
1038 (checkOperand (oper, alloc)
1039 ; Type.isCPointer (Operand.ty oper))
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.
1049 (let val _ = labelBlock l
1051 end handle _ => false)
1053 | Offset {base, offset, ty} =>
1054 (checkOperand (base, alloc)
1055 ; (Operand.isLocation base
1058 Operand.GCState => true
1060 Type.offsetIsOk {base = Operand.ty base,
1065 | Register r => Alloc.doesDefine (alloc, Live.Register r)
1066 | StackOffset (so as StackOffset.T {offset, ty, ...}) =>
1067 Bytes.<= (Bytes.+ (offset, Type.bytes ty),
1069 andalso Alloc.doesDefine (alloc, Live.StackOffset so)
1070 andalso (case Type.deLabel ty of
1074 val Block.T {kind, ...} =
1084 Runtime.labelSize ()))
1088 Kind.Cont {frameInfo, ...} =>
1090 | Kind.CReturn {frameInfo, ...} =>
1093 | SOME fi => doit fi)
1095 | Kind.Handler {frameInfo, ...} =>
1102 Err.check ("operand", ok, fn () => Operand.layout x)
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 =
1111 datatype z = datatype Kind.t
1113 fun frame (FrameInfo.T {frameLayoutsIndex},
1117 val {frameOffsetsIndex, isC = isC', ...} =
1118 Vector.sub (frameLayouts, frameLayoutsIndex)
1119 handle Subscript => raise No
1126 val Alloc.T zs = alloc
1129 (zs, [], fn (z, liveOffsets) =>
1131 Live.StackOffset (StackOffset.T {offset, ty}) =>
1133 then offset :: liveOffsets
1136 val liveOffsets = Array.fromList liveOffsets
1137 val () = QuickSort.sortArray (liveOffsets, Bytes.<=)
1138 val liveOffsets = Vector.fromArray liveOffsets
1140 Vector.sub (frameOffsets, frameOffsetsIndex)
1141 handle Subscript => raise No
1143 Vector.equals (liveOffsets, liveOffsets',
1146 end handle No => false
1147 fun slotsAreInFrame (fi: FrameInfo.t): bool =
1149 val {size, ...} = getFrameInfo fi
1154 Operand.StackOffset (StackOffset.T {offset, ty}) =>
1155 Bytes.<= (Bytes.+ (offset, Type.bytes ty), size)
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)))
1167 | CReturn {dst, frameInfo, func, ...} =>
1173 Type.isSubtype (CFunction.return func,
1176 (if CFunction.mayGC func
1177 then (case frameInfo of
1180 (frame (fi, true, true)
1181 andalso slotsAreInFrame fi))
1182 else if !Control.profile = Control.ProfileNone
1184 else (case frameInfo of
1186 | SOME fi => frame (fi, false, true)))
1189 then SOME (case dst of
1191 | SOME z => Alloc.defineLive (alloc, z))
1194 | Func => SOME alloc
1195 | Handler {frameInfo, ...} =>
1196 if frame (frameInfo, false, false)
1199 | Jump => SOME alloc
1201 fun checkStatement (s: Statement.t, alloc: Alloc.t)
1204 datatype z = datatype Statement.t
1209 val _ = checkOperand (src, alloc)
1210 val alloc = Alloc.define (alloc, dst)
1211 val _ = checkOperand (dst, alloc)
1213 if Type.isSubtype (Operand.ty src, Operand.ty dst)
1214 andalso Operand.isLocation dst
1218 | Noop => SOME alloc
1219 | PrimApp {args, dst, prim, ...} =>
1221 val _ = checkOperands (args, alloc)
1227 val alloc = Alloc.define (alloc, z)
1228 val _ = checkOperand (z, alloc)
1234 {args = Vector.map (args, Operand.ty),
1236 result = Option.map (dst, Operand.ty)}
1243 if profileLabelIsOk l
1247 fun liveIsOk (live: Live.t vector,
1249 Vector.forall (live, fn z => Alloc.doesDefine (a, z))
1250 fun liveSubset (live: Live.t vector,
1251 live': Live.t vector): bool =
1253 (live, fn z => Vector.exists (live', fn z' =>
1254 Live.equals (z, z')))
1255 fun goto (Block.T {live,
1257 returns = returns', ...},
1258 raises: Live.t vector option,
1259 returns: Live.t vector option,
1260 alloc: Alloc.t): bool =
1261 liveIsOk (live, alloc)
1263 (case (raises, raises') of
1265 | (SOME gs, SOME gs') =>
1266 Vector.equals (gs', gs, Live.isSubtype)
1269 (case (returns, returns') of
1271 | (SOME os, SOME os') =>
1272 Vector.equals (os', os, Live.isSubtype)
1274 fun checkCont (cont: Label.t, size: Bytes.t, alloc: Alloc.t) =
1276 val Block.T {kind, live, ...} = labelBlock cont
1278 if Vector.forall (live, fn z => Alloc.doesDefine (alloc, z))
1281 Kind.Cont {args, frameInfo, ...} =>
1282 (if Bytes.equals (size,
1283 #size (getFrameInfo frameInfo))
1291 Live.StackOffset s =>
1293 (StackOffset.shift (s, size))
1299 fun callIsOk {alloc: Alloc.t,
1301 live: Live.t vector,
1302 raises: Live.t vector option,
1304 returns: Live.t vector option} =
1306 val {raises, returns, size} =
1312 | SOME {handler, return, size} =>
1314 val (contLive, returns) =
1317 fn () => checkCont (return, size, alloc),
1318 fn () => Label.layout return)
1319 fun checkHandler () =
1324 val Block.T {kind, live, ...} =
1327 if liveSubset (live, contLive)
1330 Kind.Handler {handles, ...} =>
1337 ("handler", checkHandler,
1338 fn () => Option.layout Label.layout handler)
1344 val b = labelBlock dst
1348 (live, [], fn (z, ac) =>
1350 Live.StackOffset (StackOffset.T {offset, ty}) =>
1351 if Bytes.< (offset, size)
1353 else (Live.StackOffset
1355 {offset = Bytes.- (offset, size),
1359 goto (b, raises, returns, alloc)
1363 raises: Live.t vector option,
1364 returns: Live.t vector option,
1365 alloc: Alloc.t): bool =
1367 fun jump (l: Label.t, a: Alloc.t) =
1369 val b as Block.T {kind, ...} = labelBlock l
1374 andalso goto (b, raises, returns, a)
1376 datatype z = datatype Transfer.t
1379 Arith {args, dst, overflow, prim, success, ...} =>
1381 val _ = checkOperands (args, alloc)
1382 val alloc = Alloc.define (alloc, dst)
1383 val _ = checkOperand (dst, alloc)
1385 Prim.mayOverflow prim
1386 andalso jump (overflow, alloc)
1387 andalso jump (success, alloc)
1390 {args = Vector.map (args, Operand.ty),
1392 result = SOME (Operand.ty dst)}
1394 | CCall {args, frameInfo = fi, func, return} =>
1396 val _ = checkOperands (args, alloc)
1398 CFunction.isOk (func, {isUnit = Type.isUnit})
1400 Vector.equals (args, CFunction.args func,
1402 Type.isSubtype (Operand.ty z, t))
1408 val Block.T {live, ...} = labelBlock l
1410 liveIsOk (live, alloc)
1414 {frameInfo = fi', func = f, ...} =>
1415 CFunction.equals (func, f)
1416 andalso (Option.equals
1417 (fi, fi', FrameInfo.equals))
1421 | Call {label, live, return} =>
1423 (live, fn z => Alloc.doesDefine (alloc, z))
1425 callIsOk {alloc = alloc,
1431 | Goto l => jump (l, alloc)
1437 (zs, fn z => Alloc.doesDefine (alloc, z)))
1443 (zs, fn z => Alloc.doesDefine (alloc, z)))
1446 (s, {checkUse = fn z => checkOperand (z, alloc),
1447 labelIsOk = fn l => jump (l, alloc)})
1451 ("Machine.Program.typeCheck.transferOk",
1453 Layout.tuple [Transfer.layout t, Alloc.layout a],
1456 fun blockOk (Block.T {kind, live, raises, returns, statements,
1457 transfer, ...}): bool =
1459 val live = Vector.toList live
1471 not (Live.interfere (z, z')))
1475 fn () => List.layout Live.layout live)
1476 val alloc = Alloc.new live
1480 fn () => checkKind (kind, alloc),
1481 fn () => Kind.layout kind)
1484 (statements, alloc, fn (s, alloc) =>
1487 fn () => checkStatement (s, alloc),
1488 fn () => Statement.layout s))
1492 fn () => transferOk (transfer, raises, returns, alloc),
1493 fn () => Transfer.layout transfer)
1500 fn Chunk.T {blocks, ...} =>
1505 check' (b, "block", blockOk, Block.layout))
1507 val _ = clear program
1510 end handle Err.E e => (Layout.outputl (Err.layout e, Out.error)
1511 ; Error.bug "Machine.typeCheck")
1513 fun clearLabelNames (T {chunks, ...}): unit =
1515 (chunks, fn Chunk.T {blocks, ...} =>
1517 (blocks, fn Block.T {label, ...} =>
1518 Label.clearPrintName label))