/* Why the hell is XEmacs so fucking slow?
   Copyright (C) 1996 Ben Wing.

This file is part of XEmacs.

XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.

XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

#include <config.h>
#include "lisp.h"

#include "backtrace.h"
#include "bytecode.h"
#include "hash.h"

#include "syssignal.h"
#include "systime.h"

/*

We implement our own profiling scheme so that we can determine things
like which Lisp functions are occupying the most time.  Any standard
OS-provided profiling works on C functions, which is somewhat useless.

The basic idea is simple.  We set a profiling timer using
setitimer (ITIMER_PROF), which generates a SIGPROF every so often.
\(This runs not in real time but rather when the process is executing
or the system is running on behalf of the process.) When the signal
goes off, we see what we're in, and add by 1 the count associated with
that function.

It would be nice to use the Lisp allocation mechanism etc. to keep
track of the profiling information, but we can't because that's not
safe, and trying to make it safe would be much more work than is
worth.

*/

c_hashtable big_profile_table;

int default_profiling_interval;

int profiling_active;

/* The normal flag in_display is used as a critical-section flag
   and is not set the whole time we're in redisplay. */
int profiling_redisplay_flag;

Lisp_Object QSin_redisplay;
Lisp_Object QSin_garbage_collection;
Lisp_Object QSprocessing_events_at_top_level;
Lisp_Object QSunknown;

static SIGTYPE
sigprof_handler (int signo)
{
  Lisp_Object fun;

  if (profiling_redisplay_flag)
    fun = QSin_redisplay;
  else if (gc_in_progress)
    fun = QSin_garbage_collection;
  else if (backtrace_list)
    {
      fun = *backtrace_list->function;

      XUNMARK (fun);
      if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun))
        fun = QSunknown;
    }
  else
    fun = QSprocessing_events_at_top_level;

  {
    long count;
    CONST void *vval;
    
    if (gethash (LISP_TO_VOID (fun), big_profile_table, &vval))
      count = (long) vval;
    else
      count = 0;
    count++;
    vval = (CONST void *) count;
    puthash (LISP_TO_VOID (fun), (void *) vval, big_profile_table);
  }
}

DEFUN ("start-profiling", Fstart_profiling, 0, 1, 0, /*
Start profiling, with profile queries every MICROSECS.
If MICROSECS is nil or omitted, the value of `default-profiling-interval'
is used.

You can retrieve the recorded profiling info using `get-profiling-info'.

Starting and stopping profiling does not clear the currently recorded
info.  Thus you can start and stop as many times as you want and everything
will be properly accumulated.
*/
       (microsecs))
{
  int msecs;
  struct itimerval foo;

  /* #### The hash code can safely be called from a signal handler
     except when it has to grow the hashtable.  In this case, it calls
     realloc(), which is not (in general) re-entrant.  We just be
     sleazy and make the table large enough that it (hopefully) won't
     need to be realloc()ed. */
  if (!big_profile_table)
    big_profile_table = make_hashtable (10000);
  if (NILP (microsecs))
    msecs = default_profiling_interval;
  else
    {
      CHECK_NATNUM (microsecs);
      msecs = XINT (microsecs);
    }
  if (msecs <= 0)
    msecs = 1000;

  signal (SIGPROF, sigprof_handler);
  foo.it_value.tv_sec = 0;
  foo.it_value.tv_usec = msecs;
  EMACS_NORMALIZE_TIME (foo.it_value);
  foo.it_interval = foo.it_value;
  profiling_active = 1;
  setitimer (ITIMER_PROF, &foo, 0);
  return Qnil;
}

DEFUN ("stop-profiling", Fstop_profiling, 0, 0, 0, /*
Stop profiling.
*/
       ())
{
  struct itimerval foo;

  foo.it_value.tv_sec = 0;
  foo.it_value.tv_usec = 0;
  foo.it_interval = foo.it_value;
  setitimer (ITIMER_PROF, &foo, 0);
  profiling_active = 0;
  signal (SIGPROF, fatal_error_signal);
  return Qnil;
}

struct get_profiling_info_closure
{
  Lisp_Object accum;
};

static void
get_profiling_info_maphash (CONST void *void_key,
			    void *void_val,
			    void *void_closure)
{
  /* This function can GC */
  Lisp_Object key;
  struct get_profiling_info_closure *closure = void_closure;
  EMACS_INT val;

  CVOID_TO_LISP (key, void_key);
  val = (EMACS_INT) void_val;

  closure->accum = Fcons (Fcons (key, make_int (val)),
			  closure->accum);
}

DEFUN ("get-profiling-info", Fget_profiling_info, 0, 0, 0, /*
Return the profiling info as an alist.
*/
       ())
{
  struct get_profiling_info_closure closure;

  closure.accum = Qnil;
  if (big_profile_table)
    maphash (get_profiling_info_maphash, big_profile_table, &closure);
  return closure.accum;
}

struct mark_profiling_info_closure
{
  void (*markfun) (Lisp_Object);
};

static void
mark_profiling_info_maphash (CONST void *void_key,
			     void *void_val,
			     void *void_closure)
{
  /* This function can GC */
  Lisp_Object key;
  struct mark_profiling_info_closure *closure = void_closure;

  CVOID_TO_LISP (key, void_key);
  (closure->markfun) (key);
}

void
mark_profiling_info (void (*markfun) (Lisp_Object))
{
  struct mark_profiling_info_closure closure;

  closure.markfun = markfun;
  if (big_profile_table)
    maphash (mark_profiling_info_maphash, big_profile_table, &closure);
}

DEFUN ("clear-profiling-info", Fclear_profiling_info, 0, 0, 0, /*
Clear out the recorded profiling info.
*/
       ())
{
  if (big_profile_table)
    clrhash (big_profile_table);
  return Qnil;
}

DEFUN ("profiling-active-p", Fprofiling_active_p, 0, 0, 0, /*
Return non-nil if profiling information is currently being recorded.
*/
       ())
{
  return profiling_active ? Qt : Qnil;
}

void
syms_of_profile (void)
{
  DEFSUBR (Fstart_profiling);
  DEFSUBR (Fstop_profiling);
  DEFSUBR (Fget_profiling_info);
  DEFSUBR (Fclear_profiling_info);
  DEFSUBR (Fprofiling_active_p);
}

void
vars_of_profile (void)
{
  DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /*
Default time in microseconds between profiling queries.
Used when the argument to `start-profiling' is nil or omitted.
Note that the time in question is CPU time (when the program is executing
or the kernel is executing on behalf of the program) and not real time.
*/ );
  default_profiling_interval = 1000;

  QSin_redisplay = build_string ("(in redisplay)");
  staticpro (&QSin_redisplay);
  QSin_garbage_collection = build_string ("(in garbage collection)");
  staticpro (&QSin_garbage_collection);
  QSunknown = build_string ("(unknown)");
  staticpro (&QSunknown);
  QSprocessing_events_at_top_level =
    build_string ("(processing events at top level)");
  staticpro (&QSprocessing_events_at_top_level);
}