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
[smlnj] / 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 678, Tue Jun 27 07:51:09 2000 UTC revision 679, Thu Jun 29 07:03:20 2000 UTC
# Line 37  Line 37 
37    
38      val i_i_Ty = BT.intTy --> BT.intTy      val i_i_Ty = BT.intTy --> BT.intTy
39      val ii_u_Ty = BT.tupleTy [BT.intTy, BT.intTy] --> BT.unitTy      val ii_u_Ty = BT.tupleTy [BT.intTy, BT.intTy] --> BT.unitTy
40        val ii_u_u_Ty = ii_u_Ty --> BT.unitTy
41      val u_u_Ty = BT.unitTy --> BT.unitTy      val u_u_Ty = BT.unitTy --> BT.unitTy
42      val u_u_u_Ty = BT.unitTy --> u_u_Ty      val u_u_u_Ty = BT.unitTy --> u_u_Ty
43      val iis_u_Ty = BT.tupleTy [BT.intTy, BT.intTy, BT.unitTy] --> BT.unitTy      val iis_u_Ty = BT.tupleTy [BT.intTy, BT.intTy, BT.unitTy] --> BT.unitTy
# Line 96  Line 97 
97          val bt_register = getCoreVal "bt_register"          val bt_register = getCoreVal "bt_register"
98          val bt_save = getCoreVal "bt_save"          val bt_save = getCoreVal "bt_save"
99          val bt_push = getCoreVal "bt_push"          val bt_push = getCoreVal "bt_push"
100            val bt_nopush = getCoreVal "bt_nopush"
101          val bt_add = getCoreVal "bt_add"          val bt_add = getCoreVal "bt_add"
102          val matchcon = getCoreCon "Match"          val matchcon = getCoreCon "Match"
103    
104          val bt_register_var = tmpvar ("<bt_register>", iis_u_Ty)          val bt_register_var = tmpvar ("<bt_register>", iis_u_Ty)
105          val bt_save_var = tmpvar ("<bt_save>", u_u_u_Ty)          val bt_save_var = tmpvar ("<bt_save>", u_u_u_Ty)
106          val bt_push_var = tmpvar ("<bt_push>", u_u_u_Ty)          val bt_push_var = tmpvar ("<bt_push>", ii_u_u_Ty)
107            val bt_nopush_var = tmpvar ("<bt_nopush>", ii_u_Ty)
108          val bt_add_var = tmpvar ("<bt_add>", ii_u_Ty)          val bt_add_var = tmpvar ("<bt_add>", ii_u_Ty)
109          val bt_reserve_var = tmpvar ("<bt_reserve>", i_i_Ty)          val bt_reserve_var = tmpvar ("<bt_reserve>", i_i_Ty)
110          val bt_module_var = tmpvar ("<bt_module>", BT.intTy)          val bt_module_var = tmpvar ("<bt_module>", BT.intTy)
# Line 113  Line 116 
116          val pushexp = A.APPexp (VARexp bt_push_var, uExp)          val pushexp = A.APPexp (VARexp bt_push_var, uExp)
117          val saveexp = A.APPexp (VARexp bt_save_var, uExp)          val saveexp = A.APPexp (VARexp bt_save_var, uExp)
118    
119          fun mkaddexp id = A.APPexp (VARexp bt_add_var,          fun mkmodidexp fctvar id =
120                                      EU.TUPLEexp [VARexp bt_module_var,              A.APPexp (VARexp fctvar,
121                                                   INTexp id])                        EU.TUPLEexp [VARexp bt_module_var, INTexp id])
122    
123            val mkaddexp = mkmodidexp bt_add_var
124            val mkpushexp = mkmodidexp bt_push_var
125            val mknopushexp = mkmodidexp bt_nopush_var
126    
127          fun mkregexp (id, s) =          fun mkregexp (id, s) =
128              A.APPexp (VARexp bt_register_var,              A.APPexp (VARexp bt_register_var,
129                        EU.TUPLEexp [VARexp bt_module_var,                        EU.TUPLEexp [VARexp bt_module_var,
# Line 124  Line 132 
132          val regexps = ref []          val regexps = ref []
133          val next = ref 0          val next = ref 0
134    
135          fun mkadd (id, s) =          fun newid s = let
136              (regexps := mkregexp (id, s) :: !regexps;              val id = !next
137               mkaddexp id)          in
138                next := id + 1;
139                regexps := mkregexp (id, s) :: !regexps;
140                id
141            end
142    
143            val mkadd = mkaddexp o newid
144            val mkpush = mkpushexp o newid
145            val mknopush = mknopushexp o newid
146    
147          fun VALdec (v, e) =          fun VALdec (v, e) =
148              A.VALdec [A.VB { pat = A.VARpat v, exp = e,              A.VALdec [A.VB { pat = A.VARpat v, exp = e,
# Line 141  Line 157 
157            | is_prim_exp (A.MARKexp (e, _)) = is_prim_exp e            | is_prim_exp (A.MARKexp (e, _)) = is_prim_exp e
158            | is_prim_exp _ = false            | is_prim_exp _ = false
159    
160          fun is_raise_exp (A.RAISEexp _) = true          fun is_raise_exp (A.RAISEexp (e, _)) =
161                let fun is_simple_exn (A.VARexp _) = true
162                      | is_simple_exn (A.CONexp _) = true
163                      | is_simple_exn (A.CONSTRAINTexp (e, _)) = is_simple_exn e
164                      | is_simple_exn (A.MARKexp (e, _)) = is_simple_exn e
165                      | is_simple_exn (A.RAISEexp (e, _)) =
166                        is_simple_exn e     (* !! *)
167                      | is_simple_exn _ = false
168                in
169                    is_simple_exn e
170                end
171            | is_raise_exp (A.MARKexp (e, _) |            | is_raise_exp (A.MARKexp (e, _) |
172                            A.CONSTRAINTexp (e, _) |                            A.CONSTRAINTexp (e, _) |
173                            A.SEQexp [e]) = is_raise_exp e                            A.SEQexp [e]) = is_raise_exp e
174            | is_raise_exp _ = false            | is_raise_exp _ = false
175    
176            fun mkDescr ((n, r), what) = let
177                fun name ((s, 0), a) = Symbol.name s :: a
178                  | name ((s, m), a) = Symbol.name s :: "[" ::
179                                       Int.toString (m + 1) :: "]" :: a
180                fun dot ([z], a) = name (z, a)
181                  | dot (h :: t, a) = dot (t, "." :: name (h, a))
182                  | dot ([], a) = impossible (what ^ ": no path")
183                val ms = matchstring r
184            in
185                concat (ms :: ": " :: dot (n, []))
186            end
187    
188          fun i_exp _ loc (A.RECORDexp l) =          fun i_exp _ loc (A.RECORDexp l) =
189              A.RECORDexp (map (fn (l, e) => (l, i_exp false loc e)) l)              A.RECORDexp (map (fn (l, e) => (l, i_exp false loc e)) l)
190            | i_exp _ loc (A.SELECTexp (l, e)) =            | i_exp _ loc (A.SELECTexp (l, e)) =
# Line 155  Line 193 
193              A.VECTORexp (map (i_exp false loc) l, t)              A.VECTORexp (map (i_exp false loc) l, t)
194            | i_exp tail loc (A.PACKexp (e, t, tcl)) =            | i_exp tail loc (A.PACKexp (e, t, tcl)) =
195              A.PACKexp (i_exp tail loc e, t, tcl)              A.PACKexp (i_exp tail loc e, t, tcl)
196            | i_exp tail loc (e as A.APPexp (f, a)) =            | i_exp tail loc (e as A.APPexp (f, a)) = let
197              if tail orelse is_prim_exp f then                  val mainexp =  A.APPexp (i_exp false loc f, i_exp false loc a)
198                  A.APPexp (i_exp false loc f, i_exp false loc a)              in
199                    if is_prim_exp f then mainexp
200                    else if tail then A.SEQexp [mknopush (mkDescr (loc, "GOTO")),
201                                                mainexp]
202              else let              else let
                     val mainexp = A.APPexp (i_exp false loc f,  
                                             i_exp false loc a)  
203                      val ty = Reconstruct.expType e                      val ty = Reconstruct.expType e
204                      val result = tmpvar ("tmpresult", ty)                      val result = tmpvar ("tmpresult", ty)
205                      val restore = tmpvar ("tmprestore", u_u_Ty)                      val restore = tmpvar ("tmprestore", u_u_Ty)
206                            val pushexp = mkpush (mkDescr (loc, "CALL"))
207                  in                  in
208                      LETexp (restore, pushexp,                      LETexp (restore, pushexp,
209                              LETexp (result, mainexp,                              LETexp (result, mainexp,
210                                      A.SEQexp [AUexp restore, VARexp result]))                                          A.SEQexp [AUexp restore,
211                                                      VARexp result]))
212                        end
213                  end                  end
214            | i_exp tail loc (A.HANDLEexp (e, A.HANDLER (A.FNexp (rl, t)))) = let            | i_exp tail loc (A.HANDLEexp (e, A.HANDLER (A.FNexp (rl, t)))) = let
215                  val restore = tmpvar ("tmprestore", u_u_Ty)                  val restore = tmpvar ("tmprestore", u_u_Ty)
# Line 185  Line 227 
227            | i_exp tail loc (A.CASEexp (e, rl, b)) =            | i_exp tail loc (A.CASEexp (e, rl, b)) =
228              A.CASEexp (i_exp false loc e, map (i_rule tail loc) rl, b)              A.CASEexp (i_exp false loc e, map (i_rule tail loc) rl, b)
229            | i_exp tail loc (A.FNexp (rl, t)) = let            | i_exp tail loc (A.FNexp (rl, t)) = let
230                  fun name ((s, 0), a) = Symbol.name s :: a                  val addexp = mkadd (mkDescr (loc, "FN"))
                   | name ((s, m), a) = Symbol.name s :: "[" ::  
                                      Int.toString (m + 1) :: "]" :: a  
                 fun dot ([z], a) = name (z, a)  
                   | dot (h :: t, a) = dot (t, "." :: name (h, a))  
                   | dot ([], a) = impossible "FNexp: no path"  
                 val (n, r) = loc  
                 val ms = matchstring r  
                 val descr = concat (ms :: ": " :: dot (n, []))  
                 val id = !next  
                 val _ = next := id + 1  
                 val addexp = mkadd (id, descr)  
231                  val arg = tmpvar ("fnvar", t)                  val arg = tmpvar ("fnvar", t)
232                  val rl' = map (i_rule true loc) rl                  val rl' = map (i_rule true loc) rl
233                  val re = let                  val re = let
# Line 305  Line 336 
336                                                  INTexp (!next))),                                                  INTexp (!next))),
337                                VALdec (bt_save_var, AUexp bt_save),                                VALdec (bt_save_var, AUexp bt_save),
338                                VALdec (bt_push_var, AUexp bt_push),                                VALdec (bt_push_var, AUexp bt_push),
339                                  VALdec (bt_nopush_var, AUexp bt_nopush),
340                                VALdec (bt_register_var, AUexp bt_register),                                VALdec (bt_register_var, AUexp bt_register),
341                                VALdec (bt_add_var,                                VALdec (bt_add_var,
342                                        A.SEQexp (!regexps @ [AUexp bt_add]))],                                        A.SEQexp (!regexps @ [AUexp bt_add]))],
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  
Powered By FusionForge