Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2017 Matthew Fluet. |
2 | * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | structure MLtonCallStack = | |
10 | struct | |
11 | open Primitive.MLton.CallStack | |
12 | ||
13 | val gcState = Primitive.MLton.GCState.gcState | |
14 | structure Pointer = MLtonPointer | |
15 | ||
16 | val current: unit -> t = | |
17 | fn () => | |
18 | if not keep | |
19 | then T (Array.array (0, 0wx0)) | |
20 | else | |
21 | let | |
22 | val a = Array.alloc (Word32.toInt (numStackFrames gcState)) | |
23 | val () = callStack (gcState, a) | |
24 | in | |
25 | T a | |
26 | end | |
27 | ||
28 | val toStrings: t -> string list = | |
29 | fn T a => | |
30 | if not keep | |
31 | then [] | |
32 | else | |
33 | let | |
34 | val skip = Array.length a - 1 | |
35 | in | |
36 | Array.foldri | |
37 | (fn (i, frameIndex, ac) => | |
38 | if i >= skip | |
39 | then ac | |
40 | else | |
41 | let | |
42 | val p = frameIndexSourceSeq (gcState, frameIndex) | |
43 | val max = Int32.toInt (Pointer.getInt32 (p, 0)) | |
44 | fun loop (j, ac) = | |
45 | if j > max | |
46 | then ac | |
47 | else loop (j + 1, | |
48 | CUtil.C_String.toString (sourceName (gcState, Pointer.getWord32 (p, j))) | |
49 | :: ac) | |
50 | in | |
51 | loop (1, ac) | |
52 | end) | |
53 | [] a | |
54 | end | |
55 | end |