-
Notifications
You must be signed in to change notification settings - Fork 51
/
NYTProf.xs
5442 lines (4724 loc) · 191 KB
/
NYTProf.xs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* vim: ts=8 sw=4 expandtab:
* ************************************************************************
* This file is part of the Devel::NYTProf package.
* Copyright 2008 Adam J. Kaplan, The New York Times Company.
* Copyright 2009-2010 Tim Bunce, Ireland.
* Released under the same terms as Perl 5.8
* See http://metacpan.org/release/Devel-NYTProf/
*
* Contributors:
* Tim Bunce, http://blog.timbunce.org
* Nicholas Clark,
* Adam Kaplan, akaplan at nytimes.com
* Steve Peters, steve at fisharerojo.org
*
* ************************************************************************
*/
#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "FileHandle.h"
#include "NYTProf.h"
#ifndef NO_PPPORT_H
#define NEED_my_snprintf_GLOBAL
#define NEED_newRV_noinc_GLOBAL
#define NEED_sv_2pv_flags
#define NEED_newSVpvn_flags
#define NEED_my_strlcat
# include "ppport.h"
#endif
/* Until ppport.h gets this: */
#ifndef memEQs
# define memEQs(s1, l, s2) \
(sizeof(s2)-1 == l && memEQ(s1, ("" s2 ""), (sizeof(s2)-1)))
#endif
#ifdef USE_HARD_ASSERT
#undef NDEBUG
#include <assert.h>
#endif
#if !defined(OutCopFILE)
# define OutCopFILE CopFILE
#endif
#ifndef gv_fetchfile_flags /* added in perl 5.009005 */
/* we know our uses don't contain embedded nulls, so we just need to copy to a
* buffer so we can add a trailing null byte */
#define gv_fetchfile_flags(a,b,c) gv_fetchfile_flags(a,b,c)
static GV *
gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const U32 flags) {
char buf[2000];
if (namelen >= sizeof(buf)-1)
croak("panic: gv_fetchfile_flags overflow");
memcpy(buf, name, namelen);
buf[namelen] = '\0'; /* null-terminate */
return gv_fetchfile(buf);
}
#endif
#ifndef OP_SETSTATE
#define OP_SETSTATE OP_NEXTSTATE
#endif
#ifndef PERLDBf_SAVESRC
#define PERLDBf_SAVESRC PERLDBf_SUBLINE
#endif
#ifndef PERLDBf_SAVESRC_NOSUBS
#define PERLDBf_SAVESRC_NOSUBS 0
#endif
#ifndef CvISXSUB
#define CvISXSUB CvXSUB
#endif
#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION < 8))
/* If we're using DB::DB() instead of opcode redirection with an old perl
* then PL_curcop in DB() will refer to the DB() wrapper in Devel/NYTProf.pm
* so we'd have to crawl the stack to find the right cop. However, for some
* reason that I don't pretend to understand the following expression works:
*/
#define PL_curcop_nytprof (opt_use_db_sub ? ((cxstack + cxstack_ix)->blk_oldcop) : PL_curcop)
#else
#define PL_curcop_nytprof PL_curcop
#endif
#define OP_NAME_safe(op) ((op) ? OP_NAME(op) : "NULL")
#ifdef I_SYS_TIME
#include <sys/time.h>
#endif
#include <stdio.h>
#ifdef HAS_ZLIB
#include <zlib.h>
#define default_compression_level 6
#else
#define default_compression_level 0
#endif
#ifndef ZLIB_VERSION
#define ZLIB_VERSION "0"
#endif
#ifndef NYTP_MAX_SUB_NAME_LEN
#define NYTP_MAX_SUB_NAME_LEN 500
#endif
#define NYTP_FILE_MAJOR_VERSION 5
#define NYTP_FILE_MINOR_VERSION 0
#define NYTP_START_NO 0
#define NYTP_START_BEGIN 1
#define NYTP_START_CHECK_unused 2 /* not used */
#define NYTP_START_INIT 3
#define NYTP_START_END 4
#define NYTP_OPTf_ADDPID 0x0001 /* append .pid to output filename */
#define NYTP_OPTf_OPTIMIZE 0x0002 /* affect $^P & 0x04 */
#define NYTP_OPTf_SAVESRC 0x0004 /* copy source code lines into profile data */
#define NYTP_OPTf_ADDTIMESTAMP 0x0008 /* append timestamp to output filename */
#define NYTP_FIDf_IS_PMC 0x0001 /* .pm probably really loaded as .pmc */
#define NYTP_FIDf_VIA_STMT 0x0002 /* fid first seen by stmt profiler */
#define NYTP_FIDf_VIA_SUB 0x0004 /* fid first seen by sub profiler */
#define NYTP_FIDf_IS_AUTOSPLIT 0x0008 /* fid is an autosplit (see AutoLoader) */
#define NYTP_FIDf_HAS_SRC 0x0010 /* src is available to profiler */
#define NYTP_FIDf_SAVE_SRC 0x0020 /* src will be saved by profiler, if NYTP_FIDf_HAS_SRC also set */
#define NYTP_FIDf_IS_ALIAS 0x0040 /* fid is clone of the 'parent' fid it was autosplit from */
#define NYTP_FIDf_IS_FAKE 0x0080 /* eg dummy caller of a string eval that doesn't have a filename */
#define NYTP_FIDf_IS_EVAL 0x0100 /* is an eval */
/* indices to elements of the file info array */
#define NYTP_FIDi_FILENAME 0
#define NYTP_FIDi_EVAL_FID 1
#define NYTP_FIDi_EVAL_LINE 2
#define NYTP_FIDi_FID 3
#define NYTP_FIDi_FLAGS 4
#define NYTP_FIDi_FILESIZE 5
#define NYTP_FIDi_FILEMTIME 6
#define NYTP_FIDi_PROFILE 7
#define NYTP_FIDi_EVAL_FI 8
#define NYTP_FIDi_HAS_EVALS 9
#define NYTP_FIDi_SUBS_DEFINED 10
#define NYTP_FIDi_SUBS_CALLED 11
#define NYTP_FIDi_elements 12 /* highest index, plus 1 */
/* indices to elements of the sub info array (report-side only) */
#define NYTP_SIi_FID 0 /* fid of file sub was defined in */
#define NYTP_SIi_FIRST_LINE 1 /* line number of first line of sub */
#define NYTP_SIi_LAST_LINE 2 /* line number of last line of sub */
#define NYTP_SIi_CALL_COUNT 3 /* number of times sub was called */
#define NYTP_SIi_INCL_RTIME 4 /* incl real time in sub */
#define NYTP_SIi_EXCL_RTIME 5 /* excl real time in sub */
#define NYTP_SIi_SUB_NAME 6 /* sub name */
#define NYTP_SIi_PROFILE 7 /* ref to profile object */
#define NYTP_SIi_REC_DEPTH 8 /* max recursion call depth */
#define NYTP_SIi_RECI_RTIME 9 /* recursive incl real time in sub */
#define NYTP_SIi_CALLED_BY 10 /* { fid => { line => [...] } } */
#define NYTP_SIi_elements 11 /* highest index, plus 1 */
/* indices to elements of the sub call info array */
/* XXX currently ticks are accumulated into NYTP_SCi_*_TICKS during profiling
* and then NYTP_SCi_*_RTIME are calculated and output. This avoids float noise
* during profiling but we should really output ticks so the reporting side
* can also be more accurate when merging subs, for example.
* That'll probably need a file format bump and thus also a major version bump.
* Will need coresponding changes to NYTP_SIi_* as well.
*/
#define NYTP_SCi_CALL_COUNT 0 /* count of calls to sub */
#define NYTP_SCi_INCL_RTIME 1 /* inclusive real time in sub (set from NYTP_SCi_INCL_TICKS) */
#define NYTP_SCi_EXCL_RTIME 2 /* exclusive real time in sub (set from NYTP_SCi_EXCL_TICKS) */
#define NYTP_SCi_INCL_TICKS 3 /* inclusive ticks in sub */
#define NYTP_SCi_EXCL_TICKS 4 /* exclusive ticks in sub */
#define NYTP_SCi_RECI_RTIME 5 /* recursive incl real time in sub */
#define NYTP_SCi_REC_DEPTH 6 /* max recursion call depth */
#define NYTP_SCi_CALLING_SUB 7 /* name of calling sub */
#define NYTP_SCi_elements 8 /* highest index, plus 1 */
/* we're not thread-safe (or even multiplicity safe) yet, so detect and bail */
#ifdef MULTIPLICITY
static PerlInterpreter *orig_my_perl;
#endif
#define MAX_HASH_SIZE 512
typedef struct hash_entry Hash_entry;
struct hash_entry {
unsigned int id;
char* key;
int key_len;
Hash_entry* next_entry;
Hash_entry* next_inserted; /* linked list in insertion order */
};
typedef struct hash_table {
Hash_entry** table;
char *name;
unsigned int size;
unsigned int entry_struct_size;
Hash_entry* first_inserted;
Hash_entry* prior_inserted; /* = last_inserted before the last insertion */
Hash_entry* last_inserted;
unsigned int next_id; /* starts at 1, 0 is reserved */
} Hash_table;
typedef struct {
Hash_entry he;
unsigned int eval_fid;
unsigned int eval_line_num;
unsigned int file_size;
unsigned int file_mtime;
unsigned int fid_flags;
char *key_abs;
/* update autosplit logic in get_file_id if fields are added or changed */
} fid_hash_entry;
static Hash_table fidhash = { NULL, "fid", MAX_HASH_SIZE, sizeof(fid_hash_entry), NULL, NULL, NULL, 1 };
typedef struct {
Hash_entry he;
} str_hash_entry;
static Hash_table strhash = { NULL, "str", MAX_HASH_SIZE, sizeof(str_hash_entry), NULL, NULL, NULL, 1 };
/* END Hash table definitions */
/* defaults */
static NYTP_file out;
/* options and overrides */
static char PROF_output_file[MAXPATHLEN+1] = "nytprof.out";
static unsigned int profile_opts = NYTP_OPTf_OPTIMIZE | NYTP_OPTf_SAVESRC;
static int profile_start = NYTP_START_BEGIN; /* when to start profiling */
static char const *nytp_panic_overflow_msg_fmt = "panic: buffer overflow of %s on '%s' (see TROUBLESHOOTING section of the NYTProf documentation)";
struct NYTP_options_t {
const char *option_name;
IV option_iv;
char *option_pv; /* strdup'd */
};
/* XXX boolean options should be moved into profile_opts */
static struct NYTP_options_t options[] = {
#define profile_usecputime options[0].option_iv
{ "usecputime", 0, NULL },
#define profile_subs options[1].option_iv
{ "subs", 1, NULL }, /* subroutine times */
#define profile_blocks options[2].option_iv
{ "blocks", 0, NULL }, /* block and sub *exclusive* times */
#define profile_leave options[3].option_iv
{ "leave", 1, NULL }, /* correct block end timing */
#define embed_fid_line options[4].option_iv
{ "expand", 0, NULL },
#define trace_level options[5].option_iv
{ "trace", 0, NULL },
#define opt_use_db_sub options[6].option_iv
{ "use_db_sub", 0, NULL },
#define compression_level options[7].option_iv
{ "compress", default_compression_level, NULL },
#define profile_clock options[8].option_iv
{ "clock", -1, NULL },
#define profile_stmts options[9].option_iv
{ "stmts", 1, NULL }, /* statement exclusive times */
#define profile_slowops options[10].option_iv
{ "slowops", 2, NULL }, /* slow opcodes, typically system calls */
#define profile_findcaller options[11].option_iv
{ "findcaller", 0, NULL }, /* find sub caller instead of trusting outer */
#define profile_forkdepth options[12].option_iv
{ "forkdepth", -1, NULL }, /* how many generations of kids to profile */
#define opt_perldb options[13].option_iv
{ "perldb", 0, NULL }, /* force certain PL_perldb value */
#define opt_nameevals options[14].option_iv
{ "nameevals", 1, NULL }, /* change $^P 0x100 bit */
#define opt_nameanonsubs options[15].option_iv
{ "nameanonsubs", 1, NULL }, /* change $^P 0x200 bit */
#define opt_calls options[16].option_iv
{ "calls", 1, NULL }, /* output call/return event stream */
#define opt_evals options[17].option_iv
{ "evals", 0, NULL } /* handling of string evals - TBD XXX */
};
/* XXX TODO: add these to options:
if (strEQ(option, "file")) {
strncpy(PROF_output_file, value, MAXPATHLEN);
else if (strEQ(option, "log")) {
else if (strEQ(option, "start")) {
else if (strEQ(option, "addpid")) {
else if (strEQ(option, "optimize") || strEQ(option, "optimise")) {
else if (strEQ(option, "savesrc")) {
else if (strEQ(option, "endatexit")) {
else if (strEQ(option, "libcexit")) {
and write the options to the stream when profiling starts.
*/
/* time tracking */
#ifdef WIN32
/* win32_gettimeofday has ~15 ms resolution on Win32, so use
* QueryPerformanceCounter which has us or ns resolution depending on
* motherboard and OS. Comment this out to use the old clock.
*/
# define HAS_QPC
#endif /* WIN32 */
#ifdef HAS_CLOCK_GETTIME
/* http://www.freebsd.org/cgi/man.cgi?query=clock_gettime
* http://webnews.giga.net.tw/article//mailing.freebsd.performance/710
* http://sean.chittenden.org/news/2008/06/01/
* Explanation of why gettimeofday() (and presumably CLOCK_REALTIME) may go backwards:
* https://groups.google.com/forum/#!topic/comp.os.linux.development.apps/3CkHHyQX918
*/
typedef struct timespec time_of_day_t;
# define CLOCK_GETTIME(ts) clock_gettime(profile_clock, ts)
# define TICKS_PER_SEC 10000000 /* 10 million - 100ns */
# define get_time_of_day(into) CLOCK_GETTIME(&into)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
ticks = ((e.tv_sec - s.tv_sec) * TICKS_PER_SEC + (e.tv_nsec / (typ)100) - (s.tv_nsec / (typ)100)); \
} STMT_END
#else /* !HAS_CLOCK_GETTIME */
#ifdef HAS_MACH_TIME
#include <mach/mach.h>
#include <mach/mach_time.h>
mach_timebase_info_data_t our_timebase;
typedef uint64_t time_of_day_t;
# define TICKS_PER_SEC 10000000 /* 10 million - 100ns */
# define get_time_of_day(into) into = mach_absolute_time()
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
if( our_timebase.denom == 0 ) mach_timebase_info(&our_timebase); \
ticks = (e-s) * our_timebase.numer / our_timebase.denom / (typ)100; \
} STMT_END
#else /* !HAS_MACH_TIME */
#ifdef HAS_QPC
# ifndef U64_CONST
# ifdef _MSC_VER
# define U64_CONST(x) x##UI64
# else
# define U64_CONST(x) x##ULL
# endif
# endif
unsigned __int64 time_frequency = U64_CONST(0);
typedef unsigned __int64 time_of_day_t;
# define TICKS_PER_SEC time_frequency
# define get_time_of_day(into) QueryPerformanceCounter((LARGE_INTEGER*)&into)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; /* XXX whats this? */ \
ticks = (typ)(e-s); \
} STMT_END
/* workaround for "error C2520: conversion from unsigned __int64 to double not
implemented, use signed __int64" on VC 6 */
# if defined(_MSC_VER) && _MSC_VER < 1300 /* < VC 7/2003*/
# define NYTPIuint642NV(x) \
((NV)(__int64)((x) & U64_CONST(0x7FFFFFFFFFFFFFFF)) \
+ -(NV)(__int64)((x) & U64_CONST(0x8000000000000000)))
# define get_NV_ticks_between(s, e, ticks, overflow) STMT_START { \
overflow = 0; /* XXX whats this? */ \
ticks = NYTPIuint642NV(e-s); \
} STMT_END
# endif
#elif defined(HAS_GETTIMEOFDAY)
/* on Win32 gettimeofday is always implemented in Perl, not the MS C lib, so
either we use PerlProc_gettimeofday or win32_gettimeofday, depending on the
Perl defines about NO_XSLOCKS and PERL_IMPLICIT_SYS, to simplify logic,
we don't check the defines, just the macro symbol to see if it forwards to
presumably the iperlsys.h vtable call or not.
See https://github.com/timbunce/devel-nytprof/pull/27#issuecomment-46102026
for more details.
*/
#if defined(WIN32) && !defined(gettimeofday)
# define gettimeofday win32_gettimeofday
#endif
typedef struct timeval time_of_day_t;
# define TICKS_PER_SEC 1000000 /* 1 million */
# define get_time_of_day(into) gettimeofday(&into, NULL)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
ticks = ((e.tv_sec - s.tv_sec) * TICKS_PER_SEC + e.tv_usec - s.tv_usec); \
} STMT_END
#else /* !HAS_GETTIMEOFDAY */
/* worst-case fallback - use Time::HiRes which is expensive to call */
#define WANT_TIME_HIRES
typedef UV time_of_day_t[2];
# define TICKS_PER_SEC 1000000 /* 1 million */
# define get_time_of_day(into) (*time_hires_u2time_hook)(aTHX_ into)
# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
ticks = ((e[0] - s[0]) * (typ)TICKS_PER_SEC + e[1] - s[1]); \
} STMT_END
static int (*time_hires_u2time_hook)(pTHX_ UV *) = 0;
#endif /* HAS_GETTIMEOFDAY else */
#endif /* HAS_MACH_TIME else */
#endif /* HAS_CLOCK_GETTIME else */
#ifndef get_NV_ticks_between
# define get_NV_ticks_between(s, e, ticks, overflow) get_ticks_between(NV, s, e, ticks, overflow)
#endif
#ifndef NYTPIuint642NV
# define NYTPIuint642NV(x) ((NV)(x))
#endif
static time_of_day_t start_time;
static time_of_day_t end_time;
static unsigned int last_executed_line;
static unsigned int last_executed_fid;
static char *last_executed_fileptr;
static unsigned int last_block_line;
static unsigned int last_sub_line;
static unsigned int is_profiling; /* disable_profile() & enable_profile() */
static Pid_t last_pid = 0;
static NV cumulative_overhead_ticks = 0.0;
static NV cumulative_subr_ticks = 0.0;
static UV cumulative_subr_seqn = 0;
static int main_runtime_used = 0;
static SV *DB_CHECK_cv;
static SV *DB_INIT_cv;
static SV *DB_END_cv;
static SV *DB_fin_cv;
static const char *class_mop_evaltag = " defined at ";
static int class_mop_evaltag_len = 12;
static unsigned int ticks_per_sec = 0; /* 0 forces error if not set */
static AV *slowop_name_cache;
/* prototypes */
static void output_header(pTHX);
static SV *read_str(pTHX_ NYTP_file ifile, SV *sv);
static unsigned int get_file_id(pTHX_ char*, STRLEN, int created_via);
static void DB_stmt(pTHX_ COP *cop, OP *op);
static void set_option(pTHX_ const char*, const char*);
static int enable_profile(pTHX_ char *file);
static int disable_profile(pTHX);
static void finish_profile(pTHX);
static void finish_profile_nocontext(void);
static void open_output_file(pTHX_ char *);
static int reinit_if_forked(pTHX);
static int parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p, char *sub_name);
static void write_cached_fids(void);
static void write_src_of_files(pTHX);
static void write_sub_line_ranges(pTHX);
static void write_sub_callers(pTHX);
static AV *store_profile_line_entry(pTHX_ SV *rvav, unsigned int line_num,
NV time, int count, unsigned int fid);
/* copy of original contents of PL_ppaddr */
typedef OP * (CPERLscope(*orig_ppaddr_t))(pTHX);
orig_ppaddr_t *PL_ppaddr_orig;
#define run_original_op(type) CALL_FPTR(PL_ppaddr_orig[type])(aTHX)
static OP *pp_entersub_profiler(pTHX);
static OP *pp_subcall_profiler(pTHX_ int type);
static OP *pp_leave_profiler(pTHX);
static HV *sub_callers_hv;
static HV *pkg_fids_hv; /* currently just package names */
/* PL_sawampersand is disabled in 5.17.7+ 1a904fc */
#if (PERL_VERSION < 17) || ((PERL_VERSION == 17) && (PERL_SUBVERSION < 7)) || defined(PERL_SAWAMPERSAND)
static U8 last_sawampersand;
#define CHECK_SAWAMPERSAND(fid,line) STMT_START { \
if (PL_sawampersand != last_sawampersand) { \
if (trace_level >= 1) \
logwarn("Slow regex match variable seen (0x%x->0x%x at %u:%u)\n", PL_sawampersand, last_sawampersand, fid, line); \
/* XXX this is a hack used by test14 to avoid different behaviour \
* pre/post perl 5.17.7 since it's not relevant to the test, which is really \
* about AutoSplit */ \
if (!getenv("DISABLE_NYTPROF_SAWAMPERSAND")) \
NYTP_write_sawampersand(out, fid, line); \
last_sawampersand = (U8)PL_sawampersand; \
} \
} STMT_END
#else
#define CHECK_SAWAMPERSAND(fid,line) (void)0
#endif
/* macros for outputing profile data */
#ifndef HAS_GETPPID
#define getppid() 0
#endif
static FILE *logfh;
/* predeclare to set attribute */
static void logwarn(const char *pat, ...) __attribute__format__(__printf__,1,2);
static void
logwarn(const char *pat, ...)
{
/* we avoid using any perl mechanisms here */
va_list args;
NYTP_IO_dTHX;
va_start(args, pat);
if (!logfh)
logfh = stderr;
vfprintf(logfh, pat, args);
/* Flush to ensure the log message gets pushed out to the kernel.
* This flush will be expensive but is needed to ensure the log has recent info
* if there's a core dump. Could add an option to disable flushing if needed.
*/
fflush(logfh);
va_end(args);
}
/***********************************
* Devel::NYTProf Functions *
***********************************/
static NV
gettimeofday_nv(void)
{
#ifdef HAS_GETTIMEOFDAY
NYTP_IO_dTHX;
struct timeval when;
gettimeofday(&when, (struct timezone *) 0);
return when.tv_sec + (when.tv_usec / 1000000.0);
#else
#ifdef WANT_TIME_HIRES
NYTP_IO_dTHX;
UV time_of_day[2];
(*time_hires_u2time_hook)(aTHX_ &time_of_day);
return time_of_day[0] + (time_of_day[1] / 1000000.0);
#else
return (NV)time(); /* practically useless */
#endif /* WANT_TIME_HIRES else */
#endif /* HAS_GETTIMEOFDAY else */
}
/**
* output file header
*/
static void
output_header(pTHX)
{
/* $0 - application name */
SV *const sv = get_sv("0",GV_ADDWARN);
time_t basetime = PL_basetime;
/* This comes back with a terminating \n, and we don't want that. */
const char *const basetime_str = ctime(&basetime);
const STRLEN basetime_str_len = strlen(basetime_str);
const char version[] = STRINGIFY(PERL_REVISION) "."
STRINGIFY(PERL_VERSION) "." STRINGIFY(PERL_SUBVERSION);
STRLEN len;
const char *argv0 = SvPV(sv, len);
assert(out != NULL);
/* File header with "magic" string, with file major and minor version */
NYTP_write_header(out, NYTP_FILE_MAJOR_VERSION, NYTP_FILE_MINOR_VERSION);
/* Human readable comments and attributes follow
* comments start with '#', end with '\n', and are discarded
* attributes start with ':', a word, '=', then the value, then '\n'
*/
NYTP_write_comment(out, "Perl profile database. Generated by Devel::NYTProf on %.*s",
(int)basetime_str_len - 1, basetime_str);
/* XXX add options, $0, etc, but beware of embedded newlines */
/* XXX would be good to adopt a proper charset & escaping for these */
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("basetime"), (unsigned long)PL_basetime); /* $^T */
NYTP_write_attribute_string(out, STR_WITH_LEN("application"), argv0, len);
/* perl constants: */
NYTP_write_attribute_string(out, STR_WITH_LEN("perl_version"), version, sizeof(version) - 1);
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("nv_size"), sizeof(NV));
/* sanity checks: */
NYTP_write_attribute_string(out, STR_WITH_LEN("xs_version"), STR_WITH_LEN(XS_VERSION));
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("PL_perldb"), PL_perldb);
/* these are really options: */
NYTP_write_attribute_signed(out, STR_WITH_LEN("clock_id"), profile_clock);
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("ticks_per_sec"), ticks_per_sec);
if (1) {
struct NYTP_options_t *opt_p = options;
const struct NYTP_options_t *const opt_end
= options + sizeof(options) / sizeof (struct NYTP_options_t);
do {
NYTP_write_option_iv(out, opt_p->option_name, opt_p->option_iv);
} while (++opt_p < opt_end);
}
#ifdef HAS_ZLIB
if (compression_level) {
NYTP_start_deflate_write_tag_comment(out, compression_level);
}
#endif
NYTP_write_process_start(out, getpid(), getppid(), gettimeofday_nv());
write_cached_fids(); /* empty initially, non-empty after fork */
NYTP_flush(out);
}
static SV *
read_str(pTHX_ NYTP_file ifile, SV *sv) {
STRLEN len;
char *buf;
unsigned char tag;
NYTP_read(ifile, &tag, sizeof(tag), "string prefix");
if (NYTP_TAG_STRING != tag && NYTP_TAG_STRING_UTF8 != tag)
croak("Profile format error at offset %ld%s, expected string tag but found %d ('%c') (see TROUBLESHOOTING in NYTProf docs)",
NYTP_tell(ifile)-1, NYTP_type_of_offset(ifile), tag, tag);
len = read_u32(ifile);
if (sv) {
SvGROW(sv, len+1); /* forces SVt_PV */
}
else {
sv = newSV(len+1); /* +1 to force SVt_PV even for 0 length string */
}
SvPOK_on(sv);
buf = SvPV_nolen(sv);
NYTP_read(ifile, buf, len, "string");
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
if (NYTP_TAG_STRING_UTF8 == tag)
SvUTF8_on(sv);
if (trace_level >= 19) {
STRLEN len2 = len;
const char *newline = "";
if (buf[len2-1] == '\n') {
--len2;
newline = "\\n";
}
logwarn(" read string '%.*s%s'%s\n", (int)len2, SvPV_nolen(sv),
newline, (SvUTF8(sv)) ? " (utf8)" : "");
}
return sv;
}
/**
* An implementation of the djb2 hash function by Dan Bernstein.
*/
static unsigned long
hash (char* _str, unsigned int len)
{
char* str = _str;
unsigned long hash = 5381;
while (len--) {
/* hash * 33 + c */
hash = ((hash << 5) + hash) + *str++;
}
return hash;
}
/**
* Returns a pointer to the ')' after the digits in the (?:re_)?eval prefix.
* As the prefix length is known, this gives the length of the digits.
*/
static const char *
eval_prefix(const char *filename, const char *prefix, STRLEN prefix_len) {
if (memEQ(filename, prefix, prefix_len)
&& isdigit((int)filename[prefix_len])) {
const char *s = filename + prefix_len + 1;
while (isdigit((int)*s))
++s;
if (s[0] == ')')
return s;
}
return NULL;
}
/**
* Return true if filename looks like an eval
*/
static int
filename_is_eval(const char *filename, STRLEN filename_len)
{
if (filename_len < 6)
return 0;
/* typically "(eval N)[...]" sometimes just "(eval N)" */
if (filename[filename_len - 1] != ']' && filename[filename_len - 1] != ')')
return 0;
if (eval_prefix(filename, "(eval ", 6))
return 1;
if (eval_prefix(filename, "(re_eval ", 9))
return 1;
return 0;
}
/**
* Fetch/Store on hash table. entry must always be defined.
* hash_op will find hash_entry in the hash table.
* hash_entry not in table, insert is false: returns NULL
* hash_entry not in table, insert is true: inserts hash_entry and returns hash_entry
* hash_entry in table, insert IGNORED: returns pointer to the actual hash entry
*/
static char
hash_op(Hash_table *hashtable, char *key, int key_len, Hash_entry** retval, bool insert)
{
unsigned long h = hash(key, key_len) % hashtable->size;
Hash_entry* found = hashtable->table[h];
while(NULL != found) {
if (found->key_len == key_len
&& memEQ(found->key, key, key_len)
) {
*retval = found;
return 0;
}
if (NULL == found->next_entry) {
if (insert) {
Hash_entry* e;
Newc(0, e, hashtable->entry_struct_size, char, Hash_entry);
memzero(e, hashtable->entry_struct_size);
e->id = hashtable->next_id++;
e->next_entry = NULL;
e->key_len = key_len;
e->key = (char*)safemalloc(sizeof(char) * key_len + 1);
e->key[key_len] = '\0';
memcpy(e->key, key, key_len);
found->next_entry = e;
*retval = found->next_entry;
hashtable->prior_inserted = hashtable->last_inserted;
hashtable->last_inserted = e;
return 1;
}
else {
*retval = NULL;
return -1;
}
}
found = found->next_entry;
}
if (insert) {
Hash_entry* e;
Newc(0, e, hashtable->entry_struct_size, char, Hash_entry);
memzero(e, hashtable->entry_struct_size);
e->id = hashtable->next_id++;
e->next_entry = NULL;
e->key_len = key_len;
e->key = (char*)safemalloc(sizeof(char) * e->key_len + 1);
e->key[e->key_len] = '\0';
memcpy(e->key, key, key_len);
*retval = hashtable->table[h] = e;
if (!hashtable->first_inserted)
hashtable->first_inserted = e;
hashtable->prior_inserted = hashtable->last_inserted;
hashtable->last_inserted = e;
return 1;
}
*retval = NULL;
return -1;
}
static void
hash_stats(Hash_table *hashtable, int verbosity)
{
int idx = 0;
int max_chain_len = 0;
int buckets = 0;
int items = 0;
if (verbosity)
warn("%s hash: size %d\n", hashtable->name, hashtable->size);
if (!hashtable->table)
return;
for (idx=0; idx < hashtable->size; ++idx) {
int chain_len = 0;
Hash_entry *found = hashtable->table[idx];
if (!found)
continue;
++buckets;
while (NULL != found) {
++chain_len;
++items;
found = found->next_entry;
}
if (verbosity)
warn("%s hash[%3d]: %d items\n", hashtable->name, idx, chain_len);
if (chain_len > max_chain_len)
max_chain_len = chain_len;
}
/* XXX would be nice to show a histogram of chain lenths */
warn("%s hash: %d of %d buckets used, %d items, max chain %d\n",
hashtable->name, buckets, hashtable->size, items, max_chain_len);
}
static void
emit_fid (fid_hash_entry *fid_info)
{
char *file_name = fid_info->he.key;
STRLEN file_name_len = fid_info->he.key_len;
char *file_name_copy = NULL;
if (fid_info->key_abs) {
file_name = fid_info->key_abs;
file_name_len = strlen(file_name);
}
#ifdef WIN32
/* Make sure we only use forward slashes in filenames */
if (memchr(file_name, '\\', file_name_len)) {
STRLEN i;
file_name_copy = (char*)safemalloc(file_name_len);
for (i=0; i<file_name_len; ++i) {
char ch = file_name[i];
file_name_copy[i] = ch == '\\' ? '/' : ch;
}
file_name = file_name_copy;
}
#endif
NYTP_write_new_fid(out, fid_info->he.id, fid_info->eval_fid,
fid_info->eval_line_num, fid_info->fid_flags,
fid_info->file_size, fid_info->file_mtime,
file_name, (I32)file_name_len);
if (file_name_copy)
Safefree(file_name_copy);
}
/* return true if file is a .pm that was actually loaded as a .pmc */
static int
fid_is_pmc(pTHX_ fid_hash_entry *fid_info)
{
int is_pmc = 0;
char *file_name = fid_info->he.key;
STRLEN len = fid_info->he.key_len;
if (fid_info->key_abs) {
file_name = fid_info->key_abs;
len = strlen(file_name);
}
if (len > 3 && memEQs(file_name + len - 3, 3, ".pm")) {
/* ends in .pm, ok, does a newer .pmc exist? */
/* based on doopen_pm() in perl's pp_ctl.c */
SV *const pmcsv = newSV(len + 2);
char *const pmc = SvPVX(pmcsv);
Stat_t pmstat;
Stat_t pmcstat;
memcpy(pmc, file_name, len);
pmc[len] = 'c';
pmc[len + 1] = '\0';
if (PerlLIO_lstat(pmc, &pmcstat) == 0) {
/* .pmc exists, is it newer than the .pm (if that exists) */
/* Keys in the fid_info are explicitly written with a terminating
'\0', so it is safe to pass file_name to a system call. */
if (PerlLIO_lstat(file_name, &pmstat) < 0 ||
pmstat.st_mtime < pmcstat.st_mtime) {
is_pmc = 1; /* hey, maybe it's Larry working on the perl6 comiler */
}
}
SvREFCNT_dec(pmcsv);
}
return is_pmc;
}
static char *
fmt_fid_flags(pTHX_ int fid_flags, char *buf, Size_t len) {
*buf = '\0';
if (fid_flags & NYTP_FIDf_IS_EVAL) my_strlcat(buf, "eval,", len);
if (fid_flags & NYTP_FIDf_IS_FAKE) my_strlcat(buf, "fake,", len);
if (fid_flags & NYTP_FIDf_IS_AUTOSPLIT) my_strlcat(buf, "autosplit,", len);
if (fid_flags & NYTP_FIDf_IS_ALIAS) my_strlcat(buf, "alias,", len);
if (fid_flags & NYTP_FIDf_IS_PMC) my_strlcat(buf, "pmc,", len);
if (fid_flags & NYTP_FIDf_VIA_STMT) my_strlcat(buf, "viastmt,", len);
if (fid_flags & NYTP_FIDf_VIA_SUB) my_strlcat(buf, "viasub,", len);
if (fid_flags & NYTP_FIDf_HAS_SRC) my_strlcat(buf, "hassrc,", len);
if (fid_flags & NYTP_FIDf_SAVE_SRC) my_strlcat(buf, "savesrc,", len);
if (*buf) /* trim trailing comma */
buf[ my_strlcat(buf,"",len)-1 ] = '\0';
return buf;
}
static void
write_cached_fids()
{
fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted;
while (e) {
if ( !(e->fid_flags & NYTP_FIDf_IS_ALIAS) )
emit_fid(e);
e = (fid_hash_entry*)e->he.next_inserted;
}
}
static fid_hash_entry *
find_autosplit_parent(pTHX_ char* file_name)
{
/* extract basename from file_name, then search for most recent entry
* in fidhash that has the same basename
*/
fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted;
fid_hash_entry *match = NULL;
const char *sep = "/";
char *base_end = strstr(file_name, " (autosplit");
char *base_start = rninstr(file_name, base_end, sep, sep+1);
STRLEN base_len;
base_start = (base_start) ? base_start+1 : file_name;
base_len = base_end - base_start;
if (trace_level >= 3)
logwarn("find_autosplit_parent of '%.*s' (%s)\n",
(int)base_len, base_start, file_name);
for ( ; e; e = (fid_hash_entry*)e->he.next_inserted) {
char *e_name;
if (e->fid_flags & NYTP_FIDf_IS_AUTOSPLIT)
continue;
if (trace_level >= 4)
logwarn("find_autosplit_parent: checking '%.*s'\n", e->he.key_len, e->he.key);
/* skip if key is too small to match */
if (e->he.key_len < base_len)
continue;
/* skip if the last base_len bytes don't match the base name */
e_name = e->he.key + e->he.key_len - base_len;
if (memcmp(e_name, base_start, base_len) != 0)
continue;
/* skip if the char before the matched key isn't a separator */
if (e->he.key_len > base_len && *(e_name-1) != *sep)
continue;
if (trace_level >= 3)
logwarn("matched autosplit '%.*s' to parent fid %d '%.*s' (%c|%c)\n",
(int)base_len, base_start, e->he.id, e->he.key_len, e->he.key, *(e_name-1),*sep);
match = e;
/* keep looking, so we'll return the most recently profiled match */
}
return match;
}
#if 0 /* currently unused */
static Hash_entry *
lookup_file_entry(pTHX_ char* file_name, STRLEN file_name_len) {
Hash_entry entry, *found;
entry.key = file_name;
entry.key_len = (unsigned int)file_name_len;
if (hash_op(fidhash, &entry, &found, 0) == 0)
return found;
return NULL;
}
#endif
/**
* Return a unique persistent id number for a file.
* If file name has not been seen before
* then, if created_via is false it returns 0 otherwise it