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/system/smlnj/init/core.sml
ViewVC logotype

Diff of /sml/trunk/src/system/smlnj/init/core.sml

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

revision 1651, Wed Oct 13 21:37:30 2004 UTC revision 1652, Thu Oct 14 22:38:54 2004 UTC
# Line 259  Line 259 
259                end)                end)
260    
261          (* trace/debug/profile generation hooks *)          (* trace/debug/profile generation hooks *)
262            type tdp_plugin =
263                 { name     : string,       (* name identifying plugin *)
264                   save     : unit -> unit -> unit,
265                   push     : int * int -> unit -> unit,
266                   nopush   : int * int -> unit,
267                   enter    : int * int -> unit,
268                   register : int * int * int * string -> unit }
269    
270          local          local
271              val hook =              val next = ref 0
272                  ref { reserve = fn (nfct: int) => 0,              val hook = ref [] : tdp_plugin list ref
273                        save = fn () => fn () => (),  
                       push = fn (module: int, id: int) => fn () => (),  
                       enter = fn (module: int, id: int) => (),  
                       nopush = fn (module: int, id: int) => (),  
                       register = fn (module: int, id_kind: int,  
                                      id: int, s: string) => (),  
                       report = fn () => fn () => ([]: string list) }  
274              val ! = InLine.!              val ! = InLine.!
275              infix :=              infix :=
276              val op := = InLine.:=              val op := = InLine.:=
277    
278                fun runwith a f = f a
279    
280                fun map f = let
281                    fun loop [] = []
282                      | loop (h :: t) = f h :: loop t
283                in
284                    loop
285                end
286    
287                fun app f = let
288                    fun loop [] = ()
289                      | loop (h :: t) = (f h; loop t)
290                in
291                    loop
292                end
293    
294                fun revmap f l = let
295                    fun loop ([], a) = a
296                      | loop (h :: t, a) = loop (t, f h :: a)
297                in
298                    loop (l, [])
299                end
300    
301                fun onestage sel () =
302                    let val fns = map sel (!hook)
303                    in
304                        fn arg => app (runwith arg) fns
305                    end
306    
307                fun twostage sel () =
308                    let val stage1_fns = map sel (!hook)
309                    in
310                        fn arg =>
311                           let val stage2_fns = revmap (runwith arg) stage1_fns
312          in          in
313                               fn () => app (runwith ()) stage2_fns
314                           end
315                    end
316            in
317                fun tdp_reserve n = let val r = !next in next := r + n; r end
318                fun tdp_reset () = next := 0
319    
320              (* pre-defined kinds of IDs (to be passed to "register") *)              (* pre-defined kinds of IDs (to be passed to "register") *)
321              val tdp_idk_entry_point = 0              val tdp_idk_entry_point = 0
322              val tdp_idk_non_tail_call = 1              val tdp_idk_non_tail_call = 1
323              val tdp_idk_tail_call = 2              val tdp_idk_tail_call = 2
324    
325              (* entry points for use by BT-annotated modules: *)              val tdp_save = twostage #save
326              fun tdp_reserve () = #reserve (!hook)              val tdp_push = twostage #push
327              fun tdp_save () = #save (!hook)              val tdp_nopush = onestage #nopush
328              fun tdp_push () = #push (!hook)              val tdp_enter = onestage #enter
329              fun tdp_nopush () = #nopush (!hook)              val tdp_register = onestage #register
330              fun tdp_enter () = #enter (!hook)  
331              fun tdp_register () = #register (!hook)              val tdp_active_plugins = hook
             fun tdp_report () = #report (!hook)  
             (* to install an implementation for back-tracing: *)  
             fun tdp_install r = hook := r  
332          end          end
333    
334          val assign = ( InLine.:= )          val assign = ( InLine.:= )

Legend:
Removed from v.1651  
changed lines
  Added in v.1652

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