Leak.xs

   1 /*
   2   Copyright (c) 1995,1996-1998 Nick Ing-Simmons. All rights reserved.
   3   This program is free software; you can redistribute it and/or
   4   modify it under the same terms as Perl itself.
   5 */
   6
   7 #include <EXTERN.h>
   8 #include <perl.h>
   9 #include <XSUB.h>
  10
  11 typedef long used_proc _((void *,SV *,long));
  12 typedef struct hash_s *hash_ptr;
  13
  14 #ifndef sv_dump
  15 #define sv_dump(sv) PerlIO_printf(PerlIO_stderr(), "\n")
  16 #endif
  17
  18 #define MAX_HASH 1009
  19
  20 static hash_ptr pile = NULL;
  21
  22 static void
  23 LangDumpVec(char *who, int count, SV **data)
  24 {
  25  int i;
  26  PerlIO_printf(PerlIO_stderr(), "%s (%d):\n", who, count);
  27  for (i = 0; i < count; i++)
  28   {
  29    SV *sv = data[i];
  30    if (sv)
  31     {
  32      PerlIO_printf(PerlIO_stderr(), "%2d ", i);
  33      sv_dump(sv);
  34     }
  35   }
  36 }
  37
  38 struct hash_s
  39 {struct hash_s *link;
  40  SV *sv;
  41  char *tag;
  42 };
  43
  44 static char *
  45 lookup(hash_ptr *ht, SV *sv, void *tag)
  46 {unsigned hash = ((unsigned long) sv) % MAX_HASH;
  47  hash_ptr p = ht[hash];
  48  while (p)
  49   {
  50    if (p->sv == sv)
  51     {char *old = p->tag;
  52      p->tag = tag;
  53      return old;
  54     }
  55    p = p->link;
  56   }
  57  if ((p = pile))
  58   pile = p->link;
  59  else
  60   p = (hash_ptr) malloc(sizeof(struct hash_s));
  61  p->link  = ht[hash];
  62  p->sv    = sv;
  63  p->tag   = tag;
  64  ht[hash] = p;
  65  return NULL;
  66 }
  67
  68 void
  69 check_arenas()
  70 {
  71  SV *sva;
  72  for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva))
  73   {
  74    SV *sv = sva + 1;
  75    SV *svend = &sva[SvREFCNT(sva)];
  76    while (sv < svend)
  77     {
  78      if (SvROK(sv) && ((IV) SvANY(sv)) & 1)
  79       {
  80        warn("Odd SvANY for %p @ %p[%d]",sv,sva,(sv-sva));
  81        abort();
  82       }
  83      ++sv;
  84     }
  85   }
  86 }
  87
  88 long int
  89 sv_apply_to_used(p, proc,n)
  90 void *p;
  91 used_proc *proc;
  92 long int n;
  93 {
  94  SV *sva;
  95  for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva))
  96   {
  97    SV *sv = sva + 1;
  98    SV *svend = &sva[SvREFCNT(sva)];
  99
 100    while (sv < svend)
 101     {
 102      if (SvTYPE(sv) != SVTYPEMASK)
 103       {
 104        n = (*proc) (p, sv, n);
 105       }
 106      ++sv;
 107     }
 108   }
 109  return n;
 110 }
 111
 112 static char old[] = "old";
 113 static char new[] = "new";
 114
 115 static long
 116 note_sv(p,sv, n)
 117 void *p;
 118 SV *sv;
 119 long int n;
 120 {
 121  lookup(p,sv,old);
 122  return n+1;
 123 }
 124
 125 long
 126 note_used(hash_ptr **x)
 127 {
 128  hash_ptr *ht;
 129  Newz(603, ht, MAX_HASH, hash_ptr);
 130  *x = ht;
 131  return sv_apply_to_used(ht, note_sv, 0);
 132 }
 133
 134 static long
 135 check_sv(void *p, SV *sv, long hwm)
 136 {
 137  char *state = lookup(p,sv,new);
 138  if (state != old)
 139   {
 140    fprintf(stderr,"%s %p : ", state ? state : new, sv);
 141    sv_dump(sv);
 142   }
 143  return hwm+1;
 144 }
 145
 146 static long
 147 find_object(void *p, SV *sv, long count)
 148 {
 149  if (sv_isobject(sv))
 150   {
 151    sv_dump(sv);
 152    count++;
 153   }
 154  return count;
 155 }
 156
 157 long
 158 check_used(hash_ptr **x)
 159 {hash_ptr *ht = *x;
 160  if (ht == NULL)
 161   {
 162    croak("Please call Devel::Check::NoteSV() before calling Devel::Check::CheckSV()");
 163   }
 164  long count = sv_apply_to_used(ht, check_sv, 0);
 165  long i;
 166  for (i = 0; i < MAX_HASH; i++)
 167   {hash_ptr p = ht[i];
 168    while (p)
 169     {
 170      hash_ptr t = p;
 171      p = t->link;
 172      if (t->tag != new)
 173       {
 174        LangDumpVec(t->tag ? t->tag : "NUL",1,&t->sv);
 175       }
 176      t->link = pile;
 177      pile = t;
 178     }
 179   }
 180  Safefree(ht);
 181  *x = NULL;
 182  return count;
 183 }
 184
 185 static long
 186 add_to_AV(void *p, SV *sv, long av)
 187 {
 188  char *state = lookup(p,sv,new);
 189  if (state != old)
 190   {
 191 #if 0
 192     SV* sv_ptr = newSViv((IV)sv);
 193     note_sv(p,sv_ptr,0); /* tricky: avoid that the newly created SV is also counted... */
 194     av_push((AV*)av, sv_ptr);
 195 #else
 196     av_push((AV*)av, SvREFCNT_inc(sv));
 197 #endif
 198   }
 199  return av; /* pass over */
 200 }
 201
 202 MODULE = Devel::Leak    PACKAGE = Devel::Leak
 203
 204 PROTOTYPES: Enable
 205
 206 IV
 207 NoteSV(obj)
 208 hash_ptr *      obj = NO_INIT
 209 CODE:
 210  {
 211   RETVAL = note_used(&obj);
 212  }
 213 OUTPUT:
 214  obj
 215  RETVAL
 216
 217 IV
 218 CheckSV(obj)
 219 hash_ptr *      obj
 220 CODE:
 221  {
 222   RETVAL = check_used(&obj);
 223  }
 224 OUTPUT:
 225  obj
 226  RETVAL
 227
 228 IV
 229 FindObjects()
 230 CODE:
 231  {
 232   RETVAL = sv_apply_to_used(NULL, find_object, 0);
 233  }
 234 OUTPUT:
 235  RETVAL
 236
 237 void
 238 check_arenas()
 239
 240 AV*
 241 ListSV(obj)
 242 hash_ptr *      obj
 243 CODE:
 244  {
 245   hash_ptr **x = &obj;
 246   hash_ptr *ht = *x;
 247   RETVAL = newAV();
 248   note_sv(ht,RETVAL,0); /* tricky: avoid that the newly created AV is also counted... */
 249   sv_apply_to_used(ht, add_to_AV, (long)RETVAL); /* misuse long for pointer --- should be always large enough */
 250   sv_2mortal((SV*)RETVAL);
 251  }
 252 OUTPUT:
 253  RETVAL