Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | functor ImplementProfiling (S: IMPLEMENT_PROFILING_STRUCTS): IMPLEMENT_PROFILING = | |
9 | struct | |
10 | ||
11 | open S | |
12 | open Rssa | |
13 | ||
14 | structure CFunction = | |
15 | struct | |
16 | open CFunction | |
17 | ||
18 | structure CType = | |
19 | struct | |
20 | open CType | |
21 | val gcState = cpointer | |
22 | end | |
23 | ||
24 | local | |
25 | fun make {args, name, prototype} = | |
26 | T {args = args, | |
27 | convention = Convention.Cdecl, | |
28 | kind = Kind.Runtime {bytesNeeded = NONE, | |
29 | ensuresBytesFree = false, | |
30 | mayGC = false, | |
31 | maySwitchThreads = false, | |
32 | modifiesFrontier = false, | |
33 | readsStackTop = true, | |
34 | writesStackTop = false}, | |
35 | prototype = (prototype, NONE), | |
36 | return = Type.unit, | |
37 | symbolScope = SymbolScope.Private, | |
38 | target = Target.Direct name} | |
39 | in | |
40 | val profileEnter = fn () => | |
41 | make {args = Vector.new1 (Type.gcState ()), | |
42 | name = "GC_profileEnter", | |
43 | prototype = Vector.new1 CType.gcState} | |
44 | val profileInc = fn () => | |
45 | make {args = Vector.new2 (Type.gcState (), Type.csize ()), | |
46 | name = "GC_profileInc", | |
47 | prototype = Vector.new2 (CType.gcState, CType.csize ())} | |
48 | val profileLeave = fn () => | |
49 | make {args = Vector.new1 (Type.gcState ()), | |
50 | name = "GC_profileLeave", | |
51 | prototype = Vector.new1 CType.gcState} | |
52 | end | |
53 | end | |
54 | ||
55 | type sourceSeq = int list | |
56 | ||
57 | structure InfoNode = | |
58 | struct | |
59 | datatype t = T of {info: SourceInfo.t, | |
60 | nameIndex: int, | |
61 | sourcesIndex: int, | |
62 | successors: t list ref} | |
63 | ||
64 | local | |
65 | fun make f (T r) = f r | |
66 | in | |
67 | val info = make #info | |
68 | val sourcesIndex = make #sourcesIndex | |
69 | end | |
70 | ||
71 | fun layout (T {info, ...}) = | |
72 | Layout.record [("info", SourceInfo.layout info)] | |
73 | ||
74 | fun equals (n: t, n': t): bool = SourceInfo.equals (info n, info n') | |
75 | ||
76 | fun call {from = T {successors, ...}, | |
77 | to as T {info = i', ...}} = | |
78 | if let | |
79 | open SourceInfo | |
80 | in | |
81 | equals (i', gc) | |
82 | orelse equals (i', main) | |
83 | orelse equals (i', unknown) | |
84 | end orelse List.exists (!successors, fn n => equals (n, to)) | |
85 | then () | |
86 | else List.push (successors, to) | |
87 | ||
88 | val call = | |
89 | Trace.trace ("Profile.InfoNode.call", | |
90 | fn {from, to} => | |
91 | Layout.record [("from", layout from), | |
92 | ("to", layout to)], | |
93 | Unit.layout) | |
94 | call | |
95 | end | |
96 | ||
97 | structure FuncInfo = | |
98 | struct | |
99 | datatype t = T of {callers: InfoNode.t list ref, | |
100 | enters: InfoNode.t list ref, | |
101 | seen: bool ref, | |
102 | tailCalls: t list ref} | |
103 | ||
104 | fun new () = T {callers = ref [], | |
105 | enters = ref [], | |
106 | seen = ref false, | |
107 | tailCalls = ref []} | |
108 | end | |
109 | ||
110 | structure Push = | |
111 | struct | |
112 | datatype t = | |
113 | Enter of InfoNode.t | |
114 | | Skip of SourceInfo.t | |
115 | ||
116 | fun layout z = | |
117 | let | |
118 | open Layout | |
119 | in | |
120 | case z of | |
121 | Enter n => seq [str "Enter ", InfoNode.layout n] | |
122 | | Skip i => seq [str "Skip ", SourceInfo.layout i] | |
123 | end | |
124 | ||
125 | fun toSources (ps: t list): int list = | |
126 | List.fold (rev ps, [], fn (p, ac) => | |
127 | case p of | |
128 | Enter (InfoNode.T {sourcesIndex, ...}) => | |
129 | sourcesIndex :: ac | |
130 | | Skip _ => ac) | |
131 | end | |
132 | ||
133 | val traceEnter = | |
134 | Trace.trace2 ("Profile.enter", | |
135 | List.layout Push.layout, | |
136 | SourceInfo.layout, | |
137 | Layout.tuple2 (List.layout Push.layout, Bool.layout)) | |
138 | ||
139 | fun doit program = | |
140 | if !Control.profile = Control.ProfileNone | |
141 | then (program, fn _ => NONE) | |
142 | else | |
143 | let | |
144 | val Program.T {functions, handlesSignals, main, objectTypes} = program | |
145 | val debug = false | |
146 | datatype z = datatype Control.profile | |
147 | val profile = !Control.profile | |
148 | val profileStack: bool = !Control.profileStack | |
149 | val needProfileLabels: bool = | |
150 | profile = ProfileTimeLabel orelse profile = ProfileLabel | |
151 | val needCodeCoverage: bool = | |
152 | needProfileLabels orelse (profile = ProfileTimeField) | |
153 | val frameProfileIndices: (Label.t * int) list ref = ref [] | |
154 | val infoNodes: InfoNode.t list ref = ref [] | |
155 | val nameCounter = Counter.new 0 | |
156 | val names: string list ref = ref [] | |
157 | local | |
158 | val sourceCounter = Counter.new 0 | |
159 | val sep = | |
160 | if profile = ProfileCallStack | |
161 | then " " | |
162 | else "\t" | |
163 | val {get = nameIndex, ...} = | |
164 | Property.get (SourceInfo.plist, | |
165 | Property.initFun | |
166 | (fn si => | |
167 | (List.push (names, SourceInfo.toString' (si, sep)) | |
168 | ; Counter.next nameCounter))) | |
169 | in | |
170 | fun sourceInfoNode (si: SourceInfo.t) = | |
171 | let | |
172 | val infoNode = | |
173 | InfoNode.T {info = si, | |
174 | nameIndex = nameIndex si, | |
175 | sourcesIndex = Counter.next sourceCounter, | |
176 | successors = ref []} | |
177 | val _ = List.push (infoNodes, infoNode) | |
178 | in | |
179 | infoNode | |
180 | end | |
181 | end | |
182 | fun firstEnter (ps: Push.t list): InfoNode.t option = | |
183 | List.peekMap (ps, fn p => | |
184 | case p of | |
185 | Push.Enter n => SOME n | |
186 | | _ => NONE) | |
187 | (* unknown must be 0, which == SOURCES_INDEX_UNKNOWN from gc.h *) | |
188 | val unknownInfoNode = sourceInfoNode SourceInfo.unknown | |
189 | (* gc must be 1 which == SOURCES_INDEX_GC from gc.h *) | |
190 | val gcInfoNode = sourceInfoNode SourceInfo.gc | |
191 | val mainInfoNode = sourceInfoNode SourceInfo.main | |
192 | fun wantedSource (si: SourceInfo.t): bool = | |
193 | if SourceInfo.isC si | |
194 | then List.length (!Control.profileC) > 0 | |
195 | else (case SourceInfo.file si of | |
196 | NONE => true | |
197 | | SOME file => | |
198 | List.foldr | |
199 | (!Control.profileInclExcl, true, | |
200 | fn ((re, keep), b) => | |
201 | if Regexp.Compiled.matchesAll (re, file) | |
202 | then keep | |
203 | else b)) | |
204 | val wantedSource = | |
205 | Trace.trace ("Profile.wantedSource", SourceInfo.layout, Bool.layout) | |
206 | wantedSource | |
207 | fun wantedCSource (si: SourceInfo.t): bool = | |
208 | wantedSource si | |
209 | andalso | |
210 | if SourceInfo.isC si | |
211 | then false | |
212 | else (case SourceInfo.file si of | |
213 | NONE => false | |
214 | | SOME file => | |
215 | List.foldr | |
216 | (!Control.profileC, false, | |
217 | fn (re, b) => | |
218 | if Regexp.Compiled.matchesAll (re, file) | |
219 | then true | |
220 | else b)) | |
221 | val wantedCSource = | |
222 | Trace.trace ("Profile.wantedCSource", SourceInfo.layout, Bool.layout) | |
223 | wantedCSource | |
224 | fun keepSource (si: SourceInfo.t): bool = | |
225 | profile <> ProfileCount | |
226 | orelse wantedSource si | |
227 | val keepSource = | |
228 | Trace.trace ("Profile.keepSource", SourceInfo.layout, Bool.layout) | |
229 | keepSource | |
230 | (* With -profile count, we want to get zero counts for all functions, | |
231 | * whether or not they made it into the final executable. | |
232 | *) | |
233 | val () = | |
234 | case profile of | |
235 | ProfileCount => | |
236 | List.foreach (SourceInfo.all (), fn si => | |
237 | if wantedSource si | |
238 | then ignore (sourceInfoNode si) | |
239 | else ()) | |
240 | | _ => () | |
241 | val sourceInfoNode = | |
242 | fn si => | |
243 | let | |
244 | open SourceInfo | |
245 | in | |
246 | if equals (si, unknown) | |
247 | then unknownInfoNode | |
248 | else if equals (si, gc) | |
249 | then gcInfoNode | |
250 | else if equals (si, main) | |
251 | then mainInfoNode | |
252 | else sourceInfoNode si | |
253 | end | |
254 | val sourceInfoNode = | |
255 | Trace.trace ("Profile.sourceInfoNode", SourceInfo.layout, InfoNode.layout) | |
256 | sourceInfoNode | |
257 | local | |
258 | val table: {hash: word, | |
259 | index: int, | |
260 | sourceSeq: int vector} HashSet.t = | |
261 | HashSet.new {hash = #hash} | |
262 | val c = Counter.new 0 | |
263 | val sourceSeqs: int vector list ref = ref [] | |
264 | in | |
265 | fun sourceSeqIndex (s: sourceSeq): int = | |
266 | let | |
267 | val s = Vector.fromListRev s | |
268 | val hash = | |
269 | Vector.fold (s, 0w0, fn (i, w) => | |
270 | w * 0w31 + Word.fromInt i) | |
271 | in | |
272 | #index | |
273 | (HashSet.lookupOrInsert | |
274 | (table, hash, | |
275 | fn {sourceSeq = s', ...} => s = s', | |
276 | fn () => let | |
277 | val _ = List.push (sourceSeqs, s) | |
278 | in | |
279 | {hash = hash, | |
280 | index = Counter.next c, | |
281 | sourceSeq = s} | |
282 | end)) | |
283 | end | |
284 | fun makeSourceSeqs () = Vector.fromListRev (!sourceSeqs) | |
285 | end | |
286 | (* Ensure that [SourceInfo.unknown] is index 0. *) | |
287 | val _ = sourceSeqIndex [InfoNode.sourcesIndex unknownInfoNode] | |
288 | (* Ensure that [SourceInfo.gc] is index 1. *) | |
289 | val _ = sourceSeqIndex [InfoNode.sourcesIndex gcInfoNode] | |
290 | fun addFrameProfileIndex (label: Label.t, | |
291 | index: int): unit = | |
292 | List.push (frameProfileIndices, (label, index)) | |
293 | fun addFrameProfilePushes (label: Label.t, | |
294 | pushes: Push.t list): unit = | |
295 | addFrameProfileIndex (label, | |
296 | sourceSeqIndex (Push.toSources pushes)) | |
297 | val {get = labelInfo: Label.t -> {block: Block.t, | |
298 | visited1: bool ref, | |
299 | visited2: bool ref}, | |
300 | set = setLabelInfo, ...} = | |
301 | Property.getSetOnce | |
302 | (Label.plist, Property.initRaise ("info", Label.layout)) | |
303 | val labels = ref [] | |
304 | fun profileLabelFromIndex (sourceSeqsIndex: int): Statement.t = | |
305 | let | |
306 | val l = ProfileLabel.new () | |
307 | val _ = List.push (labels, {label = l, | |
308 | sourceSeqsIndex = sourceSeqsIndex}) | |
309 | in | |
310 | Statement.ProfileLabel l | |
311 | end | |
312 | fun setCurSourceSeqsIndexFromIndex (sourceSeqsIndex: int): Statement.t = | |
313 | let | |
314 | val curSourceSeqsIndex = | |
315 | Operand.Runtime Runtime.GCField.CurSourceSeqsIndex | |
316 | in | |
317 | Statement.Move | |
318 | {dst = curSourceSeqsIndex, | |
319 | src = Operand.word (WordX.fromIntInf | |
320 | (IntInf.fromInt sourceSeqsIndex, | |
321 | WordSize.word32))} | |
322 | end | |
323 | fun codeCoverageStatementFromIndex (sourceSeqsIndex: int): Statement.t = | |
324 | if needProfileLabels | |
325 | then profileLabelFromIndex sourceSeqsIndex | |
326 | else if profile = ProfileTimeField | |
327 | then setCurSourceSeqsIndexFromIndex sourceSeqsIndex | |
328 | else Error.bug "Profile.codeCoverageStatement" | |
329 | fun codeCoverageStatement (sourceSeq: int list): Statement.t = | |
330 | codeCoverageStatementFromIndex (sourceSeqIndex sourceSeq) | |
331 | local | |
332 | val {get: Func.t -> FuncInfo.t, ...} = | |
333 | Property.get (Func.plist, Property.initFun (fn _ => FuncInfo.new ())) | |
334 | in | |
335 | val funcInfo = get | |
336 | fun addFuncEdges () = | |
337 | (* Don't need to add edges for main because no one calls it. *) | |
338 | List.foreach | |
339 | (functions, fn f => | |
340 | let | |
341 | val allSeen: bool ref list ref = ref [] | |
342 | val func = Function.name f | |
343 | val fi as FuncInfo.T {callers, ...} = get func | |
344 | (* Add edges from all the callers to the enters in f and all | |
345 | * functions that f tail calls. | |
346 | *) | |
347 | fun call (FuncInfo.T {enters, seen, tailCalls, ...}): unit = | |
348 | if !seen | |
349 | then () | |
350 | else | |
351 | let | |
352 | val _ = seen := true | |
353 | val _ = List.push (allSeen, seen) | |
354 | val _ = | |
355 | List.foreach | |
356 | (!callers, fn from => | |
357 | List.foreach | |
358 | (!enters, fn to => | |
359 | InfoNode.call {from = from, to = to})) | |
360 | in | |
361 | List.foreach (!tailCalls, call) | |
362 | end | |
363 | val _ = call fi | |
364 | val _ = List.foreach (!allSeen, fn r => r := false) | |
365 | in | |
366 | () | |
367 | end) | |
368 | end | |
369 | fun doFunction (f: Function.t): Function.t = | |
370 | let | |
371 | val {args, blocks, name, raises, returns, start} = Function.dest f | |
372 | val _ = | |
373 | if not debug | |
374 | then () | |
375 | else print (concat ["doFunction ", Func.toString name, "\n"]) | |
376 | val FuncInfo.T {enters, tailCalls, ...} = funcInfo name | |
377 | fun enter (ps: Push.t list, si: SourceInfo.t): Push.t list * bool = | |
378 | let | |
379 | val node = Promise.lazy (fn () => sourceInfoNode si) | |
380 | fun yes () = (Push.Enter (node ()) :: ps, true) | |
381 | fun no () = (Push.Skip si :: ps, false) | |
382 | in | |
383 | if SourceInfo.equals (si, SourceInfo.unknown) | |
384 | then no () | |
385 | else | |
386 | case firstEnter ps of | |
387 | NONE => | |
388 | if keepSource si | |
389 | then (List.push (enters, node ()) | |
390 | ; yes ()) | |
391 | else no () | |
392 | | SOME (node' as InfoNode.T {info = si', ...}) => | |
393 | (* | |
394 | * si : callee | |
395 | * si' : caller | |
396 | *) | |
397 | if keepSource si | |
398 | andalso | |
399 | let | |
400 | open SourceInfo | |
401 | in | |
402 | equals (si', unknown) | |
403 | orelse | |
404 | (wantedSource si | |
405 | andalso | |
406 | not (equals (si, gcArrayAllocate)) | |
407 | andalso | |
408 | (not (isC si) | |
409 | orelse | |
410 | (wantedCSource si' | |
411 | andalso not (equals (si', main))))) | |
412 | end | |
413 | then (InfoNode.call {from = node', to = node ()} | |
414 | ; yes ()) | |
415 | else no () | |
416 | end | |
417 | val enter = traceEnter enter | |
418 | val _ = | |
419 | Vector.foreach | |
420 | (blocks, fn block as Block.T {label, ...} => | |
421 | setLabelInfo (label, {block = block, | |
422 | visited1 = ref false, | |
423 | visited2 = ref false})) | |
424 | (* Find the first Enter statement and (conceptually) move it to the | |
425 | * front of the function. | |
426 | *) | |
427 | local | |
428 | exception Yes of Label.t * Statement.t | |
429 | fun goto l = | |
430 | let | |
431 | val {block, visited1, ...} = labelInfo l | |
432 | in | |
433 | if !visited1 | |
434 | then () | |
435 | else | |
436 | let | |
437 | val () = visited1 := true | |
438 | val Block.T {statements, transfer, ...} = block | |
439 | val () = | |
440 | Vector.foreach | |
441 | (statements, fn s => | |
442 | case s of | |
443 | Statement.Profile (ProfileExp.Enter _) => | |
444 | raise Yes (l, s) | |
445 | | _ => ()) | |
446 | val () = Transfer.foreachLabel (transfer, goto) | |
447 | in | |
448 | () | |
449 | end | |
450 | end | |
451 | in | |
452 | val first = (goto start; NONE) handle Yes z => SOME z | |
453 | end | |
454 | val blocks = ref [] | |
455 | datatype z = datatype Statement.t | |
456 | datatype z = datatype ProfileExp.t | |
457 | fun backward {args, | |
458 | kind, | |
459 | label, | |
460 | leaves, | |
461 | sourceSeq: int list, | |
462 | statements: Statement.t list, | |
463 | transfer: Transfer.t}: unit = | |
464 | let | |
465 | val (_, ncc, sourceSeq, statements) = | |
466 | List.fold | |
467 | (statements, | |
468 | (leaves, true, sourceSeq, []), | |
469 | fn (s, (leaves, ncc, sourceSeq, ss)) => | |
470 | case s of | |
471 | Object _ => (leaves, true, sourceSeq, s :: ss) | |
472 | | Profile ps => | |
473 | let | |
474 | val (ncc, ss) = | |
475 | if needCodeCoverage | |
476 | then | |
477 | if ncc | |
478 | andalso not (List.isEmpty sourceSeq) | |
479 | then (false, | |
480 | codeCoverageStatement sourceSeq :: ss) | |
481 | else (true, ss) | |
482 | else (false, ss) | |
483 | val (leaves, sourceSeq) = | |
484 | case ps of | |
485 | Enter _ => | |
486 | (case sourceSeq of | |
487 | [] => Error.bug | |
488 | "Profile.backward: unmatched Enter" | |
489 | | _ :: sis => (leaves, sis)) | |
490 | | Leave _ => | |
491 | (case leaves of | |
492 | [] => Error.bug | |
493 | "Profile.backward: missing Leave" | |
494 | | infoNode :: leaves => | |
495 | (leaves, | |
496 | InfoNode.sourcesIndex infoNode | |
497 | :: sourceSeq)) | |
498 | in | |
499 | (leaves, ncc, sourceSeq, ss) | |
500 | end | |
501 | | _ => (leaves, true, sourceSeq, s :: ss)) | |
502 | val statements = | |
503 | if needCodeCoverage | |
504 | andalso ncc | |
505 | then codeCoverageStatement sourceSeq :: statements | |
506 | else statements | |
507 | val {args, kind, label} = | |
508 | if profileStack andalso (case kind of | |
509 | Kind.Cont _ => true | |
510 | | Kind.Handler => true | |
511 | | _ => false) | |
512 | then | |
513 | let | |
514 | val func = CFunction.profileLeave () | |
515 | val newLabel = Label.newNoname () | |
516 | val _ = | |
517 | addFrameProfileIndex | |
518 | (newLabel, sourceSeqIndex sourceSeq) | |
519 | val statements = | |
520 | if needCodeCoverage | |
521 | then (Vector.new1 | |
522 | (codeCoverageStatement sourceSeq)) | |
523 | else Vector.new0 () | |
524 | val _ = | |
525 | List.push | |
526 | (blocks, | |
527 | Block.T | |
528 | {args = args, | |
529 | kind = kind, | |
530 | label = label, | |
531 | statements = statements, | |
532 | transfer = | |
533 | Transfer.CCall | |
534 | {args = Vector.new1 Operand.GCState, | |
535 | func = func, | |
536 | return = SOME newLabel}}) | |
537 | in | |
538 | {args = Vector.new0 (), | |
539 | kind = Kind.CReturn {func = func}, | |
540 | label = newLabel} | |
541 | end | |
542 | else | |
543 | {args = args, | |
544 | kind = kind, | |
545 | label = label} | |
546 | in | |
547 | List.push (blocks, | |
548 | Block.T {args = args, | |
549 | kind = kind, | |
550 | label = label, | |
551 | statements = Vector.fromList statements, | |
552 | transfer = transfer}) | |
553 | end | |
554 | val backward = | |
555 | Trace.trace | |
556 | ("Profile.backward", | |
557 | fn {leaves, statements, sourceSeq, ...} => | |
558 | let | |
559 | open Layout | |
560 | in | |
561 | record [("leaves", List.layout InfoNode.layout leaves), | |
562 | ("sourceSeq", List.layout Int.layout sourceSeq), | |
563 | ("statements", | |
564 | List.layout Statement.layout statements)] | |
565 | end, | |
566 | Unit.layout) | |
567 | backward | |
568 | fun profileEnter (pushes: Push.t list, | |
569 | transfer: Transfer.t): Transfer.t = | |
570 | let | |
571 | val func = CFunction.profileEnter () | |
572 | val newLabel = Label.newNoname () | |
573 | val index = sourceSeqIndex (Push.toSources pushes) | |
574 | val _ = addFrameProfileIndex (newLabel, index) | |
575 | val statements = | |
576 | if needCodeCoverage | |
577 | then Vector.new1 (codeCoverageStatementFromIndex index) | |
578 | else Vector.new0 () | |
579 | val _ = | |
580 | List.push | |
581 | (blocks, | |
582 | Block.T {args = Vector.new0 (), | |
583 | kind = Kind.CReturn {func = func}, | |
584 | label = newLabel, | |
585 | statements = statements, | |
586 | transfer = transfer}) | |
587 | in | |
588 | Transfer.CCall {args = Vector.new1 Operand.GCState, | |
589 | func = func, | |
590 | return = SOME newLabel} | |
591 | end | |
592 | fun goto (l: Label.t, pushes: Push.t list): unit = | |
593 | let | |
594 | val _ = | |
595 | if not debug | |
596 | then () | |
597 | else | |
598 | let | |
599 | open Layout | |
600 | in | |
601 | outputl (seq [str "goto (", | |
602 | Label.layout l, | |
603 | str ", ", | |
604 | List.layout Push.layout pushes, | |
605 | str ")"], | |
606 | Out.error) | |
607 | end | |
608 | val {block, visited2, ...} = labelInfo l | |
609 | in | |
610 | if !visited2 | |
611 | then () | |
612 | else | |
613 | let | |
614 | val _ = visited2 := true | |
615 | val Block.T {args, kind, label, statements, transfer, | |
616 | ...} = block | |
617 | val statements = | |
618 | case first of | |
619 | NONE => statements | |
620 | | SOME (firstLabel, firstEnter) => | |
621 | if Label.equals (label, firstLabel) | |
622 | then | |
623 | Vector.removeFirst | |
624 | (statements, fn s => | |
625 | case s of | |
626 | Profile (Enter _) => true | |
627 | | _ => false) | |
628 | else if Label.equals (label, start) | |
629 | then | |
630 | Vector.concat | |
631 | [Vector.new1 firstEnter, | |
632 | statements] | |
633 | else statements | |
634 | val _ = | |
635 | let | |
636 | fun add pushes = | |
637 | addFrameProfilePushes (label, pushes) | |
638 | datatype z = datatype Kind.t | |
639 | in | |
640 | case kind of | |
641 | Cont _ => add pushes | |
642 | | CReturn {func, ...} => | |
643 | let | |
644 | datatype z = datatype CFunction.Target.t | |
645 | val target = CFunction.target func | |
646 | fun doit si = | |
647 | add (#1 (enter (pushes, si))) | |
648 | in | |
649 | case target of | |
650 | Direct "GC_collect" => doit SourceInfo.gc | |
651 | | Direct "GC_arrayAllocate" => | |
652 | doit SourceInfo.gcArrayAllocate | |
653 | | Direct "MLton_bug" => add pushes | |
654 | | Direct name => doit (SourceInfo.fromC name) | |
655 | | Indirect => doit (SourceInfo.fromC "<indirect>") | |
656 | end | |
657 | | Handler => add pushes | |
658 | | Jump => () | |
659 | end | |
660 | fun maybeSplit {args, | |
661 | bytesAllocated: Bytes.t, | |
662 | kind, | |
663 | label, | |
664 | leaves, | |
665 | pushes: Push.t list, | |
666 | shouldSplit: bool, | |
667 | statements} = | |
668 | if not shouldSplit | |
669 | then {args = args, | |
670 | bytesAllocated = Bytes.zero, | |
671 | kind = kind, | |
672 | label = label, | |
673 | leaves = leaves, | |
674 | statements = statements} | |
675 | else | |
676 | let | |
677 | val newLabel = Label.newNoname () | |
678 | val _ = | |
679 | addFrameProfilePushes (newLabel, pushes) | |
680 | val func = CFunction.profileInc () | |
681 | val amount = | |
682 | case profile of | |
683 | ProfileAlloc => Bytes.toInt bytesAllocated | |
684 | | ProfileCount => 1 | |
685 | | _ => Error.bug "Profile.maybeSplit: amount" | |
686 | val transfer = | |
687 | Transfer.CCall | |
688 | {args = (Vector.new2 | |
689 | (Operand.GCState, | |
690 | Operand.word | |
691 | (WordX.fromIntInf | |
692 | (IntInf.fromInt amount, | |
693 | WordSize.csize ())))), | |
694 | func = func, | |
695 | return = SOME newLabel} | |
696 | val sourceSeq = Push.toSources pushes | |
697 | val _ = | |
698 | backward {args = args, | |
699 | kind = kind, | |
700 | label = label, | |
701 | leaves = leaves, | |
702 | sourceSeq = sourceSeq, | |
703 | statements = statements, | |
704 | transfer = transfer} | |
705 | in | |
706 | {args = Vector.new0 (), | |
707 | bytesAllocated = Bytes.zero, | |
708 | kind = Kind.CReturn {func = func}, | |
709 | label = newLabel, | |
710 | leaves = [], | |
711 | statements = []} | |
712 | end | |
713 | val {args, bytesAllocated, kind, label, leaves, pushes, | |
714 | statements} = | |
715 | Vector.fold | |
716 | (statements, | |
717 | {args = args, | |
718 | bytesAllocated = Bytes.zero, | |
719 | kind = kind, | |
720 | label = label, | |
721 | leaves = [], | |
722 | pushes = pushes, | |
723 | statements = []}, | |
724 | fn (s, {args, bytesAllocated, kind, label, | |
725 | leaves, | |
726 | pushes: Push.t list, | |
727 | statements}) => | |
728 | (if not debug | |
729 | then () | |
730 | else | |
731 | let | |
732 | open Layout | |
733 | in | |
734 | outputl | |
735 | (seq [List.layout Push.layout pushes, | |
736 | str " ", | |
737 | Statement.layout s], | |
738 | Out.error) | |
739 | end | |
740 | ; | |
741 | case s of | |
742 | Object {size, ...} => | |
743 | {args = args, | |
744 | bytesAllocated = Bytes.+ (bytesAllocated, size), | |
745 | kind = kind, | |
746 | label = label, | |
747 | leaves = leaves, | |
748 | pushes = pushes, | |
749 | statements = s :: statements} | |
750 | | Profile ps => | |
751 | let | |
752 | val shouldSplit = | |
753 | profile = ProfileAlloc | |
754 | andalso Bytes.> (bytesAllocated, | |
755 | Bytes.zero) | |
756 | val {args, bytesAllocated, kind, label, | |
757 | leaves, statements} = | |
758 | maybeSplit | |
759 | {args = args, | |
760 | bytesAllocated = bytesAllocated, | |
761 | kind = kind, | |
762 | label = label, | |
763 | leaves = leaves, | |
764 | pushes = pushes, | |
765 | shouldSplit = shouldSplit, | |
766 | statements = statements} | |
767 | datatype z = datatype ProfileExp.t | |
768 | val (pushes, keep, leaves) = | |
769 | case ps of | |
770 | Enter si => | |
771 | let | |
772 | val (pushes, keep) = | |
773 | enter (pushes, si) | |
774 | in | |
775 | (pushes, keep, leaves) | |
776 | end | |
777 | | Leave si => | |
778 | (case pushes of | |
779 | [] => Error.bug | |
780 | "Profile.goto: unmatched Leave" | |
781 | | p :: pushes => | |
782 | let | |
783 | val (keep, si', leaves) = | |
784 | case p of | |
785 | Push.Enter | |
786 | (infoNode as | |
787 | InfoNode.T | |
788 | {info, ...}) => | |
789 | (true, info, | |
790 | infoNode :: leaves) | |
791 | | Push.Skip si' => | |
792 | (false, si', | |
793 | leaves) | |
794 | in | |
795 | if SourceInfo.equals (si, si') | |
796 | then (pushes, | |
797 | keep, | |
798 | leaves) | |
799 | else Error.bug | |
800 | "Profile.goto: mismatched Leave" | |
801 | end) | |
802 | val shouldSplit = | |
803 | profile = ProfileCount | |
804 | andalso (case ps of | |
805 | Enter _ => keep | |
806 | | _ => false) | |
807 | val {args, bytesAllocated, kind, label, | |
808 | leaves, statements} = | |
809 | maybeSplit | |
810 | {args = args, | |
811 | bytesAllocated = bytesAllocated, | |
812 | kind = kind, | |
813 | label = label, | |
814 | leaves = leaves, | |
815 | pushes = pushes, | |
816 | shouldSplit = shouldSplit, | |
817 | statements = statements} | |
818 | val statements = | |
819 | if keep | |
820 | then s :: statements | |
821 | else statements | |
822 | in | |
823 | {args = args, | |
824 | bytesAllocated = bytesAllocated, | |
825 | kind = kind, | |
826 | label = label, | |
827 | leaves = leaves, | |
828 | pushes = pushes, | |
829 | statements = statements} | |
830 | end | |
831 | | _ => | |
832 | {args = args, | |
833 | bytesAllocated = bytesAllocated, | |
834 | kind = kind, | |
835 | label = label, | |
836 | leaves = leaves, | |
837 | pushes = pushes, | |
838 | statements = s :: statements}) | |
839 | ) | |
840 | val shouldSplit = | |
841 | profile = ProfileAlloc | |
842 | andalso Bytes.> (bytesAllocated, Bytes.zero) | |
843 | val {args, kind, label, leaves, statements, ...} = | |
844 | maybeSplit {args = args, | |
845 | bytesAllocated = bytesAllocated, | |
846 | kind = kind, | |
847 | label = label, | |
848 | leaves = leaves, | |
849 | pushes = pushes, | |
850 | shouldSplit = shouldSplit, | |
851 | statements = statements} | |
852 | val _ = | |
853 | Transfer.foreachLabel | |
854 | (transfer, fn l => goto (l, pushes)) | |
855 | val transfer = | |
856 | case transfer of | |
857 | Transfer.Call {func, return, ...} => | |
858 | let | |
859 | val fi as FuncInfo.T {callers, ...} = | |
860 | funcInfo func | |
861 | in | |
862 | case return of | |
863 | Return.NonTail _ => | |
864 | let | |
865 | val _ = | |
866 | case firstEnter pushes of | |
867 | NONE => | |
868 | List.push (tailCalls, fi) | |
869 | | SOME n => | |
870 | List.push (callers, n) | |
871 | in | |
872 | if profileStack | |
873 | then profileEnter (pushes, | |
874 | transfer) | |
875 | else transfer | |
876 | end | |
877 | | _ => | |
878 | (List.push (tailCalls, fi) | |
879 | ; transfer) | |
880 | end | |
881 | | _ => transfer | |
882 | in | |
883 | backward {args = args, | |
884 | kind = kind, | |
885 | label = label, | |
886 | leaves = leaves, | |
887 | sourceSeq = Push.toSources pushes, | |
888 | statements = statements, | |
889 | transfer = transfer} | |
890 | end | |
891 | end | |
892 | val _ = goto (start, []) | |
893 | val blocks = Vector.fromList (!blocks) | |
894 | in | |
895 | Function.new {args = args, | |
896 | blocks = blocks, | |
897 | name = name, | |
898 | raises = raises, | |
899 | returns = returns, | |
900 | start = start} | |
901 | end | |
902 | val program = Program.T {functions = List.revMap (functions, doFunction), | |
903 | handlesSignals = handlesSignals, | |
904 | main = doFunction main, | |
905 | objectTypes = objectTypes} | |
906 | val _ = addFuncEdges () | |
907 | val names = Vector.fromListRev (!names) | |
908 | val sources = | |
909 | Vector.map | |
910 | (Vector.fromListRev (!infoNodes), | |
911 | fn InfoNode.T {nameIndex, successors, ...} => | |
912 | {nameIndex = nameIndex, | |
913 | successorsIndex = (sourceSeqIndex | |
914 | (List.revMap (!successors, | |
915 | InfoNode.sourcesIndex)))}) | |
916 | (* makeSourceSeqs () must happen after making sources, since that creates | |
917 | * new sourceSeqs. | |
918 | *) | |
919 | val sourceSeqs = makeSourceSeqs () | |
920 | fun makeProfileInfo {frames} = | |
921 | let | |
922 | val {get, set, ...} = | |
923 | Property.getSetOnce | |
924 | (Label.plist, | |
925 | Property.initRaise ("frameProfileIndex", Label.layout)) | |
926 | val _ = | |
927 | List.foreach (!frameProfileIndices, fn (l, i) => | |
928 | set (l, i)) | |
929 | val frameSources = Vector.map (frames, get) | |
930 | in | |
931 | SOME (Machine.ProfileInfo.T | |
932 | {frameSources = frameSources, | |
933 | labels = Vector.fromList (!labels), | |
934 | names = names, | |
935 | sourceSeqs = sourceSeqs, | |
936 | sources = sources}) | |
937 | end | |
938 | in | |
939 | (program, makeProfileInfo) | |
940 | end | |
941 | ||
942 | end |