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/btrace.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/MiscUtil/profile/btrace.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 28  Line 28 
28    
29  structure BTrace :> BTRACE = struct  structure BTrace :> BTRACE = struct
30    
31        exception NoCore
32    
33      fun impossible s = EM.impossible ("BTrace: " ^ s)      fun impossible s = EM.impossible ("BTrace: " ^ s)
34    
35      infix -->      infix -->
36      val op --> = BT.-->      val op --> = BT.-->
37    
38      val i_u_Ty = BT.intTy --> BT.unitTy      val i_i_Ty = BT.intTy --> BT.intTy
39        val ii_u_Ty = BT.tupleTy [BT.intTy, BT.intTy] --> BT.unitTy
40      val u_u_Ty = BT.unitTy --> BT.unitTy      val u_u_Ty = BT.unitTy --> BT.unitTy
41      val u_u_u_Ty = BT.unitTy --> u_u_Ty      val u_u_u_Ty = BT.unitTy --> u_u_Ty
42      val is_u_Ty = BT.tupleTy [BT.intTy, BT.unitTy] --> BT.unitTy      val iis_u_Ty = BT.tupleTy [BT.intTy, BT.intTy, BT.unitTy] --> BT.unitTy
43    
44      fun instrument0 (senv, cinfo: CB.compInfo) d = let      fun instrument0 (senv, cinfo: CB.compInfo) d = let
45    
# Line 73  Line 76 
76              else (s, 0) :: l              else (s, 0) :: l
77    
78          fun getCore s = let          fun getCore s = let
79              fun err _ _ _ = impossible "getCore"              fun err _ _ _ = raise NoCore
80          in          in
81              Lookup.lookVal (senv, SP.SPATH [CoreSym.coreSym,              Lookup.lookVal (senv, SP.SPATH [CoreSym.coreSym,
82                                              Symbol.varSymbol s], err)                                              Symbol.varSymbol s], err)
# Line 89  Line 92 
92                  VC.CON c => c                  VC.CON c => c
93                | _ => impossible "getCoreCon"                | _ => impossible "getCoreCon"
94    
95            val bt_reserve = getCoreVal "bt_reserve"
96          val bt_register = getCoreVal "bt_register"          val bt_register = getCoreVal "bt_register"
97          val bt_save = getCoreVal "bt_save"          val bt_save = getCoreVal "bt_save"
98          val bt_push = getCoreVal "bt_push"          val bt_push = getCoreVal "bt_push"
99          val bt_add = getCoreVal "bt_add"          val bt_add = getCoreVal "bt_add"
100          val matchcon = getCoreCon "Match"          val matchcon = getCoreCon "Match"
101    
102          val bt_register_var = tmpvar ("<bt_register>", is_u_Ty)          val bt_register_var = tmpvar ("<bt_register>", iis_u_Ty)
103          val bt_save_var = tmpvar ("<bt_save>", u_u_u_Ty)          val bt_save_var = tmpvar ("<bt_save>", u_u_u_Ty)
104          val bt_push_var = tmpvar ("<bt_push>", u_u_u_Ty)          val bt_push_var = tmpvar ("<bt_push>", u_u_u_Ty)
105          val bt_add_var = tmpvar ("<bt_add>", i_u_Ty)          val bt_add_var = tmpvar ("<bt_add>", ii_u_Ty)
106            val bt_reserve_var = tmpvar ("<bt_reserve>", i_i_Ty)
107            val bt_module_var = tmpvar ("<bt_module>", BT.intTy)
108    
109          fun VARexp v = A.VARexp (ref v, [])          fun VARexp v = A.VARexp (ref v, [])
110          fun INTexp i = A.INTexp (IntInf.fromInt i, BT.intTy)          fun INTexp i = A.INTexp (IntInf.fromInt i, BT.intTy)
# Line 107  Line 113 
113          val pushexp = A.APPexp (VARexp bt_push_var, uExp)          val pushexp = A.APPexp (VARexp bt_push_var, uExp)
114          val saveexp = A.APPexp (VARexp bt_save_var, uExp)          val saveexp = A.APPexp (VARexp bt_save_var, uExp)
115    
116          fun mkaddexp id = A.APPexp (VARexp bt_add_var, INTexp id)          fun mkaddexp id = A.APPexp (VARexp bt_add_var,
117                                        EU.TUPLEexp [VARexp bt_module_var,
118                                                     INTexp id])
119          fun mkregexp (id, s) =          fun mkregexp (id, s) =
120              A.APPexp (VARexp bt_register_var,              A.APPexp (VARexp bt_register_var,
121                        EU.TUPLEexp [INTexp id, A.STRINGexp s])                        EU.TUPLEexp [VARexp bt_module_var,
122                                       INTexp id, A.STRINGexp s])
123    
124          val regexps = ref []          val regexps = ref []
125            val next = ref 0
126    
127          fun mkadd (id, s) =          fun mkadd (id, s) =
128              (regexps := mkregexp (id, s) :: !regexps;              (regexps := mkregexp (id, s) :: !regexps;
# Line 177  Line 187 
187                  val (n, r) = loc                  val (n, r) = loc
188                  val ms = matchstring r                  val ms = matchstring r
189                  val descr = concat (ms :: ": " :: dot (n, []))                  val descr = concat (ms :: ": " :: dot (n, []))
190                  val id = SMLofNJ.Internals.BTrace.mkid descr                  val id = !next
191                    val _ = next := id + 1
192                  val addexp = mkadd (id, descr)                  val addexp = mkadd (id, descr)
193                  val arg = tmpvar ("fnvar", t)                  val arg = tmpvar ("fnvar", t)
194                  val rl' = map (i_rule true loc) rl                  val rl' = map (i_rule true loc) rl
# Line 281  Line 292 
292    
293          val d' = i_dec ([], (0, 0)) d          val d' = i_dec ([], (0, 0)) d
294      in      in
295          A.LOCALdec (A.SEQdec [VALdec (bt_save_var, AUexp bt_save),          A.LOCALdec (A.SEQdec [VALdec (bt_reserve_var, AUexp bt_reserve),
296                                  VALdec (bt_module_var,
297                                          A.APPexp (VARexp bt_reserve_var,
298                                                    INTexp (!next))),
299                                  VALdec (bt_save_var, AUexp bt_save),
300                                VALdec (bt_push_var, AUexp bt_push),                                VALdec (bt_push_var, AUexp bt_push),
301                                VALdec (bt_register_var, AUexp bt_register),                                VALdec (bt_register_var, AUexp bt_register),
302                                VALdec (bt_add_var,                                VALdec (bt_add_var,
# Line 290  Line 305 
305      end      end
306    
307      fun instrument params d =      fun instrument params d =
308          if SMLofNJ.Internals.BTrace.mode NONE then instrument0 params d          if SMLofNJ.Internals.BTrace.mode NONE then
309                instrument0 params d
310                handle NoCore => d          (* this takes care of core.sml *)
311          else d          else d
312  end  end
313    

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