Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/system/Basis/Implementation/NJ/prof-control.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Basis/Implementation/NJ/prof-control.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 499 - (view) (download)

1 : monnier 416 (* prof-control.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 AT&T Research.
4 :     *
5 :     * This structure implements the interface to the run-time system's profiling
6 :     * support library. It is not meant for general use.
7 :     *
8 :     *)
9 :    
10 :     structure ProfControl : PROF_CONTROL =
11 :     struct
12 :    
13 :     structure CI = Unsafe.CInterface
14 :    
15 :     val setTimer : bool -> unit
16 :     = CI.c_function "SMLNJ-Prof" "setTimer"
17 :     val getQuantum : unit -> int
18 :     = CI.c_function "SMLNJ-Prof" "getQuantum"
19 :     val setTimeArray' : int array option -> unit
20 :     = CI.c_function "SMLNJ-Prof" "setTimeArray"
21 :    
22 :     val profMode = ref false (* controls profile instrumentation *)
23 :     val timingMode = ref false (* controls profile timer *)
24 :    
25 :     val times = ref (Array.array(0, 0))
26 :    
27 :     fun getTimingMode () = !timingMode
28 :    
29 :     (* set the timer count array *)
30 :     fun setTimeArray arr = (
31 :     if !timingMode then setTimeArray'(SOME arr) else ();
32 :     times := arr)
33 :    
34 :     fun getTimeArray () = !times
35 :    
36 :     fun resetTimeArray () = let
37 :     fun zero a = Array.modify (fn _ => 0) a
38 :     in
39 :     zero (!times)
40 :     end
41 :    
42 :     fun profileOn () = if !timingMode
43 :     then ()
44 :     else (timingMode := true; setTimeArray'(SOME(!times)); setTimer true)
45 :    
46 :     fun profileOff () = if !timingMode
47 :     then (setTimer false; setTimeArray' NONE; timingMode := false)
48 :     else ()
49 :    
50 :     datatype compunit = UNIT of {
51 :     base: int,
52 :     size: int,
53 :     counts: int Array.array,
54 :     names: string
55 :     }
56 :    
57 :     val runTimeIndex = 0
58 :     val minorGCIndex = 1
59 :     val majorGCIndex = 2
60 :     val otherIndex = 3
61 :     val compileIndex = 4
62 :     val numPredefIndices = 5
63 :    
64 :     val current : int ref = Core.Assembly.profCurrent
65 :     val _ = (
66 :     setTimeArray(Array.array(numPredefIndices, 0));
67 :     current := otherIndex)
68 :    
69 :     fun increase n = let
70 :     val old = getTimeArray()
71 :     in
72 :     if n <= Array.length old
73 :     then ()
74 :     else let val new = Array.array(n+n, 0)
75 :     in
76 :     Array.copy{di=0, dst=new, len=NONE, si=0, src = old};
77 :     setTimeArray new
78 :     end
79 :     end
80 :    
81 :     val units = ref [UNIT{
82 :     base = 0,
83 :     size = numPredefIndices,
84 :     counts = Array.array(numPredefIndices, 0),
85 :     names = "\
86 :     \Run-time System\n\
87 :     \Minor GC\n\
88 :     \Major GC\n\
89 :     \Other\n\
90 :     \Compilation\n"
91 :     }];
92 :    
93 :     (* count the number of newlines in a string *)
94 :     fun newlines s = let
95 :     fun notNL #"\n" = false | notNL _ = true
96 :     fun f (ss, count) = let
97 :     val ss = Substring.dropl notNL ss
98 :     in
99 :     if Substring.isEmpty ss
100 :     then count
101 :     else f (Substring.triml 1 ss, count+1)
102 :     end
103 :     in
104 :     f (Substring.all s, 0)
105 :     end
106 :    
107 :     fun register names = let
108 : monnier 498 val list = !units
109 :     val UNIT { base, size, ... } = List.hd list
110 :     val count = newlines names
111 :     val a = Array.array(count,0)
112 :     val b = base+size
113 :     in
114 :     increase(b+count);
115 :     units := UNIT{base=b,size=count,counts=a,names=names}::list;
116 :     (b,a,current)
117 :     end
118 : monnier 416
119 :     val _ = Core.profile_register := register;
120 :    
121 :     fun reset() = let
122 :     fun zero a = Array.modify (fn _ => 0) a
123 :     in
124 :     resetTimeArray();
125 :     List.app (fn UNIT{counts,...}=> zero counts) (!units)
126 :     end
127 :    
128 :     (* space profiling hooks *)
129 :     val spaceProfiling = ref false
130 :     val spaceProfRegister :
131 :     (Unsafe.Object.object * string -> Unsafe.Object.object) ref =
132 :     Unsafe.cast Core.profile_sregister
133 :    
134 :     end
135 :    
136 :    

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