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 / limit-check.fun
CommitLineData
7f918cf1
CE		 1(* Copyright (C) 2009 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
10(*
11 * The goal of limit check insertion is to ensure that
12 * 1. At any allocation of b bytes, frontier + b <= base + heapSize
13 * 2. At entry to each function, stackTop <= stackLimit
14 *
15 * It assumes that runtime provides several operands to help with this.
16 * Frontier
17 * Limit
18 * LimitPlusSlop
19 * StackLimit
20 * StackTop
21 *
22 * There are three different kinds of checks inserted, depending on the
23 * amount being allocated and whether or not the program uses signal
24 * handlers.
25 *
26 * 1. If b <= LIMIT_SLOP, then continue (don't GC) if
27 *
28 * frontier <= limit
29 *
30 * The reason this works is that if frontier <= limit and b <=
31 * LIMIT_SLOP, then
32 * frontier + b <= limit + LIMIT_SLOP
33 * = limitPlusSlop
34 * = base + heapSize
35 * This works even if the program uses signal handlers, which set
36 * limit to zero, since frontier <= 0 will always be false.
37 *
38 * 2. If b > LIMIT_SLOP and if the program doesn't use signal handlers,
39 * then continue (don't GC) if
40 *
41 * b <= limitPlusSlop - frontier
42 *
43 * The reason this works is that the condition is equivalent to
44 *
45 * b + frontier <= limitPlusSlop = base + heapSize
46 *
47 * We write the condition the way we do instead of the more obvious way
48 * because "b + frontier" may overflow, while limitPlusSlop - frontier
49 * can not, unless the program uses signal handlers.
50 *
51 * 3. If b > LIMIT_SLOP and if the program uses signal handlers, then
52 * continue (don't GC) if
53 *
54 * limit > 0
55 * and b <= limitPlusSlop - frontier
56 *
57 * This is like case (2), except that because the program uses signal
58 * handlers, the runtime may have set limit to zero to indicate that a
59 * signal needs to be handled. So, we first check that this is not
60 * the case before continuing as in case (2).
61 *
62 * Stack limit checks are completely orthogonal to heap checks, and are simply
63 * inserted at the start of each function.
64 *)
65functor LimitCheck (S: RSSA_TRANSFORM_STRUCTS): RSSA_TRANSFORM =
66struct
67
68open S
69open Rssa
70
71structure LimitCheck =
72 struct
73 datatype t =
74 PerBlock
75 | ExtBasicBlocks
76 | LoopHeaders of {fullCFG: bool,
77 loopExits: bool}
78 end
79
80structure Control =
81 struct
82 open Control
83
84 datatype limitCheck = datatype LimitCheck.t
85
86 val limitCheck =
87 ref (LoopHeaders {fullCFG = false,
88 loopExits = true})
89 end
90
91datatype z = datatype Transfer.t
92
93structure CFunction =
94 struct
95 open CFunction Type.BuiltInCFunction
96 end
97
98structure Statement =
99 struct
100 open Statement
101
102 fun bytesAllocated (s: t): Bytes.t =
103 case s of
104 Object {size, ...} => size
105 | _ => Bytes.zero
106 end
107
108structure Transfer =
109 struct
110 open Transfer
111
112 datatype bytesAllocated =
113 Big of Operand.t
114 | Small of Bytes.t
115
116 fun bytesAllocated (t: t): bytesAllocated =
117 case t of
118 CCall {args, func, ...} =>
119 (case CFunction.bytesNeeded func of
120 NONE => Small Bytes.zero
121 | SOME i =>
122 let
123 val z = Vector.sub (args, i)
124 in
125 case z of
126 Operand.Const c =>
127 (case c of
128 Const.Word w =>
129 let
130 val w = WordX.toIntInf w
131 in
132 (* 512 is small and arbitrary *)
133 if w <= 512
134 then Small (Bytes.fromIntInf w)
135 else Big z
136 end
137 | _ => Error.bug "LimitCheck.Transfer.bytesAllocated: strange numBytes")
138 | _ => Big z
139 end)
140 | _ => Small Bytes.zero
141 end
142
143structure Block =
144 struct
145 open Block
146
147 fun objectBytesAllocated (T {statements, transfer, ...}): Bytes.t =
148 Bytes.+
149 (Vector.fold (statements, Bytes.zero, fn (s, ac) =>
150 Bytes.+ (ac, Statement.bytesAllocated s)),
151 case Transfer.bytesAllocated transfer of
152 Transfer.Big _ => Bytes.zero
153 | Transfer.Small b => b)
154 end
155
156val extraGlobals: Var.t list ref = ref []
157
158fun insertFunction (f: Function.t,
159 handlesSignals: bool,
160 blockCheckAmount: {blockIndex: int} -> Bytes.t,
161 ensureFree: Label.t -> Bytes.t) =
162 let
163 val {args, blocks, name, raises, returns, start} = Function.dest f
164 val lessThan = Prim.wordLt (WordSize.csize (), {signed = false})
165 val newBlocks = ref []
166 local
167 val r: Label.t option ref = ref NONE
168 in
169 fun heapCheckTooLarge () =
170 case !r of
171 SOME l => l
172 | NONE =>
173 let
174 val l = Label.newNoname ()
175 val _ = r := SOME l
176 val cfunc =
177 CFunction.T {args = Vector.new0 (),
178 convention = CFunction.Convention.Cdecl,
179 kind = CFunction.Kind.Runtime {bytesNeeded = NONE,
180 ensuresBytesFree = false,
181 mayGC = false,
182 maySwitchThreads = false,
183 modifiesFrontier = false,
184 readsStackTop = false,
185 writesStackTop = false},
186 prototype = (Vector.new0 (), NONE),
187 return = Type.unit,
188 symbolScope = CFunction.SymbolScope.Private,
189 target = CFunction.Target.Direct "MLton_heapCheckTooLarge"}
190 val _ =
191 newBlocks :=
192 Block.T {args = Vector.new0 (),
193 kind = Kind.Jump,
194 label = l,
195 statements = Vector.new0 (),
196 transfer =
197 Transfer.CCall {args = Vector.new0 (),
198 func = cfunc,
199 return = NONE}}
200 :: !newBlocks
201 in
202 l
203 end
204 end
205 val _ =
206 Vector.foreachi
207 (blocks, fn (i, Block.T {args, kind, label, statements, transfer}) =>
208 let
209 val transfer =
210 case transfer of
211 Transfer.CCall {args, func, return} =>
212 (if CFunction.ensuresBytesFree func
213 then
214 Transfer.CCall
215 {args = (Vector.map
216 (args, fn z =>
217 case z of
218 Operand.EnsuresBytesFree =>
219 Operand.word
220 (WordX.fromIntInf
221 (Bytes.toIntInf
222 (ensureFree (valOf return)),
223 WordSize.csize ()))
224 | _ => z)),
225 func = func,
226 return = return}
227 else transfer)
228 | _ => transfer
229 val stack = Label.equals (start, label)
230 fun insert (amount: Operand.t (* of type word *)) =
231 let
232 val collect = Label.newNoname ()
233 val collectReturn = Label.newNoname ()
234 val dontCollect = Label.newNoname ()
235 val (dontCollect', collectReturnStatements, force) =
236 case !Control.gcCheck of
237 Control.First =>
238 let
239 val global = Var.newNoname ()
240 val _ = List.push (extraGlobals, global)
241 val global =
242 Operand.Var {var = global,
243 ty = Type.bool}
244 val dontCollect' = Label.newNoname ()
245 val _ =
246 List.push
247 (newBlocks,
248 Block.T
249 {args = Vector.new0 (),
250 kind = Kind.Jump,
251 label = dontCollect',
252 statements = Vector.new0 (),
253 transfer =
254 Transfer.ifBool
255 (global, {falsee = dontCollect,
256 truee = collect})})
257 in
258 (dontCollect',
259 Vector.new1
260 (Statement.Move {dst = global,
261 src = Operand.bool false}),
262 global)
263 end
264 | Control.Limit =>
265 (dontCollect, Vector.new0 (), Operand.bool false)
266 | Control.Every =>
267 (collect, Vector.new0 (), Operand.bool true)
268 val func = CFunction.gc {maySwitchThreads = handlesSignals}
269 val _ =
270 newBlocks :=
271 Block.T {args = Vector.new0 (),
272 kind = Kind.Jump,
273 label = collect,
274 statements = Vector.new0 (),
275 transfer = (Transfer.CCall
276 {args = Vector.new3 (Operand.GCState,
277 amount,
278 force),
279 func = func,
280 return = SOME collectReturn})}
281 :: (Block.T
282 {args = Vector.new0 (),
283 kind = Kind.CReturn {func = func},
284 label = collectReturn,
285 statements = collectReturnStatements,
286 transfer = Transfer.Goto {dst = dontCollect,
287 args = Vector.new0 ()}})
288 :: Block.T {args = Vector.new0 (),
289 kind = Kind.Jump,
290 label = dontCollect,
291 statements = statements,
292 transfer = transfer}
293 :: !newBlocks
294 in
295 {collect = collect,
296 dontCollect = dontCollect'}
297 end
298 fun newBlock (isFirst, statements, transfer) =
299 let
300 val (args, kind, label) =
301 if isFirst
302 then (args, kind, label)
303 else (Vector.new0 (), Kind.Jump, Label.newNoname ())
304 val _ =
305 List.push
306 (newBlocks,
307 Block.T {args = args,
308 kind = kind,
309 label = label,
310 statements = statements,
311 transfer = transfer})
312 in
313 label
314 end
315 fun gotoHeapCheckTooLarge () =
316 newBlock
317 (true,
318 Vector.new0 (),
319 Transfer.Goto {args = Vector.new0 (),
320 dst = heapCheckTooLarge ()})
321 fun primApp (prim, op1, op2, {collect, dontCollect}) =
322 let
323 val res = Var.newNoname ()
324 val s =
325 Statement.PrimApp {args = Vector.new2 (op1, op2),
326 dst = SOME (res, Type.bool),
327 prim = prim}
328 val transfer =
329 Transfer.ifBool
330 (Operand.Var {var = res, ty = Type.bool},
331 {falsee = dontCollect,
332 truee = collect})
333 in
334 (Vector.new1 s, transfer)
335 end
336 datatype z = datatype Runtime.GCField.t
337 fun stackCheck (maybeFirst, z): Label.t =
338 let
339 val (statements, transfer) =
340 primApp (Prim.cpointerLt,
341 Operand.Runtime StackLimit,
342 Operand.Runtime StackTop,
343 z)
344 in
345 newBlock (maybeFirst, statements, transfer)
346 end
347 fun maybeStack (): unit =
348 if stack
349 then ignore (stackCheck
350 (true,
351 insert (Operand.word
352 (WordX.zero (WordSize.csize ())))))
353 else
354 (* No limit check, just keep the block around. *)
355 List.push (newBlocks,
356 Block.T {args = args,
357 kind = kind,
358 label = label,
359 statements = statements,
360 transfer = transfer})
361 fun frontierCheck (isFirst,
362 prim, op1, op2,
363 z as {collect, dontCollect = _}): Label.t =
364 let
365 val (statements, transfer) = primApp (prim, op1, op2, z)
366 val l = newBlock (isFirst andalso not stack,
367 statements, transfer)
368 in
369 if stack
370 then stackCheck (isFirst, {collect = collect,
371 dontCollect = l})
372 else l
373 end
374 fun heapCheck (isFirst: bool,
375 amount: Operand.t (* of type word *)): Label.t =
376 let
377 val z as {collect, ...} = insert amount
378 val res = Var.newNoname ()
379 val s =
380 (* Can't do Limit - Frontier, because don't know that
381 * Frontier < Limit.
382 *)
383 Statement.PrimApp
384 {args = Vector.new2 (Operand.Runtime LimitPlusSlop,
385 Operand.Runtime Frontier),
386 dst = SOME (res, Type.csize ()),
387 prim = Prim.cpointerDiff}
388 val (statements, transfer) =
389 primApp (lessThan,
390 Operand.Var {var = res, ty = Type.csize ()},
391 amount,
392 z)
393 val statements = Vector.concat [Vector.new1 s, statements]
394 in
395 if handlesSignals
396 then
397 frontierCheck (isFirst,
398 Prim.cpointerEqual,
399 Operand.Runtime Limit,
400 Operand.null,
401 {collect = collect,
402 dontCollect = newBlock (false,
403 statements,
404 transfer)})
405 else if stack
406 then
407 stackCheck
408 (isFirst,
409 {collect = collect,
410 dontCollect =
411 newBlock (false, statements, transfer)})
412 else newBlock (isFirst, statements, transfer)
413 end
414 fun heapCheckNonZero (bytes: Bytes.t): unit =
415 ignore
416 (if Bytes.<= (bytes, Runtime.limitSlop)
417 then frontierCheck (true,
418 Prim.cpointerLt,
419 Operand.Runtime Limit,
420 Operand.Runtime Frontier,
421 insert (Operand.word
422 (WordX.zero (WordSize.csize ()))))
423 else
424 let
425 val bytes =
426 let
427 val bytes =
428 WordX.fromIntInf
429 (Bytes.toIntInf bytes,
430 WordSize.csize ())
431 in
432 SOME bytes
433 end handle Overflow => NONE
434 in
435 case bytes of
436 NONE => gotoHeapCheckTooLarge ()
437 | SOME bytes => heapCheck (true, Operand.word bytes)
438 end)
439 fun smallAllocation (): unit =
440 let
441 val b = blockCheckAmount {blockIndex = i}
442 in
443 if Bytes.isZero b
444 then maybeStack ()
445 else heapCheckNonZero b
446 end
447 fun bigAllocation (bytesNeeded: Operand.t): unit =
448 let
449 val extraBytes = blockCheckAmount {blockIndex = i}
450 in
451 case bytesNeeded of
452 Operand.Const c =>
453 (case c of
454 Const.Word w =>
455 heapCheckNonZero
456 (Bytes.+
457 (Bytes.fromIntInf (WordX.toIntInf w),
458 extraBytes))
459 | _ => Error.bug "LimitCheck.bigAllocation: strange constant bytesNeeded")
460 | _ =>
461 let
462 val bytes = Var.newNoname ()
463 val extraBytes =
464 let
465 val extraBytes =
466 WordX.fromIntInf
467 (Bytes.toIntInf extraBytes,
468 WordSize.csize ())
469 in
470 SOME extraBytes
471 end handle Overflow => NONE
472 in
473 case extraBytes of
474 NONE => ignore (gotoHeapCheckTooLarge ())
475 | SOME extraBytes =>
476 (ignore o newBlock)
477 (true,
478 Vector.new0 (),
479 Transfer.Arith
480 {args = Vector.new2 (Operand.word extraBytes,
481 bytesNeeded),
482 dst = bytes,
483 overflow = heapCheckTooLarge (),
484 prim = Prim.wordAddCheck (WordSize.csize (),
485 {signed = false}),
486 success = (heapCheck
487 (false,
488 Operand.Var
489 {var = bytes,
490 ty = Type.csize ()})),
491 ty = Type.csize ()})
492 end
493 end
494 in
495 case Transfer.bytesAllocated transfer of
496 Transfer.Big z => bigAllocation z
497 | Transfer.Small _ => smallAllocation ()
498 end)
499 in
500 Function.new {args = args,
501 blocks = Vector.fromList (!newBlocks),
502 name = name,
503 raises = raises,
504 returns = returns,
505 start = start}
506 end
507
508fun insertPerBlock (f: Function.t, handlesSignals) =
509 let
510 val {blocks, ...} = Function.dest f
511 fun blockCheckAmount {blockIndex} =
512 Block.objectBytesAllocated (Vector.sub (blocks, blockIndex))
513 in
514 insertFunction (f, handlesSignals, blockCheckAmount, fn _ => Bytes.zero)
515 end
516
517structure Graph = DirectedGraph
518structure Node = Graph.Node
519structure Edge = Graph.Edge
520structure Forest = Graph.LoopForest
521
522val traceMaxPath = Trace.trace ("LimitCheck.maxPath", Int.layout, Bytes.layout)
523
524fun isolateBigTransfers (f: Function.t): Function.t =
525 let
526 val {args, blocks, name, raises, returns, start} = Function.dest f
527 val newBlocks = ref []
528 val () =
529 Vector.foreach
530 (blocks,
531 fn block as Block.T {args, kind, label, statements, transfer} =>
532 case Transfer.bytesAllocated transfer of
533 Transfer.Big _ =>
534 let
535 val l = Label.newNoname ()
536 in
537 List.push (newBlocks,
538 Block.T {args = args,
539 kind = kind,
540 label = label,
541 statements = statements,
542 transfer = Goto {args = Vector.new0 (),
543 dst = l}})
544 ; List.push (newBlocks,
545 Block.T {args = Vector.new0 (),
546 kind = Kind.Jump,
547 label = l,
548 statements = Vector.new0 (),
549 transfer = transfer})
550 end
551 | Transfer.Small _ => List.push (newBlocks, block))
552 val blocks = Vector.fromListRev (!newBlocks)
553 in
554 Function.new {args = args,
555 blocks = blocks,
556 name = name,
557 raises = raises,
558 returns = returns,
559 start = start}
560 end
561
562fun insertCoalesce (f: Function.t, handlesSignals) =
563 let
564 val f = isolateBigTransfers f
565 val {blocks, start, ...} = Function.dest f
566 val n = Vector.length blocks
567 val {get = labelIndex, set = setLabelIndex, ...} =
568 Property.getSetOnce
569 (Label.plist,
570 Property.initRaise ("LimitCheck.labelIndex", Label.layout))
571 val {get = nodeIndex, set = setNodeIndex, ...} =
572 Property.getSetOnce
573 (Node.plist, Property.initRaise ("LimitCheck.nodeIndex", Node.layout))
574 val _ =
575 Vector.foreachi
576 (blocks, fn (i, Block.T {label, ...}) =>
577 setLabelIndex (label, i))
578 (* Build the graph. *)
579 val g = Graph.new ()
580 val nodes =
581 Vector.tabulate
582 (n, fn i =>
583 let
584 val n = Graph.newNode g
585 val _ = setNodeIndex (n, i)
586 in
587 n
588 end)
589 fun indexNode i = Vector.sub (nodes, i)
590 val labelNode = indexNode o labelIndex
591 val root = Graph.newNode g
592 (* mayHaveCheck == E U D
593 * E = set of entry nodes
594 * = start, Cont, Handler,
595 * or CReturn that doesn't ensure bytesFree
596 * Jump that calls a cfunction with bytesneeded
597 * D = set of decycling nodes
598 *)
599 val mayHaveCheck =
600 Array.tabulate
601 (n, fn i =>
602 let
603 val Block.T {kind, transfer, ...} = Vector.sub (blocks, i)
604 datatype z = datatype Kind.t
605 val isBigAlloc =
606 case Transfer.bytesAllocated transfer of
607 Transfer.Big _ => true
608 | Transfer.Small _ => false
609 val b =
610 case kind of
611 Cont _ => true
612 | CReturn {func, ...} =>
613 CFunction.mayGC func
614 andalso not (CFunction.ensuresBytesFree func)
615 | Handler => true
616 | Jump =>
617 (case transfer of
618 Transfer.CCall {args, func, ...} =>
619 (case CFunction.bytesNeeded func of
620 NONE => true
621 | SOME i =>
622 (case Vector.sub (args, i) of
623 Operand.Const _ => false
624 | _ => true))
625 | _ => false)
626 in
627 b orelse isBigAlloc
628 end)
629 val _ = Array.update (mayHaveCheck, labelIndex start, true)
630 (* Build cfg. *)
631 val _ = Graph.addEdge (g, {from = root, to = labelNode start})
632 datatype z = datatype Control.limitCheck
633 val fullCFG =
634 case !Control.limitCheck of
635 ExtBasicBlocks => true
636 | LoopHeaders {fullCFG, ...} => fullCFG
637 | _ => Error.bug "LimitCheck.insertCoalesce: fullCFG"
638 val _ =
639 Vector.foreachi
640 (blocks, fn (i, Block.T {transfer, ...}) =>
641 let
642 val from = indexNode i
643 in
644 Transfer.foreachLabel
645 (transfer, fn l =>
646 let
647 val i' = labelIndex l
648 val to = indexNode i'
649 fun addEdge from =
650 (ignore o Graph.addEdge)
651 (g, {from = from, to = to})
652 in
653 if fullCFG
654 then addEdge from
655 else if Array.sub (mayHaveCheck, i')
656 then addEdge root
657 else addEdge from
658 end)
659 end)
660 val objectBytesAllocated = Vector.map (blocks, Block.objectBytesAllocated)
661 fun insertCoalesceExtBasicBlocks () =
662 let
663 val preds = Array.new (n, 0)
664 fun incPred i =
665 Array.update (preds, i, 1 + (Array.sub (preds, i)))
666 val _ =
667 Vector.foreach
668 (nodes, fn node =>
669 List.foreach
670 (Node.successors node,
671 incPred o nodeIndex o Edge.to))
672 val _ =
673 Array.foreachi
674 (preds, fn (i, n) =>
675 if n > 1 then Array.update (mayHaveCheck, i, true) else ())
676 in
677 ()
678 end
679 fun insertCoalesceLoopHeaders loopExits =
680 let
681 (* Set equivalence classes, where two nodes are equivalent if they
682 * are in the same loop in the loop forest.
683 * Also mark loop headers as mayHaveCheck.
684 *)
685 val classes = Array.array (n, ~1)
686 fun indexClass i = Array.sub (classes, i)
687 val c = Counter.new 0
688 fun setClass (f: unit Forest.t) =
689 let
690 val {loops, notInLoop} = Forest.dest f
691 val class = Counter.next c
692 val _ =
693 Vector.foreach
694 (notInLoop, fn n =>
695 if Node.equals (n, root)
696 then ()
697 else Array.update (classes, nodeIndex n, class))
698 val _ =
699 Vector.foreach
700 (loops, fn {headers, child} =>
701 (Vector.foreach
702 (headers, fn n =>
703 Array.update (mayHaveCheck, nodeIndex n, true))
704 ; setClass child))
705 in
706 ()
707 end
708 val _ = setClass (Graph.loopForestSteensgaard (g, {root = root}))
709 val numClasses = Counter.value c
710 datatype z = datatype Control.limitCheck
711 val _ =
712 if loopExits
713 then let
714 (* Determine which classes allocate. *)
715 val classDoesAllocate =
716 Array.array (numClasses, false)
717 val _ =
718 List.foreach
719 (Graph.nodes g, fn n =>
720 if Node.equals (n, root)
721 then ()
722 else
723 let
724 val i = nodeIndex n
725 in
726 if (Bytes.<
727 (Bytes.zero,
728 Vector.sub (objectBytesAllocated, i)))
729 then Array.update (classDoesAllocate,
730 indexClass i,
731 true)
732 else ()
733 end)
734 (* Mark nodes that are post-exits of non-allocating
735 * loops as mayHaveCheck.
736 *)
737 val _ =
738 List.foreach
739 (Graph.nodes g, fn n =>
740 if Node.equals (n, root)
741 then ()
742 else
743 let
744 val i = nodeIndex n
745 val c = indexClass i
746 in
747 if Array.sub (classDoesAllocate, c)
748 then ()
749 else List.foreach
750 (Node.successors n, fn e =>
751 let
752 val i' = nodeIndex (Edge.to e)
753 in
754 if c <> indexClass i'
755 then Array.update
756 (mayHaveCheck, i', true)
757 else ()
758 end)
759 end)
760 in
761 ()
762 end
763 else ()
764 in
765 ()
766 end
767 datatype z = datatype Control.limitCheck
768 val _ =
769 case !Control.limitCheck of
770 ExtBasicBlocks => insertCoalesceExtBasicBlocks ()
771 | LoopHeaders {loopExits, ...} => insertCoalesceLoopHeaders loopExits
772 | _ => Error.bug "LimitCheck.insertCoalesce"
773 (* If we remove edges into nodes that are mayHaveCheck, we have an
774 * acyclic graph.
775 * So, we can compute a function, maxPath, inductively that for each node
776 * tells the maximum amount allocated along any path that passes only
777 * through nodes that are not mayHaveCheck.
778 *)
779 local
780 val a = Array.array (n, NONE)
781 in
782 fun maxPath arg : Bytes.t = (* i is a node index *)
783 traceMaxPath
784 (fn (i: int) =>
785 case Array.sub (a, i) of
786 SOME x => x
787 | NONE =>
788 let
789 val x = Vector.sub (objectBytesAllocated, i)
790 val max =
791 List.fold
792 (Node.successors (indexNode i), Bytes.zero,
793 fn (e, max) =>
794 let
795 val i' = nodeIndex (Edge.to e)
796 in
797 if Array.sub (mayHaveCheck, i')
798 then max
799 else Bytes.max (max, maxPath i')
800 end)
801 val x = Bytes.+ (x, max)
802 val _ = Array.update (a, i, SOME x)
803 in
804 x
805 end
806 ) arg
807 end
808 fun blockCheckAmount {blockIndex} =
809 if Array.sub (mayHaveCheck, blockIndex)
810 then maxPath blockIndex
811 else Bytes.zero
812 val f = insertFunction (f, handlesSignals, blockCheckAmount,
813 maxPath o labelIndex)
814 val _ =
815 Control.diagnostics
816 (fn display =>
817 Vector.foreach
818 (blocks, fn Block.T {label, ...} =>
819 display (let open Layout
820 in seq [Label.layout label, str " ",
821 Bytes.layout (maxPath (labelIndex label))]
822 end)))
823 val _ = Function.clear f
824 in
825 f
826 end
827
828fun transform (Program.T {functions, handlesSignals, main, objectTypes}) =
829 let
830 val _ = Control.diagnostic (fn () => Layout.str "Limit Check maxPaths")
831 datatype z = datatype Control.limitCheck
832 fun insert f =
833 case !Control.limitCheck of
834 PerBlock => insertPerBlock (f, handlesSignals)
835 | _ => insertCoalesce (f, handlesSignals)
836 val functions = List.revMap (functions, insert)
837 val {args, blocks, name, raises, returns, start} =
838 Function.dest (insert main)
839 val newStart = Label.newNoname ()
840 val block =
841 Block.T {args = Vector.new0 (),
842 kind = Kind.Jump,
843 label = newStart,
844 statements = (Vector.fromListMap
845 (!extraGlobals, fn x =>
846 Statement.Bind
847 {dst = (x, Type.bool),
848 isMutable = true,
849 src = Operand.cast (Operand.bool true,
850 Type.bool)})),
851 transfer = Transfer.Goto {args = Vector.new0 (),
852 dst = start}}
853 val blocks = Vector.concat [Vector.new1 block, blocks]
854 val main = Function.new {args = args,
855 blocks = blocks,
856 name = name,
857 raises = raises,
858 returns = returns,
859 start = newStart}
860 in
861 Program.T {functions = functions,
862 handlesSignals = handlesSignals,
863 main = main,
864 objectTypes = objectTypes}
865 end
866
867end
mlton packaging