ext/Devel/DProf/DProf.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 /*
   6 # Devel::DProf - a Perl code profiler
   7 #  5apr95
   8 #  Dean Roehrich
   9 #
  10 # changes/bugs fixed since 2apr95 version:
  11 #  -now mallocing an extra byte for the \0 :)
  12 # changes/bugs fixed since 01mar95 version:
  13 #  -stringified code ref is used for name of anonymous sub.
  14 #  -include stash name with stringified code ref.
  15 #  -use perl.c's DBsingle and DBsub.
  16 #  -now using croak() and warn().
  17 #  -print "timer is on" before turning timer on.
  18 #  -use safefree() instead of free().
  19 #  -rely on PM to provide full path name to tmon.out.
  20 #  -print errno if unable to write tmon.out.
  21 # changes/bugs fixed since 03feb95 version:
  22 #  -comments
  23 # changes/bugs fixed since 31dec94 version:
  24 #  -added patches from Andy.
  25 #
  26 */
  27
  28 /*#define DBG_SUB 1     /* */
  29 /*#define DBG_TIMER 1   /* */
  30
  31 #ifdef DBG_SUB
  32 #  define DBG_SUB_NOTIFY(A,B) warn( A, B )
  33 #else
  34 #  define DBG_SUB_NOTIFY(A,B)  /* nothing */
  35 #endif
  36
  37 #ifdef DBG_TIMER
  38 #  define DBG_TIMER_NOTIFY(A) warn( A )
  39 #else
  40 #  define DBG_TIMER_NOTIFY(A)  /* nothing */
  41 #endif
  42
  43 /* HZ == clock ticks per second */
  44 #ifndef HZ
  45 #define HZ 60
  46 #endif
  47
  48 static SV * Sub;        /* pointer to $DB::sub */
  49 static char *Tmon;      /* name of tmon.out */
  50
  51 /* Everything is built on times(2).  See its manpage for a description
  52  * of the timings.
  53  */
  54
  55 static
  56 struct tms      prof_start,
  57                 prof_end;
  58
  59 static
  60 clock_t         rprof_start, /* elapsed real time, in ticks */
  61                 rprof_end;
  62
  63 union prof_any {
  64         clock_t tms_utime;  /* cpu time spent in user space */
  65         clock_t tms_stime;  /* cpu time spent in system */
  66         clock_t realtime;   /* elapsed real time, in ticks */
  67         char *name;
  68         opcode ptype;
  69 };
  70
  71 typedef union prof_any PROFANY;
  72
  73 static PROFANY  *profstack;
  74 static int      profstack_max = 128;
  75 static int      profstack_ix = 0;
  76
  77
  78 static void
  79 prof_mark( ptype )
  80 opcode ptype;
  81 {
  82         struct tms t;
  83         clock_t realtime;
  84         char *name, *pv;
  85         char *hvname;
  86         STRLEN len;
  87         SV *sv;
  88
  89         if( profstack_ix + 5 > profstack_max ){
  90                 profstack_max = profstack_max * 3 / 2;
  91                 Renew( profstack, profstack_max, PROFANY );
  92         }
  93
  94         realtime = times(&t);
  95         pv = SvPV( Sub, len );
  96
  97         if( SvROK(Sub) ){
  98                 /* Attempt to make CODE refs identifiable by
  99                  * including their package name.
 100                  */
 101                 sv = (SV*)SvRV(Sub);
 102                 if( sv && SvTYPE(sv) == SVt_PVCV ){
 103                         hvname = HvNAME(CvSTASH(sv));
 104                         len += strlen( hvname ) + 2;  /* +2 for more ::'s */
 105
 106                 }
 107                 else {
 108                         croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv );
 109                 }
 110                 name = (char *)safemalloc( len * sizeof(char) + 1 );
 111                 strcpy( name, hvname );
 112                 strcat( name, "::" );
 113                 strcat( name, pv );
 114         }
 115         else{
 116                 name = (char *)safemalloc( len * sizeof(char) + 1 );
 117                 strcpy( name, pv );
 118         }
 119
 120         profstack[profstack_ix++].ptype = ptype;
 121         profstack[profstack_ix++].tms_utime = t.tms_utime;
 122         profstack[profstack_ix++].tms_stime = t.tms_stime;
 123         profstack[profstack_ix++].realtime = realtime;
 124         profstack[profstack_ix++].name = name;
 125 }
 126
 127 static void
 128 prof_record(){
 129         FILE *fp;
 130         char *name;
 131         int base = 0;
 132         opcode ptype;
 133         clock_t tms_utime;
 134         clock_t tms_stime;
 135         clock_t realtime;
 136
 137         if( (fp = fopen( Tmon, "w" )) == NULL ){
 138                 warn("DProf: unable to write %s, errno = %d\n", Tmon, errno );
 139                 return;
 140         }
 141
 142         fprintf(fp, "#fOrTyTwO\n" );
 143         fprintf(fp, "$hz=%d;\n", HZ );
 144         fprintf(fp, "# All values are given in HZ\n" );
 145         fprintf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld\n",
 146                 prof_end.tms_utime - prof_start.tms_utime,
 147                 prof_end.tms_stime - prof_start.tms_stime,
 148                 rprof_end - rprof_start );
 149         fprintf(fp, "PART2\n" );
 150
 151         while( base < profstack_ix ){
 152                 ptype = profstack[base++].ptype;
 153                 tms_utime = profstack[base++].tms_utime;
 154                 tms_stime = profstack[base++].tms_stime;
 155                 realtime = profstack[base++].realtime;
 156                 name = profstack[base++].name;
 157
 158                 switch( ptype ){
 159                 case OP_LEAVESUB:
 160                         fprintf(fp,"- %ld %ld %ld %s\n",
 161                                 tms_utime, tms_stime, realtime, name );
 162                         break;
 163                 case OP_ENTERSUB:
 164                         fprintf(fp,"+ %ld %ld %ld %s\n",
 165                                 tms_utime, tms_stime, realtime, name );
 166                         break;
 167                 default:
 168                         fprintf(fp,"Profiler unknown prof code %d\n", ptype);
 169                 }
 170         }
 171         fclose( fp );
 172 }
 173
 174 #define for_real
 175 #ifdef for_real
 176
 177 XS(XS_DB_sub)
 178 {
 179         dXSARGS;
 180         dORIGMARK;
 181         SP -= items;
 182
 183         DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
 184
 185         sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
 186
 187         prof_mark( OP_ENTERSUB );
 188         PUSHMARK( ORIGMARK );
 189
 190         perl_call_sv( Sub, GIMME );
 191
 192         prof_mark( OP_LEAVESUB );
 193         SPAGAIN;
 194         PUTBACK;
 195         return;
 196 }
 197
 198 #endif /* for_real */
 199
 200 #ifdef testing
 201
 202         MODULE = Devel::DProf           PACKAGE = DB
 203
 204         void
 205         sub(...)
 206                 PPCODE:
 207
 208                 dORIGMARK;
 209                 /* SP -= items;  added by xsubpp */
 210                 DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
 211
 212                 sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
 213
 214                 prof_mark( OP_ENTERSUB );
 215                 PUSHMARK( ORIGMARK );
 216
 217                 perl_call_sv( Sub, GIMME );
 218
 219                 prof_mark( OP_LEAVESUB );
 220                 SPAGAIN;
 221                 /* PUTBACK;  added by xsubpp */
 222
 223 #endif /* testing */
 224
 225
 226 MODULE = Devel::DProf           PACKAGE = Devel::DProf
 227
 228 void
 229 END()
 230         PPCODE:
 231         rprof_end = times(&prof_end);
 232         DBG_TIMER_NOTIFY("Profiler timer is off.\n");
 233         prof_record();
 234
 235 BOOT:
 236         newXS("DB::sub", XS_DB_sub, file);
 237         Sub = GvSV(DBsub);       /* name of current sub */
 238         sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
 239         { /* obtain name of tmon.out file */
 240          SV *sv;
 241          sv = perl_get_sv( "DB::tmon", FALSE );
 242          Tmon = (char *)safemalloc( SvCUR(sv) * sizeof(char) );
 243          strcpy( Tmon, SvPVX(sv) );
 244         }
 245         New( 0, profstack, profstack_max, PROFANY );
 246         DBG_TIMER_NOTIFY("Profiler timer is on.\n");
 247         rprof_start = times(&prof_start);