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

   1 /* GNU Emacs 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 static void sigprof_handler (int, siginfo_t *, void *);
  29 static void block_sigprof (void);
  30 static void unblock_sigprof (void);
  31
  32 int sample_profiler_running;
  33 int memory_profiler_running;
  34
  35 \f
  36
  37 /* Filters */
  38
  39 enum pattern_type
  40 {
  41   pattern_exact,                /* foo */
  42   pattern_body_exact,           /* *foo* */
  43   pattern_pre_any,              /* *foo */
  44   pattern_post_any,             /* foo* */
  45   pattern_body_any              /* foo*bar */
  46 };
  47
  48 struct pattern
  49 {
  50   enum pattern_type type;
  51   char *exact;
  52   char *extra;
  53   int exact_length;
  54   int extra_length;
  55 };
  56
  57 static struct pattern *
  58 parse_pattern (const char *pattern)
  59 {
  60   int length = strlen (pattern);
  61   enum pattern_type type;
  62   char *exact;
  63   char *extra = 0;
  64   struct pattern *pat =
  65     (struct pattern *) xmalloc (sizeof (struct pattern));
  66
  67   if (length > 1
  68       && *pattern == '*'
  69       && pattern[length - 1] == '*')
  70     {
  71       type = pattern_body_exact;
  72       exact = xstrdup (pattern + 1);
  73       exact[length - 2] = 0;
  74     }
  75   else if (*pattern == '*')
  76     {
  77       type = pattern_pre_any;
  78       exact = xstrdup (pattern + 1);
  79     }
  80   else if (pattern[length - 1] == '*')
  81     {
  82       type = pattern_post_any;
  83       exact = xstrdup (pattern);
  84       exact[length - 1] = 0;
  85     }
  86   else if (strchr (pattern, '*'))
  87     {
  88       type = pattern_body_any;
  89       exact = xstrdup (pattern);
  90       extra = strchr (exact, '*');
  91       *extra++ = 0;
  92     }
  93   else
  94     {
  95       type = pattern_exact;
  96       exact = xstrdup (pattern);
  97     }
  98
  99   pat->type = type;
 100   pat->exact = exact;
 101   pat->extra = extra;
 102   pat->exact_length = strlen (exact);
 103   pat->extra_length = extra ? strlen (extra) : 0;
 104
 105   return pat;
 106 }
 107
 108 static void
 109 free_pattern (struct pattern *pattern)
 110 {
 111   xfree (pattern->exact);
 112   xfree (pattern);
 113 }
 114
 115 static int
 116 pattern_match_1 (enum pattern_type type,
 117                  const char *exact,
 118                  int exact_length,
 119                  const char *string,
 120                  int length)
 121 {
 122   if (exact_length > length)
 123     return 0;
 124   switch (type)
 125     {
 126     case pattern_exact:
 127       return exact_length == length && !strncmp (exact, string, length);
 128     case pattern_body_exact:
 129       return strstr (string, exact) != 0;
 130     case pattern_pre_any:
 131       return !strncmp (exact, string + (length - exact_length), exact_length);
 132     case pattern_post_any:
 133       return !strncmp (exact, string, exact_length);
 134     case pattern_body_any:
 135       return 0;
 136     }
 137 }
 138
 139 static int
 140 pattern_match (struct pattern *pattern, const char *string)
 141 {
 142   int length = strlen (string);
 143   switch (pattern->type)
 144     {
 145     case pattern_body_any:
 146       if (pattern->exact_length + pattern->extra_length > length)
 147         return 0;
 148       return pattern_match_1 (pattern_post_any,
 149                               pattern->exact,
 150                               pattern->exact_length,
 151                               string, length)
 152         &&   pattern_match_1 (pattern_pre_any,
 153                               pattern->extra,
 154                               pattern->extra_length,
 155                               string, length);
 156     default:
 157       return pattern_match_1 (pattern->type,
 158                               pattern->exact,
 159                               pattern->exact_length,
 160                               string, length);
 161     }
 162 }
 163
 164 static int
 165 match (const char *pattern, const char *string)
 166 {
 167   int res;
 168   struct pattern *pat = parse_pattern (pattern);
 169   res = pattern_match (pat, string);
 170   free_pattern (pat);
 171   return res;
 172 }
 173
 174 #if 0
 175 static void
 176 should_match (const char *pattern, const char *string)
 177 {
 178   putchar (match (pattern, string) ? '.' : 'F');
 179 }
 180
 181 static void
 182 should_not_match (const char *pattern, const char *string)
 183 {
 184   putchar (match (pattern, string) ? 'F' : '.');
 185 }
 186
 187 static void
 188 pattern_match_tests (void)
 189 {
 190   should_match ("", "");
 191   should_not_match ("", "a");
 192   should_match ("a", "a");
 193   should_not_match ("a", "ab");
 194   should_not_match ("ab", "a");
 195   should_match ("*a*", "a");
 196   should_match ("*a*", "ab");
 197   should_match ("*a*", "ba");
 198   should_match ("*a*", "bac");
 199   should_not_match ("*a*", "");
 200   should_not_match ("*a*", "b");
 201   should_match ("*", "");
 202   should_match ("*", "a");
 203   should_match ("a*", "a");
 204   should_match ("a*", "ab");
 205   should_not_match ("a*", "");
 206   should_not_match ("a*",  "ba");
 207   should_match ("*a", "a");
 208   should_match ("*a", "ba");
 209   should_not_match ("*a", "");
 210   should_not_match ("*a", "ab");
 211   should_match ("a*b", "ab");
 212   should_match ("a*b", "acb");
 213   should_match ("a*b", "aab");
 214   should_match ("a*b", "abb");
 215   should_not_match ("a*b", "");
 216   should_not_match ("a*b", "");
 217   should_not_match ("a*b", "abc");
 218   puts ("");
 219 }
 220 #endif
 221
 222 static struct pattern *filter_pattern;
 223
 224 static void
 225 set_filter_pattern (const char *pattern)
 226 {
 227   if (sample_profiler_running)
 228     block_sigprof ();
 229
 230   if (filter_pattern)
 231     {
 232       free_pattern (filter_pattern);
 233       filter_pattern = 0;
 234     }
 235   if (!pattern) return;
 236   filter_pattern = parse_pattern (pattern);
 237
 238   if (sample_profiler_running)
 239     unblock_sigprof ();
 240 }
 241
 242 static int
 243 apply_filter_1 (Lisp_Object function)
 244 {
 245   const char *name;
 246
 247   if (!filter_pattern)
 248     return 1;
 249
 250   if (SYMBOLP (function))
 251     name = SDATA (SYMBOL_NAME (function));
 252   else if (SUBRP (function))
 253     name = XSUBR (function)->symbol_name;
 254   else
 255     return 0;
 256
 257   return pattern_match (filter_pattern, name);
 258 }
 259
 260 static int
 261 apply_filter (struct backtrace *backlist)
 262 {
 263   while (backlist)
 264     {
 265       if (apply_filter_1 (*backlist->function))
 266         return 1;
 267       backlist = backlist->next;
 268     }
 269   return 0;
 270 }
 271
 272 DEFUN ("profiler-set-filter-pattern",
 273        Fprofiler_set_filter_pattern, Sprofiler_set_filter_pattern,
 274        1, 1, "sPattern: ",
 275        doc: /* FIXME */)
 276   (Lisp_Object pattern)
 277 {
 278   if (NILP (pattern))
 279     {
 280       set_filter_pattern (0);
 281       return Qt;
 282     }
 283   else if (!STRINGP (pattern))
 284     error ("Invalid type of profiler filter pattern");
 285
 286   set_filter_pattern (SDATA (pattern));
 287
 288   return Qt;
 289 }
 290
 291 \f
 292
 293 /* Backtraces */
 294
 295 static Lisp_Object
 296 make_backtrace (int size)
 297 {
 298   return Fmake_vector (make_number (size), Qnil);
 299 }
 300
 301 static EMACS_UINT
 302 backtrace_hash (Lisp_Object backtrace)
 303 {
 304   int i;
 305   EMACS_UINT hash = 0;
 306   for (i = 0; i < ASIZE (backtrace); i++)
 307     /* FIXME */
 308     hash = SXHASH_COMBINE (XUINT (AREF (backtrace, i)), hash);
 309   return hash;
 310 }
 311
 312 static int
 313 backtrace_equal (Lisp_Object a, Lisp_Object b)
 314 {
 315   int i, j;
 316
 317   for (i = 0, j = 0;; i++, j++)
 318     {
 319       Lisp_Object x = i < ASIZE (a) ? AREF (a, i) : Qnil;
 320       Lisp_Object y = j < ASIZE (b) ? AREF (b, j) : Qnil;
 321       if (NILP (x) && NILP (y))
 322         break;
 323       else if (!EQ (x, y))
 324         return 0;
 325     }
 326
 327   return 1;
 328 }
 329
 330 static Lisp_Object
 331 backtrace_object_1 (Lisp_Object backtrace, int i)
 332 {
 333   if (i >= ASIZE (backtrace) || NILP (AREF (backtrace, i)))
 334     return Qnil;
 335   else
 336     return Fcons (AREF (backtrace, i), backtrace_object_1 (backtrace, i + 1));
 337 }
 338
 339 static Lisp_Object
 340 backtrace_object (Lisp_Object backtrace)
 341 {
 342   backtrace_object_1 (backtrace, 0);
 343 }
 344
 345 \f
 346
 347 /* Slots */
 348
 349 struct slot
 350 {
 351   struct slot *next, *prev;
 352   Lisp_Object backtrace;
 353   unsigned int count;
 354   unsigned int elapsed;
 355   unsigned char used : 1;
 356 };
 357
 358 static void
 359 mark_slot (struct slot *slot)
 360 {
 361   mark_object (slot->backtrace);
 362 }
 363
 364 static Lisp_Object
 365 slot_object (struct slot *slot)
 366 {
 367   return list3 (backtrace_object (slot->backtrace),
 368                 make_number (slot->count),
 369                 make_number (slot->elapsed));
 370 }
 371
 372 \f
 373
 374 /* Slot heaps */
 375
 376 struct slot_heap
 377 {
 378   unsigned int size;
 379   struct slot *data;
 380   struct slot *free_list;
 381 };
 382
 383 static void
 384 clear_slot_heap (struct slot_heap *heap)
 385 {
 386   int i;
 387   struct slot *data;
 388   struct slot *free_list;
 389
 390   data = heap->data;
 391
 392   for (i = 0; i < heap->size; i++)
 393     data[i].used = 0;
 394
 395   free_list = heap->free_list = heap->data;
 396   for (i = 1; i < heap->size; i++)
 397     {
 398       free_list->next = &data[i];
 399       free_list = free_list->next;
 400     }
 401   free_list->next = 0;
 402 }
 403
 404 static struct slot_heap *
 405 make_slot_heap (unsigned int size, int max_stack_depth)
 406 {
 407   int i;
 408   struct slot_heap *heap;
 409   struct slot *data;
 410
 411   data = (struct slot *) xmalloc (sizeof (struct slot) * size);
 412   for (i = 0; i < size; i++)
 413     data[i].backtrace = make_backtrace (max_stack_depth);
 414
 415   heap = (struct slot_heap *) xmalloc (sizeof (struct slot_heap));
 416   heap->size = size;
 417   heap->data = data;
 418   clear_slot_heap (heap);
 419
 420   return heap;
 421 }
 422
 423 static void
 424 free_slot_heap (struct slot_heap *heap)
 425 {
 426   int i;
 427   struct slot *data = heap->data;
 428   for (i = 0; i < heap->size; i++)
 429     data[i].backtrace = Qnil;
 430   xfree (data);
 431   xfree (heap);
 432 }
 433
 434 static void
 435 mark_slot_heap (struct slot_heap *heap)
 436 {
 437   int i;
 438   for (i = 0; i < heap->size; i++)
 439     mark_slot (&heap->data[i]);
 440 }
 441
 442 static struct slot *
 443 allocate_slot (struct slot_heap *heap)
 444 {
 445   struct slot *slot;
 446   if (!heap->free_list)
 447     return 0;
 448   slot = heap->free_list;
 449   slot->count = 0;
 450   slot->elapsed = 0;
 451   slot->used = 1;
 452   heap->free_list = heap->free_list->next;
 453   return slot;
 454 }
 455
 456 static void
 457 free_slot (struct slot_heap *heap, struct slot *slot)
 458 {
 459   eassert (slot->used);
 460   slot->used = 0;
 461   slot->next = heap->free_list;
 462   heap->free_list = slot;
 463 }
 464
 465 static struct slot *
 466 min_slot (struct slot_heap *heap)
 467 {
 468   int i;
 469   struct slot *min = 0;
 470   for (i = 0; i < heap->size; i++)
 471     {
 472       struct slot *slot = &heap->data[i];
 473       if (!min || (slot->used && slot->count < min->count))
 474         min = slot;
 475     }
 476   return min;
 477 }
 478
 479 \f
 480
 481 /* Slot tables */
 482
 483 struct slot_table
 484 {
 485   unsigned int size;
 486   struct slot **data;
 487 };
 488
 489 static void
 490 clear_slot_table (struct slot_table *table)
 491 {
 492   int i;
 493   for (i = 0; i < table->size; i++)
 494     table->data[i] = 0;
 495 }
 496
 497 static struct slot_table *
 498 make_slot_table (int size)
 499 {
 500   struct slot_table *table
 501     = (struct slot_table *) xmalloc (sizeof (struct slot_table));
 502   table->size = size;
 503   table->data = (struct slot **) xmalloc (sizeof (struct slot *) * size);
 504   clear_slot_table (table);
 505   return table;
 506 }
 507
 508 static void
 509 free_slot_table (struct slot_table *table)
 510 {
 511   xfree (table->data);
 512   xfree (table);
 513 }
 514
 515 static void
 516 remove_slot (struct slot_table *table, struct slot *slot)
 517 {
 518   if (slot->prev)
 519     slot->prev->next = slot->next;
 520   else
 521     {
 522       EMACS_UINT hash = backtrace_hash (slot->backtrace);
 523       table->data[hash % table->size] = slot->next;
 524     }
 525   if (slot->next)
 526     slot->next->prev = slot->prev;
 527 }
 528
 529 \f
 530
 531 /* Logs */
 532
 533 struct log
 534 {
 535   Lisp_Object type;
 536   Lisp_Object backtrace;
 537   struct slot_heap *slot_heap;
 538   struct slot_table *slot_table;
 539   unsigned int others_count;
 540   unsigned int others_elapsed;
 541 };
 542
 543 static struct log *
 544 make_log (const char *type, int heap_size, int max_stack_depth)
 545 {
 546   struct log *log =
 547     (struct log *) xmalloc (sizeof (struct log));
 548   log->type = intern (type);
 549   log->backtrace = make_backtrace (max_stack_depth);
 550   log->slot_heap = make_slot_heap (heap_size, max_stack_depth);
 551   log->slot_table = make_slot_table (max (256, heap_size) / 10);
 552   log->others_count = 0;
 553   log->others_elapsed = 0;
 554   return log;
 555 }
 556
 557 static void
 558 free_log (struct log *log)
 559 {
 560   log->backtrace = Qnil;
 561   free_slot_heap (log->slot_heap);
 562   free_slot_table (log->slot_table);
 563 }
 564
 565 static void
 566 mark_log (struct log *log)
 567 {
 568   mark_object (log->type);
 569   mark_object (log->backtrace);
 570   mark_slot_heap (log->slot_heap);
 571 }
 572
 573 static void
 574 clear_log (struct log *log)
 575 {
 576   clear_slot_heap (log->slot_heap);
 577   clear_slot_table (log->slot_table);
 578   log->others_count = 0;
 579   log->others_elapsed = 0;
 580 }
 581
 582 static void
 583 evict_slot (struct log *log, struct slot *slot)
 584 {
 585   log->others_count += slot->count;
 586   log->others_elapsed += slot->elapsed;
 587   remove_slot (log->slot_table, slot);
 588   free_slot (log->slot_heap, slot);
 589 }
 590
 591 static void
 592 evict_min_slot (struct log *log)
 593 {
 594   struct slot *min = min_slot (log->slot_heap);
 595   if (min)
 596     evict_slot (log, min);
 597 }
 598
 599 static struct slot *
 600 new_slot (struct log *log, Lisp_Object backtrace)
 601 {
 602   int i;
 603   struct slot *slot = allocate_slot (log->slot_heap);
 604
 605   if (!slot)
 606     {
 607       evict_min_slot (log);
 608       slot = allocate_slot (log->slot_heap);
 609       eassert (slot);
 610     }
 611
 612   slot->prev = 0;
 613   slot->next = 0;
 614   for (i = 0; i < ASIZE (backtrace); i++)
 615     ASET (slot->backtrace, i, AREF (backtrace, i));
 616
 617   return slot;
 618 }
 619
 620 static struct slot *
 621 ensure_slot (struct log *log, Lisp_Object backtrace)
 622 {
 623   EMACS_UINT hash = backtrace_hash (backtrace);
 624   int index = hash % log->slot_table->size;
 625   struct slot *slot = log->slot_table->data[index];
 626   struct slot *prev = slot;
 627
 628   while (slot)
 629     {
 630       if (backtrace_equal (backtrace, slot->backtrace))
 631         goto found;
 632       prev = slot;
 633       slot = slot->next;
 634     }
 635
 636   slot = new_slot (log, backtrace);
 637   if (prev)
 638     {
 639       slot->prev = prev;
 640       prev->next = slot;
 641     }
 642   else
 643     log->slot_table->data[index] = slot;
 644
 645  found:
 646   return slot;
 647 }
 648
 649 static void
 650 record_backtrace (struct log *log, unsigned int count, unsigned int elapsed)
 651 {
 652   int i;
 653   Lisp_Object backtrace = log->backtrace;
 654   struct backtrace *backlist = backtrace_list;
 655
 656   if (!apply_filter (backlist)) return;
 657
 658   for (i = 0; i < ASIZE (backtrace) && backlist; backlist = backlist->next)
 659     {
 660       Lisp_Object function = *backlist->function;
 661       if (FUNCTIONP (function))
 662         {
 663           ASET (backtrace, i, function);
 664           i++;
 665         }
 666     }
 667   for (; i < ASIZE (backtrace); i++)
 668     ASET (backtrace, i, Qnil);
 669
 670   if (!NILP (AREF (backtrace, 0)))
 671     {
 672       struct slot *slot = ensure_slot (log, backtrace);
 673       slot->count += count;
 674       slot->elapsed += elapsed;
 675     }
 676 }
 677
 678 static Lisp_Object
 679 log_object (struct log *log)
 680 {
 681   int i;
 682   Lisp_Object slots = Qnil;
 683
 684   if (log->others_count != 0 || log->others_elapsed != 0)
 685     slots = list1 (list3 (list1 (Qt),
 686                           make_number (log->others_count),
 687                           make_number (log->others_elapsed)));
 688
 689   for (i = 0; i < log->slot_heap->size; i++)
 690     {
 691       struct slot *s = &log->slot_heap->data[i];
 692       if (s->used)
 693         {
 694           Lisp_Object slot = slot_object (s);
 695           slots = Fcons (slot, slots);
 696         }
 697     }
 698
 699   return list4 (log->type, Qnil, Fcurrent_time (), slots);
 700 }
 701
 702 \f
 703
 704 /* Sample profiler */
 705
 706 static struct log *sample_log;
 707 static int current_sample_interval;
 708
 709 DEFUN ("sample-profiler-start", Fsample_profiler_start, Ssample_profiler_start,
 710        1, 1, 0,
 711        doc: /* FIXME */)
 712   (Lisp_Object sample_interval)
 713 {
 714   struct sigaction sa;
 715   struct itimerval timer;
 716
 717   if (sample_profiler_running)
 718     error ("Sample profiler is already running");
 719
 720   if (!sample_log)
 721     sample_log = make_log ("sample",
 722                            profiler_slot_heap_size,
 723                            profiler_max_stack_depth);
 724
 725   current_sample_interval = XINT (sample_interval);
 726
 727   sa.sa_sigaction = sigprof_handler;
 728   sa.sa_flags = SA_RESTART | SA_SIGINFO;
 729   sigemptyset (&sa.sa_mask);
 730   sigaction (SIGPROF, &sa, 0);
 731
 732   timer.it_interval.tv_sec = 0;
 733   timer.it_interval.tv_usec = current_sample_interval * 1000;
 734   timer.it_value = timer.it_interval;
 735   setitimer (ITIMER_PROF, &timer, 0);
 736
 737   sample_profiler_running = 1;
 738
 739   return Qt;
 740 }
 741
 742 DEFUN ("sample-profiler-stop", Fsample_profiler_stop, Ssample_profiler_stop,
 743        0, 0, 0,
 744        doc: /* FIXME */)
 745   (void)
 746 {
 747   if (!sample_profiler_running)
 748     error ("Sample profiler is not running");
 749   sample_profiler_running = 0;
 750
 751   setitimer (ITIMER_PROF, 0, 0);
 752
 753   return Qt;
 754 }
 755
 756 DEFUN ("sample-profiler-reset", Fsample_profiler_reset, Ssample_profiler_reset,
 757        0, 0, 0,
 758        doc: /* FIXME */)
 759   (void)
 760 {
 761   if (sample_log)
 762     {
 763       if (sample_profiler_running)
 764         {
 765           block_sigprof ();
 766           clear_log (sample_log);
 767           unblock_sigprof ();
 768         }
 769       else
 770         {
 771           free_log (sample_log);
 772           sample_log = 0;
 773         }
 774     }
 775 }
 776
 777 DEFUN ("sample-profiler-running-p",
 778        Fsample_profiler_running_p, Ssample_profiler_running_p,
 779        0, 0, 0,
 780        doc: /* FIXME */)
 781   (void)
 782 {
 783   return sample_profiler_running ? Qt : Qnil;
 784 }
 785
 786 DEFUN ("sample-profiler-log",
 787        Fsample_profiler_log, Ssample_profiler_log,
 788        0, 0, 0,
 789        doc: /* FIXME */)
 790   (void)
 791 {
 792   int i;
 793   Lisp_Object result = Qnil;
 794
 795   if (sample_log)
 796     {
 797       if (sample_profiler_running)
 798         {
 799           block_sigprof ();
 800           result = log_object (sample_log);
 801           unblock_sigprof ();
 802         }
 803       else
 804         result = log_object (sample_log);
 805     }
 806
 807   return result;
 808 }
 809
 810 \f
 811
 812 /* Memory profiler */
 813
 814 static struct log *memory_log;
 815
 816 DEFUN ("memory-profiler-start", Fmemory_profiler_start, Smemory_profiler_start,
 817        0, 0, 0,
 818        doc: /* FIXME */)
 819   (void)
 820 {
 821   if (memory_profiler_running)
 822     error ("Memory profiler is already running");
 823
 824   if (!memory_log)
 825     memory_log = make_log ("memory",
 826                            profiler_slot_heap_size,
 827                            profiler_max_stack_depth);
 828
 829   memory_profiler_running = 1;
 830
 831   return Qt;
 832 }
 833
 834 DEFUN ("memory-profiler-stop",
 835        Fmemory_profiler_stop, Smemory_profiler_stop,
 836        0, 0, 0,
 837        doc: /* FIXME */)
 838   (void)
 839 {
 840   if (!memory_profiler_running)
 841     error ("Memory profiler is not running");
 842   memory_profiler_running = 0;
 843
 844   return Qt;
 845 }
 846
 847 DEFUN ("memory-profiler-reset",
 848        Fmemory_profiler_reset, Smemory_profiler_reset,
 849        0, 0, 0,
 850        doc: /* FIXME */)
 851   (void)
 852 {
 853   if (memory_log)
 854     {
 855       if (memory_profiler_running)
 856         clear_log (memory_log);
 857       else
 858         {
 859           free_log (memory_log);
 860           memory_log = 0;
 861         }
 862     }
 863 }
 864
 865 DEFUN ("memory-profiler-running-p",
 866        Fmemory_profiler_running_p, Smemory_profiler_running_p,
 867        0, 0, 0,
 868        doc: /* FIXME */)
 869   (void)
 870 {
 871   return memory_profiler_running ? Qt : Qnil;
 872 }
 873
 874 DEFUN ("memory-profiler-log",
 875        Fmemory_profiler_log, Smemory_profiler_log,
 876        0, 0, 0,
 877        doc: /* FIXME */)
 878   (void)
 879 {
 880   Lisp_Object result = Qnil;
 881
 882   if (memory_log)
 883     result = log_object (memory_log);
 884
 885   return result;
 886 }
 887
 888 \f
 889
 890 /* Signals and probes */
 891
 892 static void
 893 sigprof_handler (int signal, siginfo_t *info, void *ctx)
 894 {
 895   record_backtrace (sample_log, 1, current_sample_interval);
 896 }
 897
 898 static void
 899 block_sigprof (void)
 900 {
 901   sigset_t sigset;
 902   sigemptyset (&sigset);
 903   sigaddset (&sigset, SIGPROF);
 904   sigprocmask (SIG_BLOCK, &sigset, 0);
 905 }
 906
 907 static void
 908 unblock_sigprof (void)
 909 {
 910   sigset_t sigset;
 911   sigemptyset (&sigset);
 912   sigaddset (&sigset, SIGPROF);
 913   sigprocmask (SIG_UNBLOCK, &sigset, 0);
 914 }
 915
 916 void
 917 malloc_probe (size_t size)
 918 {
 919   record_backtrace (memory_log, size, 0);
 920 }
 921
 922 \f
 923
 924 void
 925 mark_profiler (void)
 926 {
 927   if (sample_log)
 928     {
 929       if (sample_profiler_running)
 930         {
 931           block_sigprof ();
 932           mark_log (sample_log);
 933           unblock_sigprof ();
 934         }
 935       else
 936         mark_log (sample_log);
 937     }
 938   if (memory_log)
 939     mark_log (memory_log);
 940 }
 941
 942 void
 943 syms_of_profiler (void)
 944 {
 945   DEFVAR_INT ("profiler-max-stack-depth", profiler_max_stack_depth,
 946               doc: /* FIXME */);
 947   profiler_max_stack_depth = 16;
 948   DEFVAR_INT ("profiler-slot-heap-size", profiler_slot_heap_size,
 949               doc: /* FIXME */);
 950   profiler_slot_heap_size = 10000;
 951
 952   defsubr (&Sprofiler_set_filter_pattern);
 953
 954   defsubr (&Ssample_profiler_start);
 955   defsubr (&Ssample_profiler_stop);
 956   defsubr (&Ssample_profiler_reset);
 957   defsubr (&Ssample_profiler_running_p);
 958   defsubr (&Ssample_profiler_log);
 959
 960   defsubr (&Smemory_profiler_start);
 961   defsubr (&Smemory_profiler_stop);
 962   defsubr (&Smemory_profiler_reset);
 963   defsubr (&Smemory_profiler_running_p);
 964   defsubr (&Smemory_profiler_log);
 965 }