Check-ins Using Download Hex

Artifact 5b1d9328b026745e369eeeabeb98d5e92b51f6d2b24d0889e24703d2683cdd48:

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Ordinary LISP part of the heap statistics gathering package, HEAP-STATS.
%%% Load this file to get the package.
%%% The top-level function is collect-stats.  See its description.
%%% 
%%% Author: Cris Perdue
%%% December 1982
%%% Documented and cleaned up a litte, January 1983
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load if))

(load h-stats-1 get-heap-bounds)

%%% An object that holds a complete set of statistics for the heap
%%% at some moment in time.  When one of these is created, the
%%% instance variable "template" must be initialized, and the
%%% template must be a "histogram template" as discussed below.

%%% Maintainer note: the code that actually gathers statistics assumes
%%% that the heap-stats object is a vector (or evector) with a header,
%%% 2 items of data allocated by the objects package, then the data shown
%%% here, in order.
(defflavor heap-stats
  (template
   string-count
   string-space
   vector-count
   vector-space
   wordvec-count
   wordvec-space
   (pairs 0)
   (strings 0)
   (halfwords 0)
   (wordvecs 0)
   (vectors 0))
  ()
  (initable-instance-variables template)
  gettable-instance-variables)

(defmethod (heap-stats init) (init-plist)
  (if (not (vectorp template)) then
      (error 0 "The TEMPLATE of a HEAP-STATS object must be initialized."))
  (let ((s (+ (size template) 1)))
    (setf string-count (make-vector s 0))
    (setf string-space (make-vector s 0))
    (setf vector-count (make-vector s 0))
    (setf vector-space (make-vector s 0))
    (setf wordvec-count (make-vector s 0))
    (setf wordvec-space (make-vector s 0))))

(global '(old-!%reclaim stats-channel))

%%% This method prints statistics on a particular snapshot of the heap
%%% onto the given channel.
(defmethod (heap-stats print-stats) (channel)
  (channelprintf
   channel
   "%w pairs, %w strings, %w vectors, %w wordvecs, %w halfwordvecs%n%n"
   pairs strings vectors wordvecs halfwords)
  (for (in table (list string-count vector-count))
       (in spacetable (list string-space vector-space))
       (in title '("STRINGS" "VECTORS"))
       (do
	(channelprintf channel "%w%n%n" title)
	(print-histo template table spacetable channel)
	(channelterpri channel)
	(channelterpri channel))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Internal functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%% Prints a single histogram onto the given channel.  Arguments
%%% are the template from which the histogram was generated, a
%%% corresponding table with a count of the number of objects of
%%% each size range, and another corresponding table with the
%%% total space occupied by the objects within each size range.
(defun print-histo (template table spacetable channel)
  (channelprintf channel
		 "Size <= n%tHow many%tStorage items used%n" 12 24)
  (channelprintf channel
		 "------------------------------------------%n")
  (for (from i 0 (size template))
       (do (channelprintf channel
			  "%w%t%w%t%w%n" (indx template i) 12
			  (indx table i) 24 (indx spacetable i))))
  (channelprintf channel
		 "> %w%t%w%t%w%n"
		 (indx template (size template)) 12
		 (indx table (+ (size template) 1)) 24
		 (indx spacetable (+ (size template) 1))))

(fluid '(before-stats after-stats print-stats? stdtemplate))

%%% This function initializes the collecting of statistics and
%%% printing them to a file.  The name of the file is the
%%% argument to collect-stats.  NIL rather than a string for the file
%%% name turns statistics collection off.  In statistics collection mode
%%% statistics are gathered just before and after each garbage collection.
(defun collect-stats (file)
  (if (and file (not old-!%reclaim)) then
      (if (not (and (eq (object-type before-stats) 'heap-stats)
		    (eq (object-type after-stats) 'heap-stats))) then
	  (printf "Caution: before- and after-stats are not both bound.%n"))
      (setq old-!%reclaim (cdr (getd '!%reclaim)))
      (setq stats-channel (open file 'output))
      (putd '!%reclaim
	    'expr
	    '(lambda ()
	       (heapstats before-stats)
	       (apply old-!%reclaim nil)
	       (heapstats after-stats)
	       (channelprintf stats-channel "BEFORE RECLAIMING%n%n")
	       (=> before-stats print-stats stats-channel)
	       (channelterpri stats-channel)
	       (channelprintf stats-channel "AFTER RECLAIMING%n%n")
	       (=> after-stats print-stats stats-channel)))
      elseif (and (not file) old-!%reclaim) then
      (close stats-channel)
      (putd '!%reclaim 'expr old-!%reclaim)
      (setq old-!%reclaim nil)
      elseif old-!%reclaim then
      (printf "Statistics collecting is apparently already turned on.%n")
      else
      (printf "Statistics collecting is apparently already off.%n")
      (printf "Trying to close the channel anyway.%n")
      (close stats-channel)))

%%% This is initialized here to be a reasonable histogram template for
%%% statistics on heap usage.  A histogram template is a vector of
%%% integers that define the buckets to be used in collecting the
%%% histogram data.  All values less than or equal to template[0]
%%% go into data[0].  Of those values that do not go into data[0],
%%% all less than or equal to template[1] go into data[1], etc..
%%% The vector of data must have at least one more element that
%%% the template does.  All values greater than the last value in
%%% the template go into the following element of the data vector.
(setq StdTemplate
      (make-vector 27 0))

(for (from i 0 16)
     (do (setf (indx StdTemplate i) i)))

(for (from i 17 27)
     (for k 32 (* k 2))
     (do (setf (indx StdTemplate i) k)))

(setq before-stats (make-instance 'heap-stats 'template StdTemplate))

(setq after-stats (make-instance 'heap-stats 'template StdTemplate))
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]