From mboxrd@z Thu Jan  1 00:00:00 1970
Received: (from weis@localhost) by pauillac.inria.fr (8.6.10/8.6.6) id RAA01015 for caml-redistribution; Thu, 9 May 1996 17:16:50 +0200
Received: from concorde.inria.fr (concorde.inria.fr [192.93.2.39]) by pauillac.inria.fr (8.6.10/8.6.6) with ESMTP id PAA07710 for <caml-list@pauillac.inria.fr>; Wed, 8 May 1996 15:56:10 +0200
Received: from simon.cs.cornell.edu ([128.84.154.10]) by concorde.inria.fr (8.7.1/8.7.1) with SMTP id PAA27772 for <caml-list@pauillac.inria.fr>; Wed, 8 May 1996 15:56:08 +0200 (MET DST)
Received: from cloyd.cs.cornell.edu (CLOYD.CS.CORNELL.EDU [128.84.227.15]) by simon.cs.cornell.edu (8.6.10/R1.4) with ESMTP id JAA22152 for <caml-list@pauillac.inria.fr>; Wed, 8 May 1996 09:56:07 -0400
Received: from verdandi.cs.cornell.edu (VERDANDI.CS.CORNELL.EDU [128.84.254.202]) by cloyd.cs.cornell.edu (8.6.10/M1.8) with ESMTP id JAA02937; Wed, 8 May 1996 09:56:05 -0400
Received: (hayden@localhost) by verdandi.cs.cornell.edu (8.6.10/C1.3) id JAA10521; Wed, 8 May 1996 09:56:03 -0400
Date: Wed, 8 May 1996 09:56:03 -0400
Message-Id: <199605081356.JAA10521@verdandi.cs.cornell.edu>
From: Mark Hayden <hayden@cs.cornell.edu>
To: caml-list@pauillac.inria.fr
cc: hayden@cs.cornell.edu
Subject: time-based profiler for Caml Special Light
Sender: weis



Hi,
  A couple of months ago, I posted a time-based
profiler for Caml Light.  I'm posting an updated
version translated to CSL for those who are
interested.  After the README file below is a shar
script containing the required sources and a
Makefile.  Please email me if you have any
problems.

--Mark


A time-based profiler for Caml Special Light
Author: Mark Hayden, 4/96, hayden@cs.cornell.edu

This library is a simple time-based profiling package (as opposed to the
call-count profiler included with Caml Special Light).  It is intended to
be similar in design and output to the time-based parts of the gprof
package for C.  This library only works with Unix because it requires Unix
timer signals.  CSL does not provide access to Unix profiling signals, so
this version uses the normal timer signals for profiling.

This libary is very similar to the time-profiler announced by Christophe
Raffalli.  It differs in that it uses signals to avoid making calls to
Unix.times on every call to a profiled function.  So potentially this
library does not affect application performance as much.  Also, after
initialization, this profiler is designed to (I believe) not cause any
additional memory allocation.

Functions are registered with the profiler through calls to [Profile.fN
"function" function], where N is the number of arguments to the function,
from 1 to 3.  The first argument is a string name of the function and the
second argument is the function itself.  Returned is a wrapped version of
the function.  For example, if 'f' is a one argument function:

  let f arg = .... ;;

  let f = Profile.f1 "f" f ;;

The profiler is started with a call to [Profile.start()] and is ended with
a call to [Profile.stop()].  The call to end causes profiling information
to be dumped to stdout.  The output is similar to the gprof package for C:
refer to that documentation for a description.

The source file profile.ml contains an embedded test example, "testprof",
which is compiled by the included Makefile.

(**************************************************************)
(* Sample test program. *)

let test () =
  let f () = for i = 1 to 1000 do () done in
  let f = f1 "f" f in

  let g () = for i = 1 to 100 do () done in
  let g = f1 "g" g in

  let h () = for i = 1 to 1000 do f () ; g () done in
  let h = f1 "h" h in

  start () ;

  h () ;

  stop ()

(* Sample output:

    Number of samples is 128
    Each sample counts as 0.01 seconds.

    %      self    self&            self     total
   time   seconds childen    calls ms/call  ms/call  name
  92.19    1.183    1.183     1000   0.001   0.001   f
   6.25    0.080    0.080     1000   0.000   0.000   g
   1.56    0.020    1.283        1   0.020   1.283   h

*)
(**************************************************************)













#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	README
#	Makefile
#	profile.ml
#	profile.mli
#	setitimer.c
#	setitimer.mli
# This archive created: Fri May  3 20:57:28 1996
export PATH; PATH=/bin:$PATH
if test -f 'README'
then
	echo shar: will not over-write existing file "'README'"
