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 1649 - (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 : mblume 1350 Array.copy{di=0, dst=new, src = old};
77 : monnier 416 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 : mblume 1649 fun newlines s =
95 :     CharVector.foldl (fn (#"\n", n) => n + 1 | (_, n) => n) 0 s
96 : monnier 416
97 :     fun register names = let
98 : monnier 498 val list = !units
99 :     val UNIT { base, size, ... } = List.hd list
100 :     val count = newlines names
101 :     val a = Array.array(count,0)
102 :     val b = base+size
103 :     in
104 :     increase(b+count);
105 :     units := UNIT{base=b,size=count,counts=a,names=names}::list;
106 :     (b,a,current)
107 :     end
108 : monnier 416
109 :     val _ = Core.profile_register := register;
110 :    
111 :     fun reset() = let
112 :     fun zero a = Array.modify (fn _ => 0) a
113 :     in
114 :     resetTimeArray();
115 :     List.app (fn UNIT{counts,...}=> zero counts) (!units)
116 :     end
117 :    
118 :     (* space profiling hooks *)
119 :     val spaceProfiling = ref false
120 :     val spaceProfRegister :
121 :     (Unsafe.Object.object * string -> Unsafe.Object.object) ref =
122 :     Unsafe.cast Core.profile_sregister
123 :    
124 :     end
125 :    
126 :    

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