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 676, Sat Jun 24 03:37:03 2000 UTC revision 677, Mon Jun 26 00:56:56 2000 UTC
# Line 20  Line 20 
20  structure BTImp : sig  structure BTImp : sig
21  end = struct  end = struct
22    
23      exception NotFound      structure S = IntRedBlackSet
24        structure M = IntRedBlackMap
25    
26      structure HT = IntHashTable      datatype descr =
27      structure IS = IntRedBlackSet          STEP of int
28      structure IM = IntRedBlackMap        | LOOP of S.set
     structure SM = RedBlackMapFn (struct  
         type ord_key = string val compare = String.compare  
     end)  
29    
30      type intset = IS.set      type stage = { num: int, descr: descr }
31    
32      datatype contents =      type frame = { depth: int, map: int M.map, stages: stage list }
         SINGLE of int  
       | CLUSTER of intset  
33    
34      type stamp = unit ref      type history = frame * frame list
35    
36      type node = stamp * contents      val cur : history ref =
37            ref ({ depth = 0, map = M.empty, stages = [] }, [])
38    
39      type htable = node HT.hash_table      val names = ref (M.empty: string M.map)
40        val next = ref 0
     type stage = htable * node list ref  
41    
42      type history = stage list      fun reset () = (names := M.empty; next := 0)
43    
44      val s2i_m = ref (SM.empty: int SM.map)      fun reserve n = !next before next := !next + n
     val i2s_m = ref (IM.empty: string IM.map)  
     val next = ref 0  
