mlton/atoms/source-info.fun

   1 (* Copyright (C) 2003-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 SourceInfo (S: SOURCE_INFO_STRUCTS): SOURCE_INFO =
   9 struct
  10
  11 open S
  12
  13 structure Pos =
  14    struct
  15       datatype t =
  16          Known of SourcePos.t
  17        | Unknown
  18
  19       fun toString p =
  20          case p of
  21             Known p =>
  22                if !Control.profile = Control.ProfileCallStack
  23                   then SourcePos.toString p
  24                else concat [SourcePos.file p, ": ",
  25                             Int.toString (SourcePos.line p)]
  26           | Unknown => "<unknown>"
  27
  28       fun fromRegion r =
  29          case Region.left r of
  30             NONE => Unknown
  31           | SOME p => Known p
  32
  33       fun file p =
  34          case p of
  35             Known p => SOME (SourcePos.file p)
  36           | Unknown => NONE
  37    end
  38
  39 datatype info =
  40    Anonymous of Pos.t
  41  | C of string
  42  | Function of {name: string list,
  43                 pos: Pos.t}
  44
  45 datatype t = T of {hash: word,
  46                    info: info,
  47                    plist: PropertyList.t}
  48
  49 local
  50    val r: t list ref = ref []
  51 in
  52    fun new info =
  53       let
  54          val res = T {hash = Random.word (),
  55                       info = info,
  56                       plist = PropertyList.new ()}
  57          val () =
  58             if !Control.profile = Control.ProfileCount
  59                then List.push (r, res)
  60             else ()
  61       in
  62          res
  63       end
  64    fun all () = !r
  65 end
  66
  67 local
  68    fun make f (T r) = f r
  69 in
  70    val hash = make #hash
  71    val info = make #info
  72    val plist = make #plist
  73 end
  74
  75 local
  76    val set: {hash: word,
  77              name: string,
  78              sourceInfo: t} HashSet.t =
  79       HashSet.new {hash = #hash}
  80 in
  81    fun fromC (name: string) =
  82       let
  83          val hash = String.hash name
  84       in
  85          #sourceInfo
  86          (HashSet.lookupOrInsert
  87           (set, hash, fn {hash = h, ...} => hash = h,
  88            fn () => {hash = hash,
  89                      name = name,
  90                      sourceInfo = new (C name)}))
  91       end
  92 end
  93
  94 fun function {name, region} =
  95    new (Function {name = name,
  96                   pos = Pos.fromRegion region})
  97
  98 fun toString' (si, sep) =
  99    case info si of
 100       Anonymous pos => Pos.toString pos
 101     | C s => concat ["<", s, ">"]
 102     | Function {name, pos} =>
 103          concat [concat (List.separate (List.rev name, ".")),
 104                  sep, Pos.toString pos]
 105
 106 fun toString si = toString' (si, " ")
 107
 108 val layout = Layout.str o toString
 109
 110 val equals: t * t -> bool =
 111    fn (s, s') => PropertyList.equals (plist s, plist s')
 112
 113 val equals =
 114    Trace.trace2 ("SourceInfo.equals", layout, layout, Bool.layout) equals
 115
 116 fun file (s: t): File.t option =
 117    case info s of
 118       Anonymous pos => Pos.file pos
 119     | C _ => NONE
 120     | Function {pos, ...} => Pos.file pos
 121
 122 fun isC (s: t): bool =
 123    case info s of
 124       C _ => true
 125     | _ => false
 126
 127 val gc = fromC "gc"
 128 val gcArrayAllocate = fromC "GC_arrayAllocate"
 129 val main = fromC "main"
 130 val polyEqual = fromC "poly-equal"
 131 val polyHash = fromC "poly-hash"
 132 val unknown = fromC "unknown"
 133
 134 end