basis-library/mlton/call-stack.sml

   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