1 /* record-profile.c -- very basic Lisp profiler
2
3 Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
4
5 $Id$
6
7 This file is part of librep.
8
9 librep is free software; you can redistribute it and/or modify it
10 under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2, or (at your option)
12 any later version.
13
14 librep is distributed in the hope that it will be useful, but
15 WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with librep; see the file COPYING. If not, write to
21 the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
22
23 /* Commentary:
24
25 Hook into the interrupt-checking code to record the current
26 backtrace statistics. Uses SIGPROF to tell the lisp system when it
27 should interrupt (can't run the profiler off the signal itself,
28 since data would need to be allocated from the signal handler) */
29
30 #define _GNU_SOURCE
31
32 /* AIX requires this to be the first thing in the file. */
33 #include <config.h>
34 #ifdef __GNUC__
35 # define alloca __builtin_alloca
36 #else
37 # if HAVE_ALLOCA_H
38 # include <alloca.h>
39 # else
40 # ifdef _AIX
41 #pragma alloca
42 # else
43 # ifndef alloca /* predefined by HP cc +Olibcalls */
44 char *alloca ();
45 # endif
46 # endif
47 # endif
48 #endif
49
50 #include "repint.h"
51 #include <signal.h>
52 #include <time.h>
53
54 #ifdef HAVE_UNISTD_H
55 # include <unistd.h>
56 #endif
57
58 #ifdef HAVE_SYS_TIME_H
59 # include <sys/time.h>
60 #endif
61
62 static repv profile_table;
63 static rep_bool profiling;
64
65 static void (*chained_test_interrupt)(void);
66
67 static int profile_interval = 10; /* microseconds */
68
69
70 /* SIGPROF handling */
71
72 #ifdef HAVE_SETITIMER
73 static RETSIGTYPE
sigprof_handler(int unused)74 sigprof_handler (int unused)
75 {
76 /* force an interrupt */
77 rep_test_int_counter = rep_test_int_period;
78 }
79 #endif
80
81 static void
set_timer(void)82 set_timer (void)
83 {
84 #ifdef HAVE_SETITIMER
85 struct itimerval it, tem;
86 it.it_interval.tv_usec = 0;
87 it.it_interval.tv_sec = 0;
88 it.it_value.tv_usec = profile_interval % 1000000;
89 it.it_value.tv_sec = profile_interval / 1000000;
90 setitimer (ITIMER_PROF, &it, &tem);
91 signal (SIGPROF, sigprof_handler);
92 #endif
93 }
94
95 static void
clear_timer(void)96 clear_timer (void)
97 {
98 #ifdef HAVE_SETITIMER
99 signal (SIGPROF, SIG_IGN);
100 #endif
101 }
102
103
104 /* profile recording */
105
106 static void
test_interrupt(void)107 test_interrupt (void)
108 {
109 if (profiling)
110 {
111 repv *seen = alloca (rep_max_lisp_depth * sizeof (repv));
112 struct rep_Call *c;
113 int seen_i = 0;
114 for (c = rep_call_stack; c != 0 && c->fun != Qnil; c = c->next)
115 {
116 repv name;
117 switch (rep_TYPE (c->fun))
118 {
119 case rep_Subr0: case rep_Subr1: case rep_Subr2: case rep_Subr3:
120 case rep_Subr4: case rep_Subr5: case rep_SubrN:
121 name = rep_XSUBR (c->fun)->name;
122 break;
123
124 case rep_Funarg:
125 name = rep_FUNARG (c->fun)->name;
126 break;
127
128 default:
129 continue;
130 }
131 if (rep_STRINGP (name))
132 {
133 repv tem;
134 int j;
135
136 name = Fintern (name, Qnil);
137 for (j = 0; j < seen_i; j++)
138 {
139 if (seen[j] == name)
140 goto skip;
141 }
142
143 tem = F_structure_ref (profile_table, name);
144 if (rep_VOIDP (tem))
145 tem = Fcons (rep_MAKE_INT (0), rep_MAKE_INT (0));
146 if (c == rep_call_stack)
147 rep_CAR (tem) = rep_MAKE_INT (rep_INT (rep_CAR (tem)) + 1);
148 rep_CDR (tem) = rep_MAKE_INT (rep_INT (rep_CDR (tem)) + 1);
149 Fstructure_define (profile_table, name, tem);
150
151 seen[seen_i++] = name;
152 }
153 skip: {}
154 }
155 set_timer ();
156 }
157 (*chained_test_interrupt) ();
158 }
159
160
161 /* interface */
162
163 DEFUN ("start-profiler", Fstart_profiler, Sstart_profiler, (void), rep_Subr0)
164 {
165 profile_table = Fmake_structure (Qnil, Qnil, Qnil, Qnil);
166 profiling = rep_TRUE;
167 set_timer ();
168 return Qt;
169 }
170
171 DEFUN ("stop-profiler", Fstop_profiler, Sstop_profiler, (void), rep_Subr0)
172 {
173 profiling = rep_FALSE;
174 clear_timer ();
175 return Qt;
176 }
177
178 DEFUN ("fetch-profile", Ffetch_profile, Sfetch_profile, (void), rep_Subr0)
179 {
180 return profile_table ? profile_table : Qnil;
181 }
182
183 DEFUN ("profile-interval", Fprofile_interval,
184 Sprofile_interval, (repv arg), rep_Subr1)
185 {
186 repv ret = rep_MAKE_INT (profile_interval);
187 if (rep_INTP (arg) && rep_INT (arg) > 0)
188 profile_interval = rep_INT (arg);
189 return ret;
190 }
191
192
193 /* init */
194
195 repv
rep_dl_init(void)196 rep_dl_init (void)
197 {
198 repv tem = rep_push_structure ("rep.lang.record-profile");
199
200 rep_ADD_SUBR (Sstart_profiler);
201 rep_ADD_SUBR (Sstop_profiler);
202 rep_ADD_SUBR (Sfetch_profile);
203 rep_ADD_SUBR (Sprofile_interval);
204 rep_mark_static (&profile_table);
205
206 #ifdef HAVE_SETITIMER
207 signal (SIGPROF, SIG_IGN);
208 #endif
209
210 chained_test_interrupt = rep_test_int_fun;
211 rep_test_int_fun = test_interrupt;
212
213 return rep_pop_structure (tem);
214 }
215