;;; 4:42pm  Saturday, 12 July 1980	-*- Lisp -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a dynamic garbage collector daemon which tries to predict
;;; consing in the various spaces based on past performance and thus to
;;; set space sizes such that garbage collection is minimized.
;;; 
;;; The algorithm is from Henry Baker and the program is his with minor
;;; modifications.  This version has been created by PSZ, incorporating
;;; some code from JONL's version on LIBDOC;.  Ideally, the two versions
;;; should merge and this one should disappear.
;;;
;;; The original algorithm has been modified by
;;;  (1) the addition of further statistics printing from the Daemon if
;;;     ^D is non-NIL.
;;;  (2) correction of an error that left too few List cells for the
;;;     Daemon itself to run.
;;;  (3) correction of an error that allocated more than the total
;;;     available core in the Lisp.
;;;  (4) provision for accomodation between several GC-Daemons.
;;;  (5) correction of a mis-feature that permitted the demon to use
;;;     less of a space than what had already been allocated.
;;;
;;; The corrections appear only in the Lisp version of the code, not the
;;; original CGOL version which is included below only for reference.
;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (cgol)
;; 
;; declare(muzzled(t))	% Shut up about closed compilation. %
;; 
;; %	GC-daemon for optimal allocation.			%
;; %	Described in AI Working Paper #142.			%
;; %	set "alloc-mark-ratio" to a flonum between 0.2 and 5.0.	%
;; 
;; sstatus(who1,42.,"%",118.,0.)	% Set up "who" line on tv's.  %
;; sstatus(gcwho,3.)
;; who3 := "GCDEMN"
;; 
;; % Initialize property lists of space names.  %
;; let gc_daemon=
;;     '\spacelist;
;;      (let alloct=nil.alloc(t);
;;       for element in spacelist
;; 	  do (let space = car(element),
;; 		  freebefore = cadr(element),
;; 		  freeafter = caddr(element),
;; 		  sizebefore = cadddr(element),
;; 		  sizeafter = car(cddddr(element));
;; 	      % Initialize state of each space for gc-daemon.  %
;; 	      accessible ofq space := sizeafter-freeafter;
;; 	      % Make sure that we don't get a gc-overflow interrupt.  %
;; 	      alloc([space,[max(512.,car(space of alloct) or sizeafter),
;; 			    262143.,
;; 			    if sizeafter>0 then 32. else 0.]])))'
;;     in gc()
;; 
;; alloc_mark_ratio := 1.0 
;; 
;; special alloc_mark_ratio
;; 
;; define "GC-DAEMON" (spacelist);
;;   let total_accessible = 0.0,
;;       total_consed = 0.0;
;;   % Go through spaces and accumulate consed and accessible
;;     information.  %
;;   for element in spacelist	    % Argument is "alist" of spaces. %
;;       do (let space = car(element),	% Give names to parameters.  %
;; 	      freebefore = cadr(element),
;; 	      freeafter = caddr(element),
;; 	      sizebefore = cadddr(element),
;; 	      sizeafter = car(cddddr(element));
;;  % Compute consed since last gc and accessible now for this space.  %
;; 	 consed ofq space := sizebefore-freebefore-accessible ofq space;
;; 	 total_consed := total_consed + consed ofq space;
;; 	 accessible ofq space := sizeafter-freeafter;
;; 	 total_accessible := total_accessible + accessible ofq space);
;;   % Store total consed, total accessible and compute total free.  %
;;   consed ofq 'total_storage' := total_consed;
;;   accessible ofq 'total_storage' := total_accessible;
;;   let total_free = alloc_mark_ratio * total_accessible;
;;   free ofq 'total_storage' := total_free;
;;   % Go through spaces and re-allocate where necessary.  %
;;   for element in spacelist
;;       do (let space = car element;
;; 	  alloc_rate ofq space := consed ofq space / total_consed;
;; 	  free ofq space := fix(total_free * alloc_rate ofq space);
;; 	  let spcsize = accessible ofq space + free ofq space + 511.;
;; 	     if spcsize>511. then alloc([space,[spcsize,262143.,32.]]))
;; 
;; gc_daemon := 'gc_daemon'
;; 
;; =exit
 
