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/Basis/Implementation/NJ/internals.sml
ViewVC logotype

Diff of /sml/trunk/src/system/Basis/Implementation/NJ/internals.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 6  Line 6 
6   * features that need to be exposed outside the boot directory.   * features that need to be exposed outside the boot directory.
7   *)   *)
8    
9  structure Internals : INTERNALS =  structure Internals : INTERNALS = struct
   struct  
10    
11      structure CleanUp = CleanUp      structure CleanUp = CleanUp
12      structure ProfControl = ProfControl      structure ProfControl = ProfControl
# Line 21  Line 20 
20    
21      val resetTimers = InternalTimer.resetTimers      val resetTimers = InternalTimer.resetTimers
22    
23      structure BTrace = struct      structure TDP = struct
24          local          type plugin = Core.tdp_plugin
25              fun mode0 (_ : bool option) : bool =  
26                  raise Fail "no btrace module hooked in"          val active_plugins = Core.tdp_active_plugins
27              val hook = ref { reset = fn () => (), mode = mode0 }  
28          in          fun reserve n = Core.tdp_reserve n
29              fun install { corefns, reset, mode } =          fun reset () = Core.tdp_reset ()
30                  (hook := { reset = reset, mode = mode };  
                  Core.tdp_install corefns)  
             fun reset () = #reset (!hook) ()  
             fun mode x = #mode (!hook) x  
         end  
         fun report () = Core.tdp_report () ()  
         fun save () = Core.tdp_save () ()  
         local  
             exception BTraceTriggered of unit -> string list  
         in  
             (* The following function must be compiled with BT-instrumentation  
              * turned off because it relies on its exception handler to _not_  
              * restore the bt-history! *)  
             fun bthandle { work, hdl } = let  
                 val restore = save ()  
             in  
                 work ()  
                 handle e as BTraceTriggered do_report' =>  
                        (restore (); hdl (e, do_report' ()))  
                      | e => let  
                            val do_report = report ()  
                        in  
                            restore ();  
                            hdl (e, do_report ())  
                        end  
             end  
             fun trigger () = raise BTraceTriggered (report ())  
31              val idk_entry_point = Core.tdp_idk_entry_point              val idk_entry_point = Core.tdp_idk_entry_point
32              val idk_tail_call = Core.tdp_idk_tail_call              val idk_tail_call = Core.tdp_idk_tail_call
33              val idk_non_tail_call = Core.tdp_idk_non_tail_call              val idk_non_tail_call = Core.tdp_idk_non_tail_call
34    
35            val mode = ref false
36        end
37    
38        structure BTrace = struct
39            local
40                val te_hook = ref (fn () => Fail "bogus backtrace exception")
41            in
42                fun install { plugin, mktriggerexn } =
43                    (te_hook := mktriggerexn;
44                     TDP.active_plugins := plugin :: !TDP.active_plugins)
45                fun trigger () = raise (!te_hook())
46          end          end
47      end      end
48    
49    end;  end

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