code.delx.au - gnu-emacs/blob - src/profiler.c

   1 /* Profiler implementation.
   2
   3 Copyright (C) 2012 Free Software Foundation, Inc.
   4
   5 This file is part of GNU Emacs.
   6
   7 GNU Emacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 GNU Emacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 #include <config.h>
  21 #include <stdio.h>
  22 #include <limits.h>
  23 #include <sys/time.h>
  24 #include <signal.h>
  25 #include <setjmp.h>
  26 #include "lisp.h"
  27
  28 /* True if sampling profiler is running.  */
  29
  30 bool sample_profiler_running;
  31
  32 /* True if memory profiler is running.  */
  33
  34 bool memory_profiler_running;
  35
  36 /* True during tracing.  */
  37
  38 bool is_in_trace;
  39
  40 /* Tag for GC entry.  */
  41
  42 Lisp_Object Qgc;
  43
  44 static void sigprof_handler (int, siginfo_t *, void *);
  45 static void block_sigprof (void);
  46 static void unblock_sigprof (void);
  47
  48 \f
  49 /* Pattern matching.  */
  50
  51 enum pattern_type
  52 {
  53   pattern_exact,                /* foo */
  54   pattern_body_exact,           /* *foo* */
  55   pattern_pre_any,              /* *foo */
  56   pattern_post_any,             /* foo* */
  57   pattern_body_any              /* foo*bar */
  58 };
  59
  60 struct pattern
  61 {
  62   enum pattern_type type;
  63   char *exact;
  64   char *extra;
  65   int exact_length;
  66   int extra_length;
  67 };
  68
  69 static struct pattern *
  70 parse_pattern (const char *pattern)
  71 {
  72   int length = strlen (pattern);
  73   enum pattern_type type;
  74   char *exact;
  75   char *extra = 0;
  76   struct pattern *pat =
  77     (struct pattern *) xmalloc (sizeof (struct pattern));
  78
  79   if (length > 1
  80       && *pattern == '*'
  81       && pattern[length - 1] == '*')
  82     {
  83       type = pattern_body_exact;
  84       exact = xstrdup (pattern + 1);
  85       exact[length - 2] = 0;
  86     }
  87   else if (*pattern == '*')
  88     {
  89       type = pattern_pre_any;
  90       exact = xstrdup (pattern + 1);
  91     }
  92   else if (pattern[length - 1] == '*')
  93     {
  94       type = pattern_post_any;
  95       exact = xstrdup (pattern);
  96       exact[length - 1] = 0;
  97     }
  98   else if (strchr (pattern, '*'))
  99     {
 100       type = pattern_body_any;
 101       exact = xstrdup (pattern);
 102       extra = strchr (exact, '*');
 103       *extra++ = 0;
 104     }
 105   else
 106     {
 107       type = pattern_exact;
 108       exact = xstrdup (pattern);
 109     }
 110
 111   pat->type = type;
 112   pat->exact = exact;
 113   pat->extra = extra;
 114   pat->exact_length = strlen (exact);
 115   pat->extra_length = extra ? strlen (extra) : 0;
 116
 117   return pat;
 118 }
 119
 120 static void
 121 free_pattern (struct pattern *pattern)
 122 {
 123   xfree (pattern->exact);
 124   xfree (pattern);
 125 }
 126
 127 static int
 128 pattern_match_1 (enum pattern_type type,
 129                  const char *exact,
 130                  int exact_length,
 131                  const char *string,
 132                  int length)
 133 {
 134   if (exact_length > length)
 135     return 0;
 136   switch (type)
 137     {
 138     case pattern_exact:
 139       return exact_length == length && !strncmp (exact, string, length);
 140     case pattern_body_exact:
 141       return strstr (string, exact) != 0;
 142     case pattern_pre_any:
 143       return !strncmp (exact, string + (length - exact_length), exact_length);
 144     case pattern_post_any:
 145       return !strncmp (exact, string, exact_length);
 146     case pattern_body_any:
 147       return 0;
 148     }
 149 }
 150
 151 static int
 152 pattern_match (struct pattern *pattern, const char *string)
 153 {
 154   int length = strlen (string);
 155   switch (pattern->type)
 156     {
 157     case pattern_body_any:
 158       if (pattern->exact_length + pattern->extra_length > length)
 159         return 0;
 160       return pattern_match_1 (pattern_post_any,
 161                               pattern->exact,
 162                               pattern->exact_length,
 163                               string, length)
 164         &&   pattern_match_1 (pattern_pre_any,
 165                               pattern->extra,
 166                               pattern->extra_length,
 167                               string, length);
 168     default:
 169       return pattern_match_1 (pattern->type,
 170                               pattern->exact,
 171                               pattern->exact_length,
 172                               string, length);
 173     }
 174 }
 175
 176 #if 0
 177 static int
 178 match (const char *pattern, const char *string)
 179 {
 180   int res;
 181   struct pattern *pat = parse_pattern (pattern);
 182   res = pattern_match (pat, string);
 183   free_pattern (pat);
 184   return res;
 185 }
 186
 187 static void
 188 should_match (const char *pattern, const char *string)
 189 {
 190   putchar (match (pattern, string) ? '.' : 'F');
 191 }
 192
 193 static void
 194 should_not_match (const char *pattern, const char *string)
 195 {
 196   putchar (match (pattern, string) ? 'F' : '.');
 197 }
 198
 199 static void
 200 pattern_match_tests (void)
 201 {
 202   should_match ("", "");
 203   should_not_match ("", "a");
 204   should_match ("a", "a");
 205   should_not_match ("a", "ab");
 206   should_not_match ("ab", "a");
 207   should_match ("*a*", "a");
 208   should_match ("*a*", "ab");
 209   should_match ("*a*", "ba");
 210   should_match ("*a*", "bac");
 211   should_not_match ("*a*", "");
 212   should_not_match ("*a*", "b");
 213   should_match ("*", "");
 214   should_match ("*", "a");
 215   should_match ("a*", "a");
 216   should_match ("a*", "ab");
 217   should_not_match ("a*", "");
 218   should_not_match ("a*",  "ba");
 219   should_match ("*a", "a");
 220   should_match ("*a", "ba");
 221   should_not_match ("*a", "");
 222   should_not_match ("*a", "ab");
 223   should_match ("a*b", "ab");
 224   should_match ("a*b", "acb");
 225   should_match ("a*b", "aab");
 226   should_match ("a*b", "abb");
 227   should_not_match ("a*b", "");
 228   should_not_match ("a*b", "");
 229   should_not_match ("a*b", "abc");
 230   puts ("");
 231 }
 232 #endif
 233
 234 \f
 235 /* Filters.  */
 236
 237 static struct pattern *filter_pattern;
 238
 239 /* Set the current filter pattern.  If PATTERN is null, unset the
 240    current filter pattern instead.  */
 241
 242 static void
 243 set_filter_pattern (const char *pattern)
 244 {
 245   if (sample_profiler_running)
 246     block_sigprof ();
 247
 248   if (filter_pattern)
 249     {
 250       free_pattern (filter_pattern);
 251       filter_pattern = 0;
 252     }
 253   if (pattern)
 254     filter_pattern = parse_pattern (pattern);
 255
 256   if (sample_profiler_running)
 257     unblock_sigprof ();
 258 }
 259
 260 /* Return true if the current filter pattern is matched with FUNCTION.
 261    FUNCTION should be a symbol or a subroutine, otherwise return
 262    false.  */
 263
 264 static int
 265 apply_filter_1 (Lisp_Object function)
 266 {
 267   const char *name;
 268
 269   if (!filter_pattern)
 270     return 1;
 271
 272   if (SYMBOLP (function))
 273     name = SDATA (SYMBOL_NAME (function));
 274   else if (SUBRP (function))
 275     name = XSUBR (function)->symbol_name;
 276   else
 277     return 0;
 278
 279   return pattern_match (filter_pattern, name);
 280 }
 281
 282 /* Return true if the current filter pattern is matched with at least
 283    one entry in BACKLIST.  */
 284
 285 static int
 286 apply_filter (struct backtrace *backlist)
 287 {
 288   while (backlist)
 289     {
 290       if (apply_filter_1 (*backlist->function))
 291         return 1;
 292       backlist = backlist->next;
 293     }
 294   return 0;
 295 }
 296
 297 DEFUN ("profiler-set-filter-pattern",
 298        Fprofiler_set_filter_pattern, Sprofiler_set_filter_pattern,
 299        1, 1, "sPattern: ",
 300        doc: /* Set the current filter pattern.  PATTERN can contain
 301 one or two wildcards (*) as follows:
 302
 303 - foo
 304 - *foo
 305 - foo*
 306 - *foo*
 307 - foo*bar
 308
 309 If PATTERN is nil or an empty string, then unset the current filter
 310 pattern.  */)
 311   (Lisp_Object pattern)
 312 {
 313   if (NILP (pattern)
 314       || (STRINGP (pattern) && !SREF (pattern, 0)))
 315     {
 316       set_filter_pattern (0);
 317       message ("Profiler filter pattern unset");
 318       return Qt;
 319     }
 320   else if (!STRINGP (pattern))
 321     error ("Invalid type of profiler filter pattern");
 322
 323   set_filter_pattern (SDATA (pattern));
 324
 325   return Qt;
 326 }
 327
 328 \f
 329 /* Backtraces.  */
 330
 331
 332 static Lisp_Object
 333 make_backtrace (int size)
 334 {
 335   return Fmake_vector (make_number (size), Qnil);
 336 }
 337
 338 static EMACS_UINT
 339 backtrace_hash (Lisp_Object backtrace)
 340 {
 341   int i;
 342   EMACS_UINT hash = 0;
 343   for (i = 0; i < ASIZE (backtrace); i++)
 344     /* FIXME */
 345     hash = SXHASH_COMBINE (XUINT (AREF (backtrace, i)), hash);
 346   return hash;
 347 }
 348
 349 static int
 350 backtrace_equal (Lisp_Object a, Lisp_Object b)
 351 {
 352   int i, j;
 353
 354   for (i = 0, j = 0;; i++, j++)
 355     {
 356       Lisp_Object x = i < ASIZE (a) ? AREF (a, i) : Qnil;
 357       Lisp_Object y = j < ASIZE (b) ? AREF (b, j) : Qnil;
 358       if (NILP (x) && NILP (y))
 359         break;
 360       else if (!EQ (x, y))
 361         return 0;
 362     }
 363
 364   return 1;
 365 }
 366
 367 static Lisp_Object
 368 backtrace_object_1 (Lisp_Object backtrace, int i)
 369 {
 370   if (i >= ASIZE (backtrace) || NILP (AREF (backtrace, i)))
 371     return Qnil;
 372   else
 373     return Fcons (AREF (backtrace, i), backtrace_object_1 (backtrace, i + 1));
 374 }
 375
 376 /* Convert BACKTRACE to a list.  */
 377
 378 static Lisp_Object
 379 backtrace_object (Lisp_Object backtrace)
 380 {
 381   backtrace_object_1 (backtrace, 0);
 382 }
 383
 384 \f
 385 /* Slots.  */
 386
 387 /* Slot data structure.  */
 388
 389 struct slot
 390 {
 391   /* Point to next free slot or next hash table link.  */
 392   struct slot *next;
 393   /* Point to previous hash table link.  */
 394   struct slot *prev;
 395   /* Backtrace object with fixed size.  */
 396   Lisp_Object backtrace;
 397   /* How many times a profiler sees the slot, or how much resouce
 398      allocated during profiling.  */
 399   size_t count;
 400   /* How long the slot takes to execute.  */
 401   size_t elapsed;
 402   /* True in used.  */
 403   unsigned char used : 1;
 404 };
 405
 406 static void
 407 mark_slot (struct slot *slot)
 408 {
 409   mark_object (slot->backtrace);
 410 }
 411
 412 /* Convert SLOT to a list.  */
 413
 414 static Lisp_Object
 415 slot_object (struct slot *slot)
 416 {
 417   return list3 (backtrace_object (slot->backtrace),
 418                 make_number (slot->count),
 419                 make_number (slot->elapsed));
 420 }
 421
 422 \f
 423
 424 /* Slot heaps.  */
 425
 426 struct slot_heap
 427 {
 428   /* Number of slots allocated to the heap.  */
 429   unsigned int size;
 430   /* Actual data area.  */
 431   struct slot *data;
 432   /* Free list.  */
 433   struct slot *free_list;
 434 };
 435
 436 static void
 437 clear_slot_heap (struct slot_heap *heap)
 438 {
 439   int i;
 440   struct slot *data;
 441   struct slot *free_list;
 442
 443   data = heap->data;
 444
 445   /* Mark all slots unsused.  */
 446   for (i = 0; i < heap->size; i++)
 447     data[i].used = 0;
 448
 449   /* Rebuild a free list.  */
 450   free_list = heap->free_list = heap->data;
 451   for (i = 1; i < heap->size; i++)
 452     {
 453       free_list->next = &data[i];
 454       free_list = free_list->next;
 455     }
 456   free_list->next = 0;
 457 }
 458
 459 /* Make a slot heap with SIZE.  MAX_STACK_DEPTH is a fixed size of
 460    allocated slots.  */
 461
 462 static struct slot_heap *
 463 make_slot_heap (unsigned int size, int max_stack_depth)
 464 {
 465   int i;
 466   struct slot_heap *heap;
 467   struct slot *data;
 468
 469   data = (struct slot *) xmalloc (sizeof (struct slot) * size);
 470   for (i = 0; i < size; i++)
 471     data[i].backtrace = make_backtrace (max_stack_depth);
 472
 473   heap = (struct slot_heap *) xmalloc (sizeof (struct slot_heap));
 474   heap->size = size;
 475   heap->data = data;
 476   clear_slot_heap (heap);
 477
 478   return heap;
 479 }
 480
 481 static void
 482 free_slot_heap (struct slot_heap *heap)
 483 {
 484   int i;
 485   struct slot *data = heap->data;
 486   for (i = 0; i < heap->size; i++)
 487     data[i].backtrace = Qnil;
 488   xfree (data);
 489   xfree (heap);
 490 }
 491
 492 static void
 493 mark_slot_heap (struct slot_heap *heap)
 494 {
 495   int i;
 496   for (i = 0; i < heap->size; i++)
 497     mark_slot (&heap->data[i]);
 498 }
 499
 500 /* Allocate one slot from HEAP.  Return 0 if no free slot in HEAP.  */
 501
 502 static struct slot *
 503 allocate_slot (struct slot_heap *heap)
 504 {
 505   struct slot *slot;
 506   if (!heap->free_list)
 507     return 0;
 508   slot = heap->free_list;
 509   slot->count = 0;
 510   slot->elapsed = 0;
 511   slot->used = 1;
 512   heap->free_list = heap->free_list->next;
 513   return slot;
 514 }
 515
 516 static void
 517 free_slot (struct slot_heap *heap, struct slot *slot)
 518 {
 519   eassert (slot->used);
 520   slot->used = 0;
 521   slot->next = heap->free_list;
 522   heap->free_list = slot;
 523 }
 524
 525 /* Return a minimal slot from HEAP.  "Minimal" means that such a slot
 526    is meaningless for profiling.  */
 527
 528 static struct slot *
 529 min_slot (struct slot_heap *heap)
 530 {
 531   int i;
 532   struct slot *min = 0;
 533   for (i = 0; i < heap->size; i++)
 534     {
 535       struct slot *slot = &heap->data[i];
 536       if (!min || (slot->used && slot->count < min->count))
 537         min = slot;
 538     }
 539   return min;
 540 }
 541
 542 \f
 543 /* Slot hash tables.  */
 544
 545 struct slot_table
 546 {
 547   /* Number of slot buckets.  */
 548   unsigned int size;
 549   /* Buckets data area.  */
 550   struct slot **data;
 551 };
 552
 553 static void
 554 clear_slot_table (struct slot_table *table)
 555 {
 556   int i;
 557   for (i = 0; i < table->size; i++)
 558     table->data[i] = 0;
 559 }
 560
 561 static struct slot_table *
 562 make_slot_table (int size)
 563 {
 564   struct slot_table *table
 565     = (struct slot_table *) xmalloc (sizeof (struct slot_table));
 566   table->size = size;
 567   table->data = (struct slot **) xmalloc (sizeof (struct slot *) * size);
 568   clear_slot_table (table);
 569   return table;
 570 }
 571
 572 static void
 573 free_slot_table (struct slot_table *table)
 574 {
 575   xfree (table->data);
 576   xfree (table);
 577 }
 578
 579 static void
 580 remove_slot (struct slot_table *table, struct slot *slot)
 581 {
 582   if (slot->prev)
 583     slot->prev->next = slot->next;
 584   else
 585     {
 586       EMACS_UINT hash = backtrace_hash (slot->backtrace);
 587       table->data[hash % table->size] = slot->next;
 588     }
 589   if (slot->next)
 590     slot->next->prev = slot->prev;
 591 }
 592
 593 \f
 594 /* Logs.  */
 595
 596 struct log
 597 {
 598   /* Type of log in symbol.  `sample' or `memory'.  */
 599   Lisp_Object type;
 600   /* Backtrace for working.  */
 601   Lisp_Object backtrace;
 602   struct slot_heap *slot_heap;
 603   struct slot_table *slot_table;
 604   size_t others_count;
 605   size_t others_elapsed;
 606 };
 607
 608 static struct log *
 609 make_log (const char *type, int heap_size, int max_stack_depth)
 610 {
 611   struct log *log =
 612     (struct log *) xmalloc (sizeof (struct log));
 613   log->type = intern (type);
 614   log->backtrace = make_backtrace (max_stack_depth);
 615   log->slot_heap = make_slot_heap (heap_size, max_stack_depth);
 616   /* Number of buckets of hash table will be 10% of HEAP_SIZE.  */
 617   log->slot_table = make_slot_table (max (256, heap_size) / 10);
 618   log->others_count = 0;
 619   log->others_elapsed = 0;
 620   return log;
 621 }
 622
 623 static void
 624 free_log (struct log *log)
 625 {
 626   log->backtrace = Qnil;
 627   free_slot_heap (log->slot_heap);
 628   free_slot_table (log->slot_table);
 629 }
 630
 631 static void
 632 mark_log (struct log *log)
 633 {
 634   mark_object (log->type);
 635   mark_object (log->backtrace);
 636   mark_slot_heap (log->slot_heap);
 637 }
 638
 639 static void
 640 clear_log (struct log *log)
 641 {
 642   clear_slot_heap (log->slot_heap);
 643   clear_slot_table (log->slot_table);
 644   log->others_count = 0;
 645   log->others_elapsed = 0;
 646 }
 647
 648 /* Evint SLOT from LOG and accumulate the slot counts into others
 649    counts.  */
 650
 651 static void
 652 evict_slot (struct log *log, struct slot *slot)
 653 {
 654   log->others_count += slot->count;
 655   log->others_elapsed += slot->elapsed;
 656   remove_slot (log->slot_table, slot);
 657   free_slot (log->slot_heap, slot);
 658 }
 659
 660 /* Evict a minimal slot from LOG.  */
 661
 662 static void
 663 evict_min_slot (struct log *log)
 664 {
 665   struct slot *min = min_slot (log->slot_heap);
 666   if (min)
 667     evict_slot (log, min);
 668 }
 669
 670 /* Allocate a new slot for BACKTRACE from LOG.  The returen value must
 671    be a valid pointer to the slot.  */
 672
 673 static struct slot *
 674 new_slot (struct log *log, Lisp_Object backtrace)
 675 {
 676   int i;
 677   struct slot *slot = allocate_slot (log->slot_heap);
 678
 679   /* If failed to allocate a slot, free some slots to make a room in
 680      heap.  */
 681   if (!slot)
 682     {
 683       evict_min_slot (log);
 684       slot = allocate_slot (log->slot_heap);
 685       /* Must be allocated.  */
 686       eassert (slot);
 687     }
 688
 689   slot->prev = 0;
 690   slot->next = 0;
 691
 692   /* Assign BACKTRACE to the slot.  */
 693   for (i = 0; i < ASIZE (backtrace); i++)
 694     ASET (slot->backtrace, i, AREF (backtrace, i));
 695
 696   return slot;
 697 }
 698
 699 /* Make sure that a slot for BACKTRACE is in LOG and return the
 700    slot. The return value must be a valid pointer to the slot.  */
 701
 702 static struct slot *
 703 ensure_slot (struct log *log, Lisp_Object backtrace)
 704 {
 705   EMACS_UINT hash = backtrace_hash (backtrace);
 706   int index = hash % log->slot_table->size;
 707   struct slot *slot = log->slot_table->data[index];
 708   struct slot *prev = slot;
 709
 710   /* Looking up in hash table bucket.  */
 711   while (slot)
 712     {
 713       if (backtrace_equal (backtrace, slot->backtrace))
 714         goto found;
 715       prev = slot;
 716       slot = slot->next;
 717     }
 718
 719   /* If not found, allocate a new slot for BACKTRACE from LOG and link
 720      it with bucket chain.  */
 721   slot = new_slot (log, backtrace);
 722   if (prev)
 723     {
 724       slot->prev = prev;
 725       prev->next = slot;
 726     }
 727   else
 728     log->slot_table->data[index] = slot;
 729
 730  found:
 731   return slot;
 732 }
 733
 734 /* Record the current backtrace in LOG. BASE is a special name for
 735    describing which the backtrace come from. BASE can be nil. COUNT is
 736    a number how many times the profiler sees the backtrace at the
 737    time.  ELAPSED is a elapsed time in millisecond that the backtrace
 738    took.  */
 739
 740 static void
 741 record_backtrace_under (struct log *log, Lisp_Object base,
 742                         size_t count, size_t elapsed)
 743 {
 744   int i = 0;
 745   Lisp_Object backtrace = log->backtrace;
 746   struct backtrace *backlist = backtrace_list;
 747
 748   /* First of all, apply filter on the bactkrace.  */
 749   if (!apply_filter (backlist)) return;
 750
 751   /* Record BASE if necessary.  */
 752   if (!NILP (base) && ASIZE (backtrace) > 0)
 753     ASET (backtrace, i++, base);
 754
 755   /* Copy the backtrace contents into working memory.  */
 756   for (; i < ASIZE (backtrace) && backlist; backlist = backlist->next)
 757     {
 758       Lisp_Object function = *backlist->function;
 759       if (FUNCTIONP (function))
 760         ASET (backtrace, i++, function);
 761     }
 762   /* Make sure that unused space of working memory is filled with
 763      nil.  */
 764   for (; i < ASIZE (backtrace); i++)
 765     ASET (backtrace, i, Qnil);
 766
 767   /* If the backtrace is not empty, */
 768   if (!NILP (AREF (backtrace, 0)))
 769     {
 770       /* then record counts.  */
 771       struct slot *slot = ensure_slot (log, backtrace);
 772       slot->count += count;
 773       slot->elapsed += elapsed;
 774     }
 775 }
 776
 777 static void
 778 record_backtrace (struct log *log, size_t count, size_t elapsed)
 779 {
 780   record_backtrace_under (log, Qnil, count, elapsed);
 781 }
 782
 783 /* Convert LOG to a list.  */
 784
 785 static Lisp_Object
 786 log_object (struct log *log)
 787 {
 788   int i;
 789   Lisp_Object slots = Qnil;
 790
 791   if (log->others_count != 0 || log->others_elapsed != 0)
 792     {
 793       /* Add others slot.  */
 794       Lisp_Object others_slot
 795         = list3 (list1 (Qt),
 796                  make_number (log->others_count),
 797                  make_number (log->others_elapsed));
 798       slots = list1 (others_slot);
 799     }
 800
 801   for (i = 0; i < log->slot_heap->size; i++)
 802     {
 803       struct slot *s = &log->slot_heap->data[i];
 804       if (s->used)
 805         {
 806           Lisp_Object slot = slot_object (s);
 807           slots = Fcons (slot, slots);
 808         }
 809     }
 810
 811   return list4 (log->type, Qnil, Fcurrent_time (), slots);
 812 }
 813
 814 \f
 815 /* Sample profiler.  */
 816
 817 static struct log *sample_log;
 818
 819 /* The current sample interval in millisecond.  */
 820
 821 static int current_sample_interval;
 822
 823 DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start,
 824        1, 1, 0,
 825        doc: /* Start or restart sample profiler.  Sample profiler will
 826 take samples each SAMPLE-INTERVAL in millisecond.  See also
 827 `profiler-slot-heap-size' and `profiler-max-stack-depth'.  */)
 828   (Lisp_Object sample_interval)
 829 {
 830   struct sigaction sa;
 831   struct itimerval timer;
 832
 833   if (sample_profiler_running)
 834     error ("Sample profiler is already running");
 835
 836   if (!sample_log)
 837     sample_log = make_log ("sample",
 838                            profiler_slot_heap_size,
 839                            profiler_max_stack_depth);
 840
 841   current_sample_interval = XINT (sample_interval);
 842
 843   sa.sa_sigaction = sigprof_handler;
 844   sa.sa_flags = SA_RESTART | SA_SIGINFO;
 845   sigemptyset (&sa.sa_mask);
 846   sigaction (SIGPROF, &sa, 0);
 847
 848   timer.it_interval.tv_sec = 0;
 849   timer.it_interval.tv_usec = current_sample_interval * 1000;
 850   timer.it_value = timer.it_interval;
 851   setitimer (ITIMER_PROF, &timer, 0);
 852
 853   sample_profiler_running = 1;
 854
 855   return Qt;
 856 }
 857
 858 DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop,
 859        0, 0, 0,
 860        doc: /* Stop sample profiler.  Profiler log will be kept.  */)
 861   (void)
 862 {
 863   if (!sample_profiler_running)
 864     error ("Sample profiler is not running");
 865   sample_profiler_running = 0;
 866
 867   setitimer (ITIMER_PROF, 0, 0);
 868
 869   return Qt;
 870 }
 871
 872 DEFUN ("sample-profiler-reset", Fsample_profiler_reset, Ssample_profiler_reset,
 873        0, 0, 0,
 874        doc: /* Clear sample profiler log.  */)
 875   (void)
 876 {
 877   if (sample_log)
 878     {
 879       if (sample_profiler_running)
 880         {
 881           block_sigprof ();
 882           clear_log (sample_log);
 883           unblock_sigprof ();
 884         }
 885       else
 886         {
 887           free_log (sample_log);
 888           sample_log = 0;
 889         }
 890     }
 891 }
 892
 893 DEFUN ("sample-profiler-running-p",
 894        Fsample_profiler_running_p, Ssample_profiler_running_p,
 895        0, 0, 0,
 896        doc: /* Return t if sample profiler is running.  */)
 897   (void)
 898 {
 899   return sample_profiler_running ? Qt : Qnil;
 900 }
 901
 902 DEFUN ("sample-profiler-log",
 903        Fsample_profiler_log, Ssample_profiler_log,
 904        0, 0, 0,
 905        doc: /* Return sample profiler log.  The data is a list of
 906 (sample nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the
 907 log is collected and SLOTS is a list of slots.  */)
 908   (void)
 909 {
 910   int i;
 911   Lisp_Object result = Qnil;
 912
 913   if (sample_log)
 914     {
 915       if (sample_profiler_running)
 916         {
 917           block_sigprof ();
 918           result = log_object (sample_log);
 919           unblock_sigprof ();
 920         }
 921       else
 922         result = log_object (sample_log);
 923     }
 924
 925   return result;
 926 }
 927
 928 \f
 929 /* Memory profiler.  */
 930
 931 static struct log *memory_log;
 932
 933 DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start,
 934        0, 0, 0,
 935        doc: /* Start/restart memory profiler.  See also
 936 `profiler-slot-heap-size' and `profiler-max-stack-depth'.  */)
 937   (void)
 938 {
 939   if (memory_profiler_running)
 940     error ("Memory profiler is already running");
 941
 942   if (!memory_log)
 943     memory_log = make_log ("memory",
 944                            profiler_slot_heap_size,
 945                            profiler_max_stack_depth);
 946
 947   memory_profiler_running = 1;
 948
 949   return Qt;
 950 }
 951
 952 DEFUN ("memory-profiler-stop",
 953        Fmemory_profiler_stop, Smemory_profiler_stop,
 954        0, 0, 0,
 955        doc: /* Stop memory profiler.  Profiler log will be kept.  */)
 956   (void)
 957 {
 958   if (!memory_profiler_running)
 959     error ("Memory profiler is not running");
 960   memory_profiler_running = 0;
 961
 962   return Qt;
 963 }
 964
 965 DEFUN ("memory-profiler-reset",
 966        Fmemory_profiler_reset, Smemory_profiler_reset,
 967        0, 0, 0,
 968        doc: /* Clear memory profiler log.  */)
 969   (void)
 970 {
 971   if (memory_log)
 972     {
 973       if (memory_profiler_running)
 974         clear_log (memory_log);
 975       else
 976         {
 977           free_log (memory_log);
 978           memory_log = 0;
 979         }
 980     }
 981 }
 982
 983 DEFUN ("memory-profiler-running-p",
 984        Fmemory_profiler_running_p, Smemory_profiler_running_p,
 985        0, 0, 0,
 986        doc: /* Return t if memory profiler is running.  */)
 987   (void)
 988 {
 989   return memory_profiler_running ? Qt : Qnil;
 990 }
 991
 992 DEFUN ("memory-profiler-log",
 993        Fmemory_profiler_log, Smemory_profiler_log,
 994        0, 0, 0,
 995        doc: /* Return memory profiler log.  The data is a list of
 996 (memory nil TIMESTAMP SLOTS), where TIMESTAMP is a timestamp when the
 997 log is collected and SLOTS is a list of slots.  */)
 998   (void)
 999 {
1000   Lisp_Object result = Qnil;
1001
1002   if (memory_log)
1003     result = log_object (memory_log);
1004
1005   return result;
1006 }
1007
1008 \f
1009 /* Signals and probes.  */
1010
1011 /* Signal handler for sample profiler.  */
1012
1013 static void
1014 sigprof_handler (int signal, siginfo_t *info, void *ctx)
1015 {
1016   if (!is_in_trace && sample_log)
1017     record_backtrace (sample_log, 1, current_sample_interval);
1018 }
1019
1020 static void
1021 block_sigprof (void)
1022 {
1023   sigset_t sigset;
1024   sigemptyset (&sigset);
1025   sigaddset (&sigset, SIGPROF);
1026   sigprocmask (SIG_BLOCK, &sigset, 0);
1027 }
1028
1029 static void
1030 unblock_sigprof (void)
1031 {
1032   sigset_t sigset;
1033   sigemptyset (&sigset);
1034   sigaddset (&sigset, SIGPROF);
1035   sigprocmask (SIG_UNBLOCK, &sigset, 0);
1036 }
1037
1038 /* Record that the current backtrace allocated SIZE bytes.  */
1039
1040 void
1041 malloc_probe (size_t size)
1042 {
1043   if (memory_log)
1044     record_backtrace (memory_log, size, 0);
1045 }
1046
1047 /* Record that GC happened in the current backtrace.  */
1048
1049 void
1050 gc_probe (size_t size, size_t elapsed)
1051 {
1052   if (sample_log)
1053     record_backtrace_under (sample_log, Qgc, 1, elapsed);
1054   if (memory_log)
1055     record_backtrace_under (memory_log, Qgc, size, elapsed);
1056 }
1057
1058 \f
1059
1060 void
1061 mark_profiler (void)
1062 {
1063   if (sample_log)
1064     {
1065       if (sample_profiler_running)
1066         {
1067           block_sigprof ();
1068           mark_log (sample_log);
1069           unblock_sigprof ();
1070         }
1071       else
1072         mark_log (sample_log);
1073     }
1074   if (memory_log)
1075     mark_log (memory_log);
1076 }
1077
1078 void
1079 syms_of_profiler (void)
1080 {
1081   DEFSYM (Qgc, "gc");
1082
1083   DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
1084               doc: /* FIXME */);
1085   profiler_max_stack_depth = 16;
1086   DEFVAR_INT ("profiler-slot-heap-size", profiler_slot_heap_size,
1087               doc: /* FIXME */);
1088   profiler_slot_heap_size = 10000;
1089
1090   defsubr (&Sprofiler_set_filter_pattern);
1091
1092   defsubr (&Ssample_profiler_start);
1093   defsubr (&Ssample_profiler_stop);
1094   defsubr (&Ssample_profiler_reset);
1095   defsubr (&Ssample_profiler_running_p);
1096   defsubr (&Ssample_profiler_log);
1097
1098   defsubr (&Smemory_profiler_start);
1099   defsubr (&Smemory_profiler_stop);
1100   defsubr (&Smemory_profiler_reset);
1101   defsubr (&Smemory_profiler_running_p);
1102   defsubr (&Smemory_profiler_log);
1103 }