else
cat << \SHAR_EOF > 'README'
A profiler for Caml Special Light
Author: Mark Hayden, 4/96, hayden@cs.cornell.edu

This library is a simple time-based profiling package (as opposed to the
call-count profiler included with Caml Special Light).  It is intended to
be similar in design and output to the time-based parts of the gprof
package for C.  This library only works with Unix because it requires Unix
profiling timer signals.

This libary is very similar to the time-profiler announced by Christophe
Raffalli.  It differs in that it uses signals to avoid making calls to
Unix.times on every call to a profiled function.  So potentially this
library does not affect application performance as much.  Also, after
initialization, this profiler is designed to (I believe) not cause any
additional memory allocation.

Functions are registered with the profiler through calls to [Profile.fN
"function" function], where N is the number of arguments to the function,
from 1 to 3.  The first argument is a string name of the function and the
second argument is the function itself.  Returned is a wrapped version of
the function.  For example, if 'f' is a one argument function:

  let f arg = .... ;;

  let f = Profile.f1 "f" f ;;

The profiler is started with a call to [Profile.start()] and is ended with
a call to [Profile.stop()].  The call to profile_end causes profiling
information to be dumped to stdout.  The output is similar to the gprof
package for C: refer to that documentation for a description.

The source file profile.ml contains an embedded test example, "testprof",
which is compiled by the included Makefile.

(**************************************************************)
(* Sample test program. *)

let test () =
  let f () = for i = 1 to 1000 do () done in
  let f = f1 "f" f in

  let g () = for i = 1 to 100 do () done in
  let g = f1 "g" g in

  let h () = for i = 1 to 1000 do f () ; g () done in
  let h = f1 "h" h in

  start () ;

  h () ;

  stop ()

(* Sample output:

    Number of samples is 128
    Each sample counts as 0.01 seconds.

    %      self    self&            self     total
   time   seconds childen    calls ms/call  ms/call  name
  92.19    1.183    1.183     1000   0.001   0.001   f
   6.25    0.080    0.080     1000   0.000   0.000   g
   1.56    0.020    1.283        1   0.020   1.283   h

*)
(**************************************************************)
SHAR_EOF
fi # end of overwriting check
if test -f 'Makefile'
then
	echo shar: will not over-write existing file "'Makefile'"
else
cat << \SHAR_EOF > 'Makefile'
#*************************************************************#
# Author: Mark Hayden, 4/96
#*************************************************************#
# Configuration section: point these to the correct directories

# CSL: root directory of Caml Special Light distribution
# CSL_LIB: directory where libraries are installed

CSL		= /usr/u/plg/src/csl-1.15
CSL_LIB		= /usr/u/plg/lib/sparc-SunOS4/camlsl

#*************************************************************#
CSL_RUNTIME	= $(CSL)/byterun
CSL_LIBUNIX	= $(CSL)/otherlibs/unix

CFLAGS		= -g -O -Wall \
	-DHML_PROTO		\
	-I$(CSL_LIB)/caml	\
	-I$(CSL_RUNTIME)	\
	-I$(CSL_LIBUNIX)
CC		= gcc

CSLCOMP		= cslc
CSLFLAGS	= -c

#*************************************************************#

.SUFFIXES :
.SUFFIXES : .ml .mli .cmi .cmo .o .c

.mli.cmi:
	$(CSLCOMP) $(CSLFLAGS) $<
.ml.cmo:
	$(CSLCOMP) $(CSLFLAGS) $<

#*************************************************************#

testprof: profile.cmo setitimer.o
	cslc -custom -o testprof unix.cma profile.cmo setitimer.o -cclib -lunix

profile.cmo: profile.cmi setitimer.cmi

#*************************************************************#

shar:
	shar README Makefile profile.ml profile.mli setitimer.c setitimer.mli >profile.shar

get:
	cp -f /usr/u/hayden/hml/extend/setitimer.* .
	cp -f /usr/u/hayden/hml/udp/profile.mli .
	grep -v Trace /usr/u/hayden/hml/udp/profile.ml >profile.ml

clean:
	$(RM) *~ *.cm[io] *.o

#*************************************************************#
SHAR_EOF
fi # end of overwriting check
if test -f 'profile.ml'
then
	echo shar: will not over-write existing file "'profile.ml'"