45    
46      fun reset () = (s2i_m := SM.empty; i2s_m := IM.empty; next := 0)      fun register (module, fct, s) =
47            names := M.insert (!names, module + fct, s)
48    
49      fun mkid s =      fun add (module, fct) = let
50          case SM.find (!s2i_m, s) of          val i = module + fct
51              SOME i => i          val (front, back) = !cur
52            | NONE => let          val { depth, map, stages } = front
53                  val i = !next      in
54            case M.find (map, i) of
55                SOME num => let
56                    fun toSet (STEP i) = S.singleton i
57                      | toSet (LOOP s) = s
58                    fun join (set, d) = S.union (set, toSet d)
59                    fun finish (stages, c, []) =
60                        let val stage = { num = num, descr = LOOP (toSet c) }
61                            val front' = { depth = depth,
62                                           map = map,
63                                           stages = stage :: stages }
64                        in
65                            cur := (front', back)
66                        end
67                      | finish (stages, c, l) =
68                        let val s0 = foldl S.union S.empty l
69                            val stage = { num = num, descr = LOOP (join (s0, c)) }
70                            fun ins (i, m) = M.insert (m, i, num)
71                            val front' = { depth = depth,
72                                           map = S.foldl ins map s0,
73                                           stages = stage :: stages }
74                        in
75                            cur := (front', back)
76                        end
77                    fun loop ([], setl) = finish ([], LOOP S.empty, setl)
78                      | loop ({ num = n', descr = d' } :: t, setl) =
79                        if num = n' then finish (t, d', setl)
80                        else loop (t, toSet d' :: setl)
81              in              in
82                  next := i + 1;                  loop (stages, [])
                 s2i_m := SM.insert (!s2i_m, s, i);  
                 i  
             end  
   
     fun register (i, s) = let  
         fun insert () = i2s_m := IM.insert (!i2s_m, i, s)  
     in  
         case IM.find (!i2s_m, i) of  
             NONE => insert ()  
           | SOME s' =>  
             if s = s' then ()  
             else (print (concat ["BTrace: register: id clash between\n\t", s',  
                                  "\nand\n\t", s, ";\nusing latter.\n"]);  
                   insert ())  
     end  
   
     fun new_ht () = HT.mkTable (16, NotFound)  
   
     val cur = ref ([]: history)  
   
     fun add i =  
         case !cur of  
             [] => ()  
           | (ht, nlr) :: _ =>  
             (case HT.find ht i of  
                  SOME (s, c) => let  
                      fun toSet (SINGLE i) = IS.singleton i  
                        | toSet (CLUSTER s) = s  
                      fun join (set, c) = IS.union (set, toSet c)  
                      fun finish (l, set) = let  
                          val n = (s, CLUSTER set)  
                      in  
                          nlr := n :: l;  
                          IS.app (fn i => HT.insert ht (i, n)) set  
                      end  
                      fun loop ([], set) = finish ([], set)  
                        | loop ((s', c) :: t, set) =  
                          if s = s' then finish (t, set)  
                          else loop (t, join (set, c))  
                  in  
                      loop (!nlr, toSet c)  
83                   end                   end
84                 | NONE => let                 | NONE => let
85                       val n = (ref (), SINGLE i)                  val num = case stages of
86                       val l = n :: !nlr                                [] => 0
87                                | s0 :: _ => #num s0 + 1
88                    val stage = { num = num, descr = STEP i}
89                    val front' = { depth = depth,
90                                   map = M.insert (map, i, num),
91                                   stages = stage :: stages }
92                   in                   in
93                       HT.insert ht (i, n);                  cur := (front' , back)
94                       nlr := l              end
95                   end)      end
96    
97      fun push () = let      fun push () = let
98          val old = !cur          val old as (front, _) = !cur
99            val front' = { depth = #depth front + 1, map = M.empty, stages = [] }
100      in      in
101          cur := (new_ht (), ref []) :: old;          cur := (front', op :: old);
102          fn () => cur := old          fn () => cur := old
103      end      end
104    
# Line 122  Line 109 
109      end      end
110    
111      fun report () = let      fun report () = let
112          val top = !cur          val (front, back) = !cur
113          fun do_report () = let          fun do_report () = let
114              val bot = !cur              val (front', _) = !cur
115              val isBot =              val bot_depth = #depth front'
116                  case bot of              fun isBot (f: frame) = #depth f = bot_depth
117                      [] => (fn _ => false)              fun name (w, pad, i) = let
118                    | (_, bot_nlr) :: _ => (fn nlr => bot_nlr = nlr)                  val n = getOpt (M.find (!names, i), "???")
             fun name (what, pad, i) = let  
                 val n = case IM.find (!i2s_m, i) of  
                             NONE => "???"  
                           | SOME s => s  
119              in              in
120                  concat [what, pad, " ", n, "\n"]                  concat [w, pad, " ", n, "\n"]
121              end              end
122              fun node (what, (_, SINGLE i), a) = name (what, "  ", i) :: a              fun stage (w, { num, descr = STEP i }, a) = name (w, "  ", i) :: a
123                | node (what, (_, CLUSTER s), a) = let                | stage (w, { num, descr = LOOP s }, a) = let
124                      fun loop ([], a) = a                      fun loop ([], a) = a
125                        | loop ([i], a) = name (what, "-\\", i) :: a                        | loop ([i], a) = name (w, "-\\", i) :: a
126                        | loop (h :: t, a) =                        | loop (h :: t, a) =
127                          loop (t, name ("    ", " |", h) :: a)                          loop (t, name ("    ", " |", h) :: a)
128                      fun looph ([], a) = a                      fun start ([], a) = a
129                        | looph ([i], a) = name (what, "-(", i) :: a                        | start ([i], a) = name (w, "-(", i) :: a
130                        | looph (h :: t, a) =                        | start (h :: t, a) =
131                          loop (t, name ("    ", " /", h) :: a)                          loop (t, name ("    ", " /", h) :: a)
132                  in                  in
133                      looph (IS.listItems s, a)                      start (S.listItems s, a)
134                  end                  end
135              fun jumps ([], a) = a              fun jumps ([], a) = a
136                | jumps ([n], a) = node ("CALL", n, a)                | jumps ([n], a) = stage ("CALL", n, a)
137                | jumps (h :: t, a) = jumps (t, node ("GOTO", h, a))                | jumps (h :: t, a) = jumps (t, stage ("GOTO", h, a))
138              fun calls ([], a) = a              fun calls (h, [], a) = jumps (#stages h, a)
139                | calls ((_, nlr as ref nl) :: t, a) = let                | calls (h, h' :: t, a) = let
140                      val a = jumps (nl, a)                      val a = jumps (#stages h, a)
141                  in                  in
142                      if isBot nlr then a else calls (t, a)                      if isBot h then a else calls (h', t, a)
143                  end                  end
144          in          in
145              rev (calls (top, []))              rev (calls (front, back, []))
146          end          end
147      in      in
148          do_report          do_report
# Line 170  Line 153 
153              { corefns = { save = save,              { corefns = { save = save,
154                            push = push,                            push = push,
155                            add = add,                            add = add,
156                              reserve = reserve,
157                            register = register,                            register = register,
158                            report = report },                            report = report },
159                reset = reset,                reset = reset }
               mkid = mkid }  
160    
161      val _ = install ()      val _ = install ()
162  end  end

Legend:
Removed from v.676  
changed lines
  Added in v.677

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