(DECLARE (MUZZLED T))

;;; Prevent this file from being loaded more than once, especially to
;;;prevent the resetting of the GC-DAEMON to do multiple calls to the
;;;BAKER-GC-DAEMON.

(declare (special baker-gc-daemon-loaded))

(cond ((boundp 'baker-gc-daemon-loaded)
       (error 'reloading-gcdemn-forbidden))
      ((setq baker-gc-daemon-loaded t)))

(COND ((STATUS SSTATUS GCWHO)
       (SSTATUS WHO1 42. '% 118. 0.) 
       (SSTATUS GCWHO 3.) 
       (SSTATUS WHO3 'GCDEMN) ))

;;; Initially set things up
((LAMBDA (GC-DAEMON) (GC))
   (function
    (LAMBDA (SPACELIST)
     ((lambda (alloct)
       (MAPC
	(FUNCTION
	   (LAMBDA (ELEMENT)
	       ((LAMBDA (SPACE FREEBEFORE FREEAFTER SIZEBEFORE
			       SIZEAFTER)
			 (PUTPROP SPACE
				  (DIFFERENCE SIZEAFTER FREEAFTER)
				  'ACCESSIBLE)
			 (ALLOC
			    (LIST
			       SPACE
			       (LIST (MAX 512.
					  (OR (CAR (GET ALLOCT SPACE))
					      SIZEAFTER))
				     262143.
				     (COND ((PLUSP SIZEAFTER)
					    (cond ((eq space 'list) 200.)
						  (t 32.)))
					   (T 0.))))))
		       (CAR ELEMENT) (CADR ELEMENT) (CADDR ELEMENT)
		       (CADDDR ELEMENT) (CAR (CDDDDR ELEMENT)))))
	SPACELIST))
      (cons nil (alloc t)))))) 

(DECLARE (SPECIAL ALLOC-MARK-RATIO fill-storage-fraction)) 

(or (boundp 'alloc-mark-ratio) (SETQ ALLOC-MARK-RATIO 1.0))

(or (boundp 'fill-storage-fraction) (setq fill-storage-fraction 0.5))

(declare (special base *nopoint))

(DEFUN BAKER-GC-DAEMON (SPACELIST)
 ((LAMBDA (TOTAL-ACCESSIBLE TOTAL-CONSED)
   (MAPC
    (FUNCTION
     (LAMBDA (ELEMENT)
      ((LAMBDA (SPACE FREEBEFORE FREEAFTER SIZEBEFORE SIZEAFTER)
	(PUTPROP SPACE (DIFFERENCE SIZEBEFORE FREEBEFORE
				   (GET SPACE 'ACCESSIBLE))
		 'CONSED)
	(SETQ TOTAL-CONSED (PLUS TOTAL-CONSED (GET SPACE 'CONSED)))
	(PUTPROP SPACE (DIFFERENCE SIZEAFTER FREEAFTER) 'ACCESSIBLE)
	(SETQ TOTAL-ACCESSIBLE (PLUS TOTAL-ACCESSIBLE
				     (GET SPACE 'ACCESSIBLE))))
       (CAR ELEMENT) (CADR ELEMENT) (CADDR ELEMENT)
       (CADDDR ELEMENT) (CAR (CDDDDR ELEMENT)))))
    SPACELIST)
   (PUTPROP 'TOTAL-STORAGE TOTAL-CONSED 'CONSED)
   (PUTPROP 'TOTAL-STORAGE TOTAL-ACCESSIBLE 'ACCESSIBLE)
   ((LAMBDA (TOTAL-FREE alloct)
     (PUTPROP 'TOTAL-STORAGE TOTAL-FREE 'FREE)
     (and ^d
      ((lambda (base *nopoint)
	(princ '|;GC-DAEMON: cons-rate%[oldgcsize->marked//gcsize//spcsize]|
	       tyo)
	(terpri tyo)
	(princ '|; Consed=| tyo)
	(princ (fix (get 'total-storage 'consed)) tyo)
	(princ '|, Marked=| tyo)
	(princ (fix (get 'total-storage 'accessible)) tyo)
	(princ '|, Allocated//Marked=| tyo)
	(princ alloc-mark-ratio tyo)
	(princ '|, Memfree= | tyo)
	(princ (status memfree) tyo)
	(terpri tyo)
	(princ '|; | tyo))
       10. t))
     (MAPC
      (FUNCTION
       (LAMBDA (ELEMENT)
	((LAMBDA (SPACE)
	  (PUTPROP SPACE (QUOTIENT (GET SPACE 'CONSED) (FLOAT TOTAL-CONSED))
		   'ALLOC-RATE)
	  (PUTPROP SPACE (FIX (TIMES TOTAL-FREE (GET SPACE 'ALLOC-RATE)))
		   'FREE)
	  ((LAMBDA (SPCSIZE)
	    (and ^d
		 (get alloct space)
		 (gc-daemon-print
		  space
		  (get space 'alloc-rate)
		  (car (get alloct space))
		  (get space 'accessible)
		  (* 512. (fix (quotient spcsize 512.)))
		  (status spcsize space)))
	    (COND ((GREATERP SPCSIZE 511.)
		   (ALLOC
		    (LIST SPACE
			  (LIST (max SPCSIZE (status spcsize space))
				262143.
				(cond ((eq space 'list) 200.)
				      (t 32.))))))))
	   (PLUS (GET SPACE 'ACCESSIBLE) (GET SPACE 'FREE) 511.)))
	 (CAR ELEMENT))))
      SPACELIST)
     (and ^d (terpri tyo)))
    (min (TIMES ALLOC-MARK-RATIO TOTAL-ACCESSIBLE)
	 (fix (times (status memfree) fill-storage-fraction)))
    (cons nil (alloc t))))
  0.0 0.0)) 

(defun gc-daemon-print (space cons-rate oldgcsize marked gcsize spcsize)
   ;; We print for each non-empty space the following information:
   ;;  CONS-RATE	The % of conses since the last GC which were for
   ;; 			this space.
   ;;  OLDGCSIZE	Size of the space in words before GC.
   ;;  MARKED		Number of words marked as "in use" by GC.
   ;;  GCSIZE		Size in words recommended by daemon.
   ;;  SPCSIZE (if present) Actual size of space if different from size.
   ((lambda (base *nopoint)
       (setq cons-rate (fix (times cons-rate 100.)))
       (and (< (linel tyo)
	       (+ (flatc space) (flatc cons-rate) (flatc oldgcsize)
		  (flatc marked) (flatc gcsize) (flatc spcsize) 10.
		  (charpos tyo)))
	    (progn (terpri tyo) (princ '|; | tyo)))
       (princ space tyo)
       (princ '| | tyo)
       (princ cons-rate tyo)
       (princ '|%[| tyo)
       (princ oldgcsize tyo)
       (princ '|->| tyo)
       (princ marked tyo)
       (princ '|//| tyo)
       (princ gcsize tyo)
       (cond ((not (= spcsize gcsize))
	      (princ '|//| tyo) (princ spcsize tyo)))
       (princ '|]  | tyo))
    10. t))

(setq GC-DAEMON (cond ((null GC-DAEMON)  'BAKER-GC-DAEMON)
		      ((let ((g (gensym)) 
			     (h (cond ((or (symbolp gc-daemon)
					   (and (not (atom gc-daemon))
						(eq (car gc-daemon) 'LAMBDA)))
				       `(,gc-daemon))
				      (`(FUNCALL ',gc-daemon)))))
			    `(LAMBDA (,g) 
				     (BAKER-GC-DAEMON ,g)
				     (,.h ,g))))))