else
cat << \SHAR_EOF > 'profile.ml'
(**************************************************************)
(* PROFILE.ML *)
(* Author: Mark Hayden, 4/96 *)
(**************************************************************)
open Setitimer
open Printf
(**************************************************************)
let name = "PROFILE"
let failwith s = failwith (name^":"^s)
(**************************************************************)
(* BUGS:

 * fixed stack size

 * CSL Sys module does not support profiling signals, so we
   use alarm signals.

*)
(**************************************************************)
let stack_size = 1000			(* some big # *)
(**************************************************************)

type prof_info = {
  name			: string ;
  mutable live 		: bool ;
  mutable self_ctr 	: int ;
  mutable total_ctr 	: int ;
  mutable ncalls 	: int
}

(**************************************************************)

let stack = Array.new stack_size
  {name="";live=false;self_ctr=0;total_ctr=0;ncalls=0}
let sp = ref 0
let ticks = ref 0
let funcs = ref []

(**************************************************************)

let alloc_info name =
  let info = {
    name	= name ;
    live	= false ;
    self_ctr	= 0 ;
    total_ctr	= 0 ;
    ncalls	= 0
  } in	
  funcs := info :: !funcs ;
  info

(**************************************************************)

let handler _ =
  incr ticks ;

  let top = pred !sp in
  if top >= 0 then
    stack.(top).self_ctr <-
      succ stack.(top).self_ctr ;

  for i = 0 to top do
    stack.(i).total_ctr <-
      succ stack.(i).total_ctr
  done 	

(**************************************************************)

let start_time = ref None
and end_time   = ref None
and started    = ref false

let start () =
  if !started then
    failwith "profiler started more than once" ;
  started := true ;
  start_time := Some (Unix.times()) ;
  Sys.signal Sys.sigalrm (Sys.Signal_handle handler) ;
  setitimer ITIMER_REAL {it_interval=0.001 ; it_value=0.001} ;
  ()

let stop () =
  if not !started then
    failwith "profile:stop:profiler not started" ;
  started := false ;
  end_time := Some (Unix.times()) ;
  setitimer ITIMER_REAL {it_interval=0.0 ; it_value=0.0} ;
  Sys.signal Sys.sigalrm (Sys.Signal_default) ;

  let cmp i1 i2 = i1.self_ctr > i2.self_ctr in

  match !start_time, !end_time with
  | Some{Unix.tms_utime=start_user}, Some{Unix.tms_utime=end_user}-> (
      let foi = float in
      let time = end_user -. start_user in
      let sample = time /. foi !ticks in
      printf "  Number of samples is %d\n" !ticks ;
      printf "  Each sample counts as %.2f seconds.\n\n" sample ;
      printf "  %%      self    self&            self     total\n" ;
      printf " time   seconds childen    calls ms/call  ms/call  name\n" ;

      List.iter (fun info ->
	printf "%5.2f %8.3f %8.3f %8d %7.3f %7.3f   %s\n"
	    (foi info.self_ctr /. foi !ticks *. 100.0)
	    (foi info.self_ctr *. sample)
	    (foi info.total_ctr *. sample)
	    (info.ncalls)
	    (foi info.self_ctr *. sample /. foi info.ncalls)
	    (foi info.total_ctr *. sample /. foi info.ncalls)
	    (info.name)
      ) (Sort.list cmp !funcs) ;
      printf "\n" ; flush stdout
    )

  | _ -> failwith "sanity"

(**************************************************************)

let f1 name f =
  let info = alloc_info name in
  fun a1 ->
    info.ncalls <- succ info.ncalls ;
    if info.live then (
      f a1
    ) else (
      stack.(!sp) <- info ;
      info.live <- true ;
      incr sp ;
      let res = try f a1 with x -> (
	decr sp ;
	info.live <- false ;
	raise x
      ) in
      decr sp ;
      info.live <- false ;
      res
    )

(* copied from f1 *)
let f2 name f =
  let info = alloc_info name in
  fun a1 a2 ->
    info.ncalls <- succ info.ncalls ;
    if info.live then (
      f a1 a2
    ) else (
      stack.(!sp) <- info ;
      info.live <- true ;
      incr sp ;
      let res = try f a1 a2 with x -> (
	decr sp ;
	info.live <- false ;
	raise x
      ) in
      decr sp ;
      info.live <- false ;
      res
    )

(* copied from f1 *)
let f3 name f =
  let info = alloc_info name in
  fun a1 a2 a3 ->
    info.ncalls <- succ info.ncalls ;
    if info.live then (
      f a1 a2 a3
    ) else (
      stack.(!sp) <- info ;
      info.live <- true ;
      incr sp ;
      let res = try f a1 a2 a3 with x -> (
	decr sp ;
	info.live <- false ;
	raise x
      ) in
      decr sp ;
      info.live <- false ;
      res
    )

(**************************************************************)
(**************************************************************)
(* Sample test program. *)

let test () =
  let f () = for i = 1 to 1000 do () done in
  let f = f1 "f" f in

  let g () = for i = 1 to 100 do () done in
  let g = f1 "g" g in

  let h () = for i = 1 to 1000 do f () ; g () done in
  let h = f1 "h" h in

  start () ;

  h () ;

  stop ()

(* Sample output:

    Number of samples is 128
    Each sample counts as 0.01 seconds.

    %      self    self&            self     total
   time   seconds childen    calls ms/call  ms/call  name
  92.19    1.183    1.183     1000   0.001   0.001   f
   6.25    0.080    0.080     1000   0.000   0.000   g
   1.56    0.020    1.283        1   0.020   1.283   h

*)
(**************************************************************)

let _ =
  let nm = Filename.basename Sys.argv.(0) in
  if nm = "testprof" then (
    Printexc.catch test () ;
    exit 0
  )

(**************************************************************)
SHAR_EOF
fi # end of overwriting check
if test -f 'profile.mli'
then
	echo shar: will not over-write existing file "'profile.mli'"
else
cat << \SHAR_EOF > 'profile.mli'
(**************************************************************)
(* PROFILE.MLI *)
(* Author: Mark Hayden, 4/96 *)
(**************************************************************)

val start : unit -> unit
val stop  : unit -> unit
val f1 : string -> ('a -> 'b) -> ('a -> 'b)
val f2 : string -> ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
val f3 : string -> ('a -> 'b -> 'c -> 'd) -> ('a -> 'b -> 'c -> 'd)

(**************************************************************)
SHAR_EOF
fi # end of overwriting check
if test -f 'setitimer.c'
then
	echo shar: will not over-write existing file "'setitimer.c'"
else
cat << \SHAR_EOF > 'setitimer.c'
/**************************************************************/
/* PROFILE.ML */
/* Author: Mark Hayden, 4/96 */
/**************************************************************/

#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
#include "signals.h"
#include "fail.h"
#include "str.h"
#include "errno.h"
#include <unix.h>

#ifdef HAS_SELECT		/* is this right? */

#include <sys/types.h>
#include <sys/time.h>

#ifdef HML_PROTO
int setitimer(
  int which,
  struct itimerval *value,
  struct itimerval *ovalue
) ;
#endif

value hml_setitimer(
        value which_v, 
        value itvalue_v
) {				/* ML */
  int which ;
  double tmp ;
  struct itimerval itvalue ;
  struct itimerval itovalue ;
  value ret ;

  Push_roots(roots,1) ;
#define res roots[0]

  switch (Int_val(which_v)) {
    case 0:
      which = ITIMER_REAL ;
      break ;
    case 1:
      which = ITIMER_VIRTUAL ;
      break ;
    case 2:
      which = ITIMER_PROF ;
      break ;
    default: 
      abort() ;
  }
  
  tmp = Double_val(Field(itvalue_v,0)) ;
  itvalue.it_interval.tv_sec = tmp ;
  itvalue.it_interval.tv_usec = (long)(tmp * (double)1E6) % (long)1E6 ;

  tmp = Double_val(Field(itvalue_v,1)) ;
  itvalue.it_value.tv_sec = tmp ;
  itvalue.it_value.tv_usec = (long)(tmp * (double)1E6) % (long)1E6 ;

  ret = setitimer(which, &itvalue, &itovalue) ;
  if (ret == -1) uerror("setitimer", Nothing);

  res = alloc_tuple(2) ;
  Field(res, 0) = Val_unit ;
  Field(res, 1) = Val_unit ;

  tmp = 
    itovalue.it_interval.tv_sec +
    ((double)itovalue.it_interval.tv_usec/(double)1E6) ;
  modify(&Field(res,0), copy_double(tmp)) ;

  tmp = 
    itovalue.it_value.tv_sec +
    ((double)itovalue.it_value.tv_usec/(double)1E6) ;
  modify(&Field(res,1), copy_double(tmp)) ;

  Pop_roots() ;
  return res ;
}
  
#else

value hml_setitimer() { invalid_argument("setitimer not implemented"); }

#endif
SHAR_EOF
fi # end of overwriting check
if test -f 'setitimer.mli'
then
	echo shar: will not over-write existing file "'setitimer.mli'"
else
cat << \SHAR_EOF > 'setitimer.mli'
(**************************************************************)
(* SETITIMER.MLI *)
(* Author: Mark Hayden, 7/95 *)
(**************************************************************)

type itimerval = {
  it_interval : float ;
  it_value : float
} 

type timer =
  | ITIMER_REAL
  | ITIMER_VIRTUAL
  | ITIMER_PROF
 
external setitimer : timer -> itimerval -> itimerval = "hml_setitimer" 
external getitimer : timer -> itimerval -> itimerval = "hml_getitimer" 

(**************************************************************)
SHAR_EOF
fi # end of overwriting check
#	End of shell archive
exit 0