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