;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Readtable:CL; Base:10 -*-

(defun for-each-area (proc)
  "(FUNCALL PROC AREA-SYMBOL AREA) for every area."
  (dolist (area-symbol (current-area-list))
    (funcall proc area-symbol (symbol-value area-symbol))))

(defun for-each-region-in-area (area proc)
  "(FUNCALL PROC REGION) for each region in AREA."
  (do ((region (aref #'area-region-list area) (aref #'region-list-thread region)))
      ((minusp region))
    (funcall proc region)))

(defun check-area (area)
  (let ((default-volatility (%area-volatility area))
	(suspicious-regions 0)
	(ok-regions         0))
    (for-each-region-in-area
      area
      (lambda (region)
	(if (< (%region-volatility region) default-volatility)
	    (incf suspicious-regions)
	    (incf ok-regions))))
    (< ok-regions suspicious-regions)))

(defun find-suspicious-areas ()
  (for-each-area
    (lambda (name area)
      (when (check-area area)
	(format t "~%Area ~D (~S) " name area)
	(show-area-and-region-volatilities area)))))

(defun show-area-and-region-volatilities (area)
  (format t "~D" (%area-volatility area))
  (for-each-region-in-area area
    (lambda (region)
      (format t "~% ~D: ~D" region (%region-volatility region)))))

(defun verify-volatility-of-pages-in-area (area max-volatility-to-consider)
  (tv:notify nil "Checking volatilities of pages in area ~S" area)
  (without-interrupts
    (si:for-every-region-in-area (region area)
      (verify-volatility-of-pages-in-region region max-volatility-to-consider)))
  (tv:notify nil "Volatilities in area ~S are OK." area))

(defun verify-volatility-of-pages-in-region (region max-volatility-to-consider)
  (let* ((origin (%region-origin region))
	 (object-to-examine origin))
    (do ()
	((= object-to-examine (%pointer-plus origin (%region-free-pointer region)))) ;;recompute each time, I might cons.
      (let ((boxed (%structure-boxed-size object-to-examine))
	    (total (%structure-total-size object-to-examine)))
	  (dotimes (offset boxed)
	    (let* ((location (%pointer-plus object-to-examine offset))
		   (current-page (page-number location))
		   (what-volatility-ought-to-be (page-volatility current-page)))
	      (when (and ( what-volatility-ought-to-be max-volatility-to-consider) ;;ignore high volatility pages.
			 (%p-pointerp location))
		  (let ((target-region (%region-number (%p-pointer location))))
		    (when (> (%region-volatility target-region) what-volatility-ought-to-be)
		      (break "Object at R~S, P~S ~S + ~S = ~S points from V~S to V~S"
			     region current-page object-to-examine offset
			     location what-volatility-ought-to-be
			     (%region-volatility target-region)))))))
	  (setq object-to-examine (%pointer-plus object-to-examine total))))))