Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/MiscUtil/profile/btimp.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/MiscUtil/profile/btimp.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 678, Tue Jun 27 07:51:09 2000 UTC revision 679, Thu Jun 29 07:03:20 2000 UTC
# Line 39  Line 39 
39          STEP of int          STEP of int
40        | LOOP of set        | LOOP of set
41    
42      type stage = { num: int, descr: descr }      type stage = { num: int, from: int, descr: descr }
43    
44      type frame = { depth: int, map: int M.map, stages: stage list }      type frame = { depth: int, map: int M.map, stages: stage list }
45    
46      type history = frame * frame list      type history = frame * frame list
47    
48      val cur : history ref =      datatype state =
49          ref ({ depth = 0, map = M.empty, stages = [] }, [])          NORMAL of history
50          | PENDING of int * history
51    
52        val cur : state ref =
53            ref (NORMAL ({ depth = 0, map = M.empty, stages = [] }, []))
54    
55      val names = ref (M.empty: string M.map)      val names = ref (M.empty: string M.map)
56      val next = ref 0      val next = ref 0
# Line 60  Line 64 
64    
65      fun add (module, fct) = let      fun add (module, fct) = let
66          val i = module + fct          val i = module + fct
67          val (front, back) = !cur          val (from, front, back) =
68                case !cur of
69                    PENDING (from, (front, back)) => (from, front, back)
70                  | NORMAL (front, back) => (~1, front, back)
71          val { depth, map, stages } = front          val { depth, map, stages } = front
72      in      in
73          case M.find (map, i) of          case M.find (map, i) of
# Line 68  Line 75 
75                  fun toSet (STEP i) = SINGLETON i                  fun toSet (STEP i) = SINGLETON i
76                    | toSet (LOOP s) = s                    | toSet (LOOP s) = s
77                  fun join (set, d) = UNION (set, toSet d)                  fun join (set, d) = UNION (set, toSet d)
78                  fun finish (stages, c, EMPTY) =                  fun finish (stages, from, c, EMPTY) =
79                      let val stage = { num = num, descr = LOOP (toSet c) }                      let val stage = { num = num, from = from,
80                                          descr = LOOP (toSet c) }
81                          val front' = { depth = depth,                          val front' = { depth = depth,
82                                         map = map,                                         map = map,
83                                         stages = stage :: stages }                                         stages = stage :: stages }
84                      in                      in
85                          cur := (front', back)                          cur := NORMAL (front', back)
86                      end                      end
87                    | finish (stages, c, set) =                    | finish (stages, from, c, set) =
88                      let val stage = { num = num, descr = LOOP (join (set, c)) }                      let val stage = { num = num, from = from,
89                                          descr = LOOP (join (set, c)) }
90                          fun ins (i, m) = M.insert (m, i, num)                          fun ins (i, m) = M.insert (m, i, num)
91                          val front' = { depth = depth,                          val front' = { depth = depth,
92                                         map = fold ins map set,                                         map = fold ins map set,
93                                         stages = stage :: stages }                                         stages = stage :: stages }
94                      in                      in
95                          cur := (front', back)                          cur := NORMAL (front', back)
96                      end                      end
97                  fun loop ([], set) = () (* cannot happen! *)                  fun loop ([], set) = () (* cannot happen! *)
98                    | loop ({ num = n', descr = d' } :: t, set) =                    | loop ({ num = n', from, descr = d' } :: t, set) =
99                      if num = n' then finish (t, d', set)                      if num = n' then finish (t, from, d', set)
100                      else loop (t, join (set, d'))                      else loop (t, join (set, d'))
101              in              in
102                  loop (stages, EMPTY)                  loop (stages, EMPTY)
# Line 96  Line 105 
105                  val num = case stages of                  val num = case stages of
106                                [] => 0                                [] => 0
107                              | s0 :: _ => #num s0 + 1                              | s0 :: _ => #num s0 + 1
108                  val stage = { num = num, descr = STEP i}                  val stage = { num = num, from = from, descr = STEP i}
109                  val front' = { depth = depth,                  val front' = { depth = depth,
110                                 map = M.insert (map, i, num),                                 map = M.insert (map, i, num),
111                                 stages = stage :: stages }                                 stages = stage :: stages }
112              in              in
113                  cur := (front' , back)                  cur := NORMAL (front' , back)
114              end              end
115      end      end
116    
117      fun push () = let      fun push (module, loc) = let
118          val old as (front, _) = !cur          val id = module + loc
119            val (NORMAL old | PENDING (_, old)) = !cur
120            val (front, _) = old
121          val front' = { depth = #depth front + 1, map = M.empty, stages = [] }          val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
122      in      in
123          cur := (front', op :: old);          cur := PENDING (id, (front', op :: old));
124          fn () => cur := old          fn () => cur := NORMAL old
125        end
126    
127        fun nopush (module, loc) = let
128            val id = module + loc
129            val (NORMAL old | PENDING (_, old)) = !cur
130        in
131            cur := PENDING (id, old)
132      end      end
133    
134      fun save () = let      fun save () = let
# Line 120  Line 138 
138      end      end
139    
140      fun report () = let      fun report () = let
141          val (front, back) = !cur          val (NORMAL top | PENDING (_, top)) = !cur
142            val (front, back) = top
143          fun do_report () = let          fun do_report () = let
144              val (front', _) = !cur              val (NORMAL bot | PENDING (_, bot)) = !cur
145                val (front', _) = bot
146              val bot_depth = #depth front'              val bot_depth = #depth front'
147              fun isBot (f: frame) = #depth f = bot_depth              fun isBot (f: frame) = #depth f = bot_depth
148              fun name (w, pad, i) = let              fun name (w, pad, from, i) = let
149                  val n = getOpt (M.find (!names, i), "???")                  fun find x = getOpt (M.find (!names, x), "???")
150              in                  val n = find i
151                  concat [w, pad, " ", n, "\n"]                  val tail = case from of
152              end                                 NONE => ["\n"]
153              fun stage (w, { num, descr = STEP i }, a) = name (w, "  ", i) :: a                               | SOME j => ["\n          (from: ", find j, ")\n"]
154                | stage (w, { num, descr = LOOP s }, a) = let              in
155                    concat (w :: pad :: " " :: n :: tail)
156                end
157                fun stage (w, { num, from, descr = STEP i }, a) =
158                    name (w, "  ", SOME from, i) :: a
159                  | stage (w, { num, from, descr = LOOP s }, a) = let
160                      fun loop ([], a) = a                      fun loop ([], a) = a
161                        | loop ([i], a) = name (w, "-\\", i) :: a                        | loop ([i], a) = name (w, "-\\", SOME from, i) :: a
162                        | loop (h :: t, a) =                        | loop (h :: t, a) =
163                          loop (t, name ("    ", " |", h) :: a)                          loop (t, name ("    ", " |", NONE, h) :: a)
164                      fun start ([], a) = a                      fun start ([], a) = a
165                        | start ([i], a) = name (w, "-(", i) :: a                        | start ([i], a) = name (w, "-(", SOME from, i) :: a
166                        | start (h :: t, a) =                        | start (h :: t, a) =
167                          loop (t, name ("    ", " /", h) :: a)                          loop (t, name ("    ", " /", NONE, h) :: a)
168                  in                  in
169                      start (fold (op ::) [] s, a)                      start (fold (op ::) [] s, a)
170                  end                  end
# Line 163  Line 188 
188          SMLofNJ.Internals.BTrace.install          SMLofNJ.Internals.BTrace.install
189              { corefns = { save = save,              { corefns = { save = save,
190                            push = push,                            push = push,
191                              nopush = nopush,
192                            add = add,                            add = add,
193                            reserve = reserve,                            reserve = reserve,
194                            register = register,                            register = register,

Legend:
Removed from v.678  
changed lines
  Added in v.679

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0