Commit | Line | Data |
---|---|---|
146174a9 | 1 | #define PERL_NO_GET_CONTEXT |
583a019e GS |
2 | #include "EXTERN.h" |
3 | #include "perl.h" | |
4 | #include "XSUB.h" | |
5 | ||
94277a97 | 6 | /* define DBG_SUB to cause a warning on each subroutine entry. */ |
7399586d | 7 | /*#define DBG_SUB 1 */ |
94277a97 ST |
8 | |
9 | /* define DBG_TIMER to cause a warning when the timer is turned on and off. */ | |
10 | /*#define DBG_TIMER 1 */ | |
583a019e GS |
11 | |
12 | #ifdef DBG_SUB | |
94277a97 ST |
13 | # define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(A) |
14 | void | |
15 | dprof_dbg_sub_notify(SV *Sub) { | |
16 | CV *cv = INT2PTR(CV*,SvIVX(Sub)); | |
17 | GV *gv = cv ? CvGV(cv) : NULL; | |
18 | if (cv && gv) { | |
19 | warn("XS DBsub(%s::%s)\n", | |
20 | ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) ? | |
21 | HvNAME(GvSTASH(gv)) : "(null)"), | |
22 | GvNAME(gv)); | |
23 | } else { | |
24 | warn("XS DBsub(unknown) at %x", Sub); | |
25 | } | |
26 | } | |
583a019e | 27 | #else |
94277a97 | 28 | # define DBG_SUB_NOTIFY(A) /* nothing */ |
583a019e GS |
29 | #endif |
30 | ||
94277a97 | 31 | |
583a019e | 32 | #ifdef DBG_TIMER |
146174a9 | 33 | # define DBG_TIMER_NOTIFY(A) warn(A) |
583a019e GS |
34 | #else |
35 | # define DBG_TIMER_NOTIFY(A) /* nothing */ | |
36 | #endif | |
37 | ||
583a019e GS |
38 | /* HZ == clock ticks per second */ |
39 | #ifdef VMS | |
552e38a9 | 40 | # define HZ ((I32)CLK_TCK) |
583a019e GS |
41 | # define DPROF_HZ HZ |
42 | # include <starlet.h> /* prototype for sys$gettim() */ | |
3e4b306a | 43 | # include <lib$routines.h> |
146174a9 | 44 | # define Times(ptr) (dprof_times(aTHX_ ptr)) |
583a019e GS |
45 | #else |
46 | # ifndef HZ | |
47 | # ifdef CLK_TCK | |
552e38a9 | 48 | # define HZ ((I32)CLK_TCK) |
583a019e GS |
49 | # else |
50 | # define HZ 60 | |
51 | # endif | |
52 | # endif | |
53 | # ifdef OS2 /* times() has significant overhead */ | |
146174a9 | 54 | # define Times(ptr) (dprof_times(aTHX_ ptr)) |
583a019e GS |
55 | # define INCL_DOSPROFILE |
56 | # define INCL_DOSERRORS | |
57 | # include <os2.h> | |
58 | # define toLongLong(arg) (*(long long*)&(arg)) | |
146174a9 | 59 | # define DPROF_HZ g_dprof_ticks |
583a019e GS |
60 | # else |
61 | # define Times(ptr) (times(ptr)) | |
62 | # define DPROF_HZ HZ | |
63 | # endif | |
64 | #endif | |
65 | ||
66 | XS(XS_Devel__DProf_END); /* used by prof_mark() */ | |
67 | ||
583a019e GS |
68 | /* Everything is built on times(2). See its manpage for a description |
69 | * of the timings. | |
70 | */ | |
71 | ||
583a019e GS |
72 | union prof_any { |
73 | clock_t tms_utime; /* cpu time spent in user space */ | |
74 | clock_t tms_stime; /* cpu time spent in system */ | |
75 | clock_t realtime; /* elapsed real time, in ticks */ | |
76 | char *name; | |
77 | U32 id; | |
78 | opcode ptype; | |
79 | }; | |
80 | ||
81 | typedef union prof_any PROFANY; | |
82 | ||
146174a9 CB |
83 | typedef struct { |
84 | U32 dprof_ticks; | |
85 | char* out_file_name; /* output file (defaults to tmon.out) */ | |
86 | PerlIO* fp; /* pointer to tmon.out file */ | |
4f4e7967 | 87 | Off_t TIMES_LOCATION; /* Where in the file to store the time totals */ |
146174a9 CB |
88 | int SAVE_STACK; /* How much data to buffer until end of run */ |
89 | int prof_pid; /* pid of profiled process */ | |
90 | struct tms prof_start; | |
91 | struct tms prof_end; | |
92 | clock_t rprof_start; /* elapsed real time ticks */ | |
93 | clock_t rprof_end; | |
94 | clock_t wprof_u; | |
95 | clock_t wprof_s; | |
96 | clock_t wprof_r; | |
97 | clock_t otms_utime; | |
98 | clock_t otms_stime; | |
99 | clock_t orealtime; | |
100 | PROFANY* profstack; | |
101 | int profstack_max; | |
102 | int profstack_ix; | |
103 | HV* cv_hash; | |
104 | U32 total; | |
105 | U32 lastid; | |
106 | U32 default_perldb; | |
425d70b4 | 107 | UV depth; |
146174a9 CB |
108 | #ifdef OS2 |
109 | ULONG frequ; | |
110 | long long start_cnt; | |
111 | #endif | |
112 | #ifdef PERL_IMPLICIT_CONTEXT | |
113 | # define register | |
114 | pTHX; | |
115 | # undef register | |
116 | #endif | |
117 | } prof_state_t; | |
118 | ||
119 | prof_state_t g_prof_state; | |
120 | ||
121 | #define g_dprof_ticks g_prof_state.dprof_ticks | |
122 | #define g_out_file_name g_prof_state.out_file_name | |
123 | #define g_fp g_prof_state.fp | |
124 | #define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION | |
125 | #define g_SAVE_STACK g_prof_state.SAVE_STACK | |
126 | #define g_prof_pid g_prof_state.prof_pid | |
127 | #define g_prof_start g_prof_state.prof_start | |
128 | #define g_prof_end g_prof_state.prof_end | |
129 | #define g_rprof_start g_prof_state.rprof_start | |
130 | #define g_rprof_end g_prof_state.rprof_end | |
131 | #define g_wprof_u g_prof_state.wprof_u | |
132 | #define g_wprof_s g_prof_state.wprof_s | |
133 | #define g_wprof_r g_prof_state.wprof_r | |
134 | #define g_otms_utime g_prof_state.otms_utime | |
135 | #define g_otms_stime g_prof_state.otms_stime | |
136 | #define g_orealtime g_prof_state.orealtime | |
137 | #define g_profstack g_prof_state.profstack | |
138 | #define g_profstack_max g_prof_state.profstack_max | |
139 | #define g_profstack_ix g_prof_state.profstack_ix | |
140 | #define g_cv_hash g_prof_state.cv_hash | |
141 | #define g_total g_prof_state.total | |
142 | #define g_lastid g_prof_state.lastid | |
143 | #define g_default_perldb g_prof_state.default_perldb | |
144 | #define g_depth g_prof_state.depth | |
145 | #ifdef PERL_IMPLICIT_CONTEXT | |
146 | # define g_THX g_prof_state.aTHX | |
147 | #endif | |
148 | #ifdef OS2 | |
149 | # define g_frequ g_prof_state.frequ | |
150 | # define g_start_cnt g_prof_state.start_cnt | |
151 | #endif | |
583a019e | 152 | |
146174a9 CB |
153 | clock_t |
154 | dprof_times(pTHX_ struct tms *t) | |
583a019e | 155 | { |
146174a9 CB |
156 | #ifdef OS2 |
157 | ULONG rc; | |
158 | QWORD cnt; | |
cb50131a | 159 | STRLEN n_a; |
146174a9 CB |
160 | |
161 | if (!g_frequ) { | |
162 | if (CheckOSError(DosTmrQueryFreq(&g_frequ))) | |
cb50131a | 163 | croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a)); |
146174a9 CB |
164 | else |
165 | g_frequ = g_frequ/DPROF_HZ; /* count per tick */ | |
166 | if (CheckOSError(DosTmrQueryTime(&cnt))) | |
167 | croak("DosTmrQueryTime: %s", | |
cb50131a | 168 | SvPV(perl_get_sv("!",TRUE), n_a)); |
146174a9 | 169 | g_start_cnt = toLongLong(cnt); |
583a019e | 170 | } |
146174a9 CB |
171 | |
172 | if (CheckOSError(DosTmrQueryTime(&cnt))) | |
cb50131a | 173 | croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a)); |
146174a9 CB |
174 | t->tms_stime = 0; |
175 | return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); | |
176 | #else /* !OS2 */ | |
177 | # ifdef VMS | |
178 | clock_t retval; | |
179 | /* Get wall time and convert to 10 ms intervals to | |
180 | * produce the return value dprof expects */ | |
181 | # if defined(__DECC) && defined (__ALPHA) | |
182 | # include <ints.h> | |
183 | uint64 vmstime; | |
184 | _ckvmssts(sys$gettim(&vmstime)); | |
185 | vmstime /= 100000; | |
186 | retval = vmstime & 0x7fffffff; | |
187 | # else | |
188 | /* (Older hw or ccs don't have an atomic 64-bit type, so we | |
189 | * juggle 32-bit ints (and a float) to produce a time_t result | |
190 | * with minimal loss of information.) */ | |
191 | long int vmstime[2],remainder,divisor = 100000; | |
192 | _ckvmssts(sys$gettim((unsigned long int *)vmstime)); | |
193 | vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ | |
194 | _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); | |
195 | # endif | |
196 | /* Fill in the struct tms using the CRTL routine . . .*/ | |
197 | times((tbuffer_t *)t); | |
198 | return (clock_t) retval; | |
199 | # else /* !VMS && !OS2 */ | |
200 | return times(t); | |
201 | # endif | |
202 | #endif | |
203 | } | |
583a019e GS |
204 | |
205 | static void | |
146174a9 | 206 | prof_dumpa(pTHX_ opcode ptype, U32 id) |
583a019e | 207 | { |
146174a9 CB |
208 | if (ptype == OP_LEAVESUB) { |
209 | PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id); | |
210 | } | |
211 | else if(ptype == OP_ENTERSUB) { | |
212 | PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id); | |
213 | } | |
214 | else if(ptype == OP_GOTO) { | |
215 | PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id); | |
216 | } | |
217 | else if(ptype == OP_DIE) { | |
218 | PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id); | |
219 | } | |
220 | else { | |
221 | PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype); | |
583a019e GS |
222 | } |
223 | } | |
224 | ||
225 | static void | |
146174a9 | 226 | prof_dumps(pTHX_ U32 id, char *pname, char *gname) |
583a019e | 227 | { |
146174a9 | 228 | PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); |
583a019e GS |
229 | } |
230 | ||
583a019e | 231 | static void |
146174a9 | 232 | prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime) |
583a019e | 233 | { |
146174a9 | 234 | PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); |
583a019e GS |
235 | } |
236 | ||
237 | static void | |
146174a9 | 238 | prof_dump_until(pTHX_ long ix) |
583a019e GS |
239 | { |
240 | long base = 0; | |
241 | struct tms t1, t2; | |
242 | clock_t realtime1, realtime2; | |
243 | ||
244 | realtime1 = Times(&t1); | |
245 | ||
146174a9 CB |
246 | while (base < ix) { |
247 | opcode ptype = g_profstack[base++].ptype; | |
583a019e | 248 | if (ptype == OP_TIME) { |
146174a9 CB |
249 | long tms_utime = g_profstack[base++].tms_utime; |
250 | long tms_stime = g_profstack[base++].tms_stime; | |
251 | long realtime = g_profstack[base++].realtime; | |
252 | ||
253 | prof_dumpt(aTHX_ tms_utime, tms_stime, realtime); | |
254 | } | |
255 | else if (ptype == OP_GV) { | |
256 | U32 id = g_profstack[base++].id; | |
257 | char *pname = g_profstack[base++].name; | |
258 | char *gname = g_profstack[base++].name; | |
259 | ||
260 | prof_dumps(aTHX_ id, pname, gname); | |
261 | } | |
262 | else { | |
263 | U32 id = g_profstack[base++].id; | |
264 | prof_dumpa(aTHX_ ptype, id); | |
583a019e GS |
265 | } |
266 | } | |
146174a9 | 267 | PerlIO_flush(g_fp); |
583a019e GS |
268 | realtime2 = Times(&t2); |
269 | if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime | |
270 | || t1.tms_stime != t2.tms_stime) { | |
146174a9 CB |
271 | g_wprof_r += realtime2 - realtime1; |
272 | g_wprof_u += t2.tms_utime - t1.tms_utime; | |
273 | g_wprof_s += t2.tms_stime - t1.tms_stime; | |
274 | ||
275 | PerlIO_printf(g_fp,"+ & Devel::DProf::write\n"); | |
276 | PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", | |
277 | /* The (IV) casts are one possibility: | |
278 | * the Painfully Correct Way would be to | |
279 | * have Clock_t_f. */ | |
280 | (IV)(t2.tms_utime - t1.tms_utime), | |
281 | (IV)(t2.tms_stime - t1.tms_stime), | |
282 | (IV)(realtime2 - realtime1)); | |
283 | PerlIO_printf(g_fp,"- & Devel::DProf::write\n"); | |
284 | g_otms_utime = t2.tms_utime; | |
285 | g_otms_stime = t2.tms_stime; | |
286 | g_orealtime = realtime2; | |
287 | PerlIO_flush(g_fp); | |
583a019e GS |
288 | } |
289 | } | |
290 | ||
583a019e | 291 | static void |
146174a9 | 292 | prof_mark(pTHX_ opcode ptype) |
583a019e | 293 | { |
146174a9 CB |
294 | struct tms t; |
295 | clock_t realtime, rdelta, udelta, sdelta; | |
146174a9 CB |
296 | U32 id; |
297 | SV *Sub = GvSV(PL_DBsub); /* name of current sub */ | |
298 | ||
299 | if (g_SAVE_STACK) { | |
300 | if (g_profstack_ix + 5 > g_profstack_max) { | |
301 | g_profstack_max = g_profstack_max * 3 / 2; | |
302 | Renew(g_profstack, g_profstack_max, PROFANY); | |
303 | } | |
304 | } | |
583a019e | 305 | |
146174a9 CB |
306 | realtime = Times(&t); |
307 | rdelta = realtime - g_orealtime; | |
308 | udelta = t.tms_utime - g_otms_utime; | |
309 | sdelta = t.tms_stime - g_otms_stime; | |
310 | if (rdelta || udelta || sdelta) { | |
311 | if (g_SAVE_STACK) { | |
312 | g_profstack[g_profstack_ix++].ptype = OP_TIME; | |
313 | g_profstack[g_profstack_ix++].tms_utime = udelta; | |
314 | g_profstack[g_profstack_ix++].tms_stime = sdelta; | |
315 | g_profstack[g_profstack_ix++].realtime = rdelta; | |
316 | } | |
317 | else { /* Write it to disk now so's not to eat up core */ | |
318 | if (g_prof_pid == (int)getpid()) { | |
319 | prof_dumpt(aTHX_ udelta, sdelta, rdelta); | |
320 | PerlIO_flush(g_fp); | |
583a019e | 321 | } |
583a019e | 322 | } |
146174a9 CB |
323 | g_orealtime = realtime; |
324 | g_otms_stime = t.tms_stime; | |
325 | g_otms_utime = t.tms_utime; | |
326 | } | |
583a019e | 327 | |
146174a9 CB |
328 | { |
329 | SV **svp; | |
330 | char *gname, *pname; | |
331 | CV *cv; | |
332 | ||
333 | cv = INT2PTR(CV*,SvIVX(Sub)); | |
334 | svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE); | |
335 | if (!SvOK(*svp)) { | |
336 | GV *gv = CvGV(cv); | |
337 | ||
338 | sv_setiv(*svp, id = ++g_lastid); | |
339 | pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) | |
340 | ? HvNAME(GvSTASH(gv)) | |
341 | : "(null)"); | |
342 | gname = GvNAME(gv); | |
343 | if (CvXSUB(cv) == XS_Devel__DProf_END) | |
344 | return; | |
345 | if (g_SAVE_STACK) { /* Store it for later recording -JH */ | |
346 | g_profstack[g_profstack_ix++].ptype = OP_GV; | |
347 | g_profstack[g_profstack_ix++].id = id; | |
348 | g_profstack[g_profstack_ix++].name = pname; | |
349 | g_profstack[g_profstack_ix++].name = gname; | |
350 | } | |
351 | else { /* Write it to disk now so's not to eat up core */ | |
352 | /* Only record the parent's info */ | |
353 | if (g_prof_pid == (int)getpid()) { | |
354 | prof_dumps(aTHX_ id, pname, gname); | |
355 | PerlIO_flush(g_fp); | |
583a019e | 356 | } |
146174a9 CB |
357 | else |
358 | PL_perldb = 0; /* Do not debug the kid. */ | |
583a019e GS |
359 | } |
360 | } | |
146174a9 CB |
361 | else { |
362 | id = SvIV(*svp); | |
363 | } | |
364 | } | |
583a019e | 365 | |
146174a9 CB |
366 | g_total++; |
367 | if (g_SAVE_STACK) { /* Store it for later recording -JH */ | |
368 | g_profstack[g_profstack_ix++].ptype = ptype; | |
369 | g_profstack[g_profstack_ix++].id = id; | |
370 | ||
371 | /* Only record the parent's info */ | |
372 | if (g_SAVE_STACK < g_profstack_ix) { | |
373 | if (g_prof_pid == (int)getpid()) | |
374 | prof_dump_until(aTHX_ g_profstack_ix); | |
375 | else | |
376 | PL_perldb = 0; /* Do not debug the kid. */ | |
377 | g_profstack_ix = 0; | |
378 | } | |
379 | } | |
380 | else { /* Write it to disk now so's not to eat up core */ | |
583a019e | 381 | |
146174a9 CB |
382 | /* Only record the parent's info */ |
383 | if (g_prof_pid == (int)getpid()) { | |
384 | prof_dumpa(aTHX_ ptype, id); | |
385 | PerlIO_flush(g_fp); | |
386 | } | |
387 | else | |
388 | PL_perldb = 0; /* Do not debug the kid. */ | |
389 | } | |
583a019e GS |
390 | } |
391 | ||
583a019e GS |
392 | #ifdef PL_NEEDED |
393 | # define defstash PL_defstash | |
394 | #endif | |
395 | ||
396 | /* Counts overhead of prof_mark and extra XS call. */ | |
397 | static void | |
146174a9 | 398 | test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) |
583a019e | 399 | { |
583a019e GS |
400 | CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); |
401 | int i, j, k = 0; | |
146174a9 | 402 | HV *oldstash = PL_curstash; |
583a019e | 403 | struct tms t1, t2; |
9c5ffd7c | 404 | clock_t realtime1 = 0, realtime2 = 0; |
146174a9 CB |
405 | U32 ototal = g_total; |
406 | U32 ostack = g_SAVE_STACK; | |
407 | U32 operldb = PL_perldb; | |
583a019e | 408 | |
146174a9 | 409 | g_SAVE_STACK = 1000000; |
583a019e GS |
410 | realtime1 = Times(&t1); |
411 | ||
412 | while (k < 2) { | |
413 | i = 0; | |
414 | /* Disable debugging of perl_call_sv on second pass: */ | |
146174a9 CB |
415 | PL_curstash = (k == 0 ? PL_defstash : PL_debstash); |
416 | PL_perldb = g_default_perldb; | |
583a019e GS |
417 | while (++i <= 100) { |
418 | j = 0; | |
146174a9 | 419 | g_profstack_ix = 0; /* Do not let the stack grow */ |
583a019e | 420 | while (++j <= 100) { |
146174a9 | 421 | /* prof_mark(aTHX_ OP_ENTERSUB); */ |
583a019e | 422 | |
146174a9 CB |
423 | PUSHMARK(PL_stack_sp); |
424 | perl_call_sv((SV*)cv, G_SCALAR); | |
425 | PL_stack_sp--; | |
426 | /* prof_mark(aTHX_ OP_LEAVESUB); */ | |
583a019e GS |
427 | } |
428 | } | |
146174a9 | 429 | PL_curstash = oldstash; |
583a019e GS |
430 | if (k == 0) { /* Put time with debugging */ |
431 | realtime2 = Times(&t2); | |
432 | *r = realtime2 - realtime1; | |
433 | *u = t2.tms_utime - t1.tms_utime; | |
434 | *s = t2.tms_stime - t1.tms_stime; | |
146174a9 CB |
435 | } |
436 | else { /* Subtract time without debug */ | |
583a019e GS |
437 | realtime1 = Times(&t1); |
438 | *r -= realtime1 - realtime2; | |
439 | *u -= t1.tms_utime - t2.tms_utime; | |
440 | *s -= t1.tms_stime - t2.tms_stime; | |
441 | } | |
442 | k++; | |
443 | } | |
146174a9 CB |
444 | g_total = ototal; |
445 | g_SAVE_STACK = ostack; | |
446 | PL_perldb = operldb; | |
583a019e GS |
447 | } |
448 | ||
449 | static void | |
146174a9 | 450 | prof_recordheader(pTHX) |
583a019e | 451 | { |
146174a9 CB |
452 | clock_t r, u, s; |
453 | ||
454 | /* g_fp is opened in the BOOT section */ | |
455 | PerlIO_printf(g_fp, "#fOrTyTwO\n"); | |
456 | PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ); | |
457 | PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION); | |
458 | PerlIO_printf(g_fp, "# All values are given in HZ\n"); | |
459 | test_time(aTHX_ &r, &u, &s); | |
460 | PerlIO_printf(g_fp, | |
461 | "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", | |
462 | /* The (IV) casts are one possibility: | |
463 | * the Painfully Correct Way would be to | |
464 | * have Clock_t_f. */ | |
465 | (IV)u, (IV)s, (IV)r); | |
466 | PerlIO_printf(g_fp, "$over_tests=10000;\n"); | |
467 | ||
468 | g_TIMES_LOCATION = PerlIO_tell(g_fp); | |
469 | ||
470 | /* Pad with whitespace. */ | |
471 | /* This should be enough even for very large numbers. */ | |
472 | PerlIO_printf(g_fp, "%*s\n", 240 , ""); | |
473 | ||
474 | PerlIO_printf(g_fp, "\n"); | |
475 | PerlIO_printf(g_fp, "PART2\n"); | |
476 | ||
477 | PerlIO_flush(g_fp); | |
583a019e GS |
478 | } |
479 | ||
480 | static void | |
146174a9 | 481 | prof_record(pTHX) |
583a019e | 482 | { |
146174a9 CB |
483 | /* g_fp is opened in the BOOT section */ |
484 | ||
485 | /* Now that we know the runtimes, fill them in at the recorded | |
486 | location -JH */ | |
583a019e | 487 | |
146174a9 CB |
488 | if (g_SAVE_STACK) { |
489 | prof_dump_until(aTHX_ g_profstack_ix); | |
490 | } | |
491 | PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET); | |
492 | /* Write into reserved 240 bytes: */ | |
493 | PerlIO_printf(g_fp, | |
494 | "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", | |
495 | /* The (IV) casts are one possibility: | |
496 | * the Painfully Correct Way would be to | |
497 | * have Clock_t_f. */ | |
498 | (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u), | |
499 | (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s), | |
500 | (IV)(g_rprof_end-g_rprof_start-g_wprof_r)); | |
501 | PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total); | |
583a019e | 502 | |
146174a9 | 503 | PerlIO_close(g_fp); |
583a019e GS |
504 | } |
505 | ||
506 | #define NONESUCH() | |
507 | ||
583a019e | 508 | static void |
d7b9cf63 | 509 | check_depth(pTHX_ void *foo) |
583a019e | 510 | { |
4b19af01 | 511 | U32 need_depth = PTR2UV(foo); |
146174a9 CB |
512 | if (need_depth != g_depth) { |
513 | if (need_depth > g_depth) { | |
583a019e | 514 | warn("garbled call depth when profiling"); |
146174a9 CB |
515 | } |
516 | else { | |
425d70b4 | 517 | IV marks = g_depth - need_depth; |
583a019e | 518 | |
146174a9 | 519 | /* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */ |
583a019e | 520 | while (marks--) { |
146174a9 | 521 | prof_mark(aTHX_ OP_DIE); |
583a019e | 522 | } |
146174a9 | 523 | g_depth = need_depth; |
583a019e GS |
524 | } |
525 | } | |
526 | } | |
527 | ||
528 | #define for_real | |
529 | #ifdef for_real | |
530 | ||
531 | XS(XS_DB_sub) | |
532 | { | |
c6c619a9 | 533 | dMARK; |
146174a9 CB |
534 | dORIGMARK; |
535 | SV *Sub = GvSV(PL_DBsub); /* name of current sub */ | |
536 | ||
537 | #ifdef PERL_IMPLICIT_CONTEXT | |
538 | /* profile only the interpreter that loaded us */ | |
539 | if (g_THX != aTHX) { | |
540 | PUSHMARK(ORIGMARK); | |
d781cccd | 541 | perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME_V | G_NODEBUG); |
146174a9 CB |
542 | } |
543 | else | |
544 | #endif | |
545 | { | |
546 | HV *oldstash = PL_curstash; | |
583a019e | 547 | |
94277a97 | 548 | DBG_SUB_NOTIFY(Sub); |
583a019e | 549 | |
a6f8e609 | 550 | SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth)); |
146174a9 | 551 | g_depth++; |
583a019e | 552 | |
146174a9 CB |
553 | prof_mark(aTHX_ OP_ENTERSUB); |
554 | PUSHMARK(ORIGMARK); | |
d781cccd | 555 | perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME_V | G_NODEBUG); |
8063af02 | 556 | PL_curstash = oldstash; |
146174a9 CB |
557 | prof_mark(aTHX_ OP_LEAVESUB); |
558 | g_depth--; | |
559 | } | |
560 | return; | |
583a019e GS |
561 | } |
562 | ||
563 | XS(XS_DB_goto) | |
564 | { | |
146174a9 CB |
565 | #ifdef PERL_IMPLICIT_CONTEXT |
566 | if (g_THX == aTHX) | |
567 | #endif | |
568 | { | |
569 | prof_mark(aTHX_ OP_GOTO); | |
583a019e | 570 | return; |
146174a9 | 571 | } |
583a019e GS |
572 | } |
573 | ||
574 | #endif /* for_real */ | |
575 | ||
576 | #ifdef testing | |
577 | ||
578 | MODULE = Devel::DProf PACKAGE = DB | |
579 | ||
580 | void | |
581 | sub(...) | |
146174a9 CB |
582 | PPCODE: |
583 | { | |
583a019e | 584 | dORIGMARK; |
146174a9 CB |
585 | HV *oldstash = PL_curstash; |
586 | SV *Sub = GvSV(PL_DBsub); /* name of current sub */ | |
583a019e | 587 | /* SP -= items; added by xsubpp */ |
94277a97 | 588 | DBG_SUB_NOTIFY(Sub); |
583a019e | 589 | |
146174a9 | 590 | sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ |
583a019e | 591 | |
146174a9 CB |
592 | prof_mark(aTHX_ OP_ENTERSUB); |
593 | PUSHMARK(ORIGMARK); | |
583a019e | 594 | |
146174a9 | 595 | PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ |
d781cccd | 596 | perl_call_sv(Sub, GIMME_V); |
146174a9 | 597 | PL_curstash = oldstash; |
583a019e | 598 | |
146174a9 | 599 | prof_mark(aTHX_ OP_LEAVESUB); |
583a019e GS |
600 | SPAGAIN; |
601 | /* PUTBACK; added by xsubpp */ | |
146174a9 | 602 | } |
583a019e GS |
603 | |
604 | #endif /* testing */ | |
605 | ||
606 | MODULE = Devel::DProf PACKAGE = Devel::DProf | |
607 | ||
608 | void | |
609 | END() | |
146174a9 CB |
610 | PPCODE: |
611 | { | |
612 | if (PL_DBsub) { | |
613 | /* maybe the process forked--we want only | |
614 | * the parent's profile. | |
615 | */ | |
616 | if ( | |
617 | #ifdef PERL_IMPLICIT_CONTEXT | |
618 | g_THX == aTHX && | |
619 | #endif | |
620 | g_prof_pid == (int)getpid()) | |
621 | { | |
622 | g_rprof_end = Times(&g_prof_end); | |
623 | DBG_TIMER_NOTIFY("Profiler timer is off.\n"); | |
624 | prof_record(aTHX); | |
625 | } | |
626 | } | |
627 | } | |
583a019e GS |
628 | |
629 | void | |
630 | NONESUCH() | |
631 | ||
632 | BOOT: | |
146174a9 CB |
633 | { |
634 | g_TIMES_LOCATION = 42; | |
635 | g_SAVE_STACK = 1<<14; | |
636 | g_profstack_max = 128; | |
637 | #ifdef PERL_IMPLICIT_CONTEXT | |
638 | g_THX = aTHX; | |
639 | #endif | |
640 | ||
583a019e GS |
641 | /* Before we go anywhere make sure we were invoked |
642 | * properly, else we'll dump core. | |
643 | */ | |
146174a9 CB |
644 | if (!PL_DBsub) |
645 | croak("DProf: run perl with -d to use DProf.\n"); | |
583a019e GS |
646 | |
647 | /* When we hook up the XS DB::sub we'll be redefining | |
648 | * the DB::sub from the PM file. Turn off warnings | |
649 | * while we do this. | |
650 | */ | |
651 | { | |
7c436af3 | 652 | bool warn_tmp = PL_dowarn; |
146174a9 CB |
653 | PL_dowarn = 0; |
654 | newXS("DB::sub", XS_DB_sub, file); | |
655 | newXS("DB::goto", XS_DB_goto, file); | |
656 | PL_dowarn = warn_tmp; | |
583a019e GS |
657 | } |
658 | ||
146174a9 | 659 | sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ |
583a019e GS |
660 | |
661 | { | |
662 | char *buffer = getenv("PERL_DPROF_BUFFER"); | |
663 | ||
664 | if (buffer) { | |
146174a9 | 665 | g_SAVE_STACK = atoi(buffer); |
583a019e GS |
666 | } |
667 | ||
668 | buffer = getenv("PERL_DPROF_TICKS"); | |
669 | ||
670 | if (buffer) { | |
146174a9 CB |
671 | g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */ |
672 | } | |
673 | else { | |
674 | g_dprof_ticks = HZ; | |
583a019e | 675 | } |
583a019e | 676 | |
146174a9 CB |
677 | buffer = getenv("PERL_DPROF_OUT_FILE_NAME"); |
678 | g_out_file_name = savepv(buffer ? buffer : "tmon.out"); | |
679 | } | |
583a019e | 680 | |
146174a9 CB |
681 | if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL) |
682 | croak("DProf: unable to write '%s', errno = %d\n", | |
683 | g_out_file_name, errno); | |
583a019e | 684 | |
146174a9 CB |
685 | g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO; |
686 | g_cv_hash = newHV(); | |
687 | g_prof_pid = (int)getpid(); | |
583a019e | 688 | |
146174a9 CB |
689 | New(0, g_profstack, g_profstack_max, PROFANY); |
690 | prof_recordheader(aTHX); | |
583a019e | 691 | DBG_TIMER_NOTIFY("Profiler timer is on.\n"); |
146174a9 CB |
692 | g_orealtime = g_rprof_start = Times(&g_prof_start); |
693 | g_otms_utime = g_prof_start.tms_utime; | |
694 | g_otms_stime = g_prof_start.tms_stime; | |
695 | PL_perldb = g_default_perldb; | |
696 | } |