From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Wed, 9 Aug 1995 01:44:43 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~6047
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ded0156527cfaa420b7811ea352de9763f318d99;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/pcsample/zones.scm b/v7/src/pcsample/zones.scm
new file mode 100644
index 000000000..ee21b76db
--- /dev/null
+++ b/v7/src/pcsample/zones.scm
@@ -0,0 +1,142 @@
+(declare (usual-integrations))
+
+(define-structure
+    (pc-sample-zone
+     (conc-name pc-sample-zone/)
+     (constructor %make-pc-sample-zone (name index))
+     (print-procedure
+      (standard-unparser-method 'PC-SAMPLE-ZONE
+	(lambda (zone port)
+	  (write-char #\space port)
+	  (write (pc-sample-zone/name zone) port)
+	  (write-char #\space port)
+	  (write (pc-sample-zone/count zone) port)))))
+
+  name					; user name
+  index					; index if user zone
+  (with-count 0))
+
+;; List of either (1) weak `zone . index' pairs, (2) available +ve
+;; indexes or (3) unavailable -ve indexes (i.e. during allocation).
+;; Zero is not a valid index and is reserved for the zone `Other'.
+(define zones)
+
+(define zone:other)
+(define counts-cache)
+
+(define (pc-sample-zone/count zone)
+  (let ((index  (pc-sample-zone/index zone)))
+    (if (and (<= 0 index) (< index (flo:vector-length counts-cache)))
+	(flo:vector-ref counts-cache index)
+	'COUNT-UNKNOWN)))
+
+(define (make-pc-sample-zone name)
+  (define (allocate!)
+    (let loop ((pair zones))
+      (and (pair? pair)
+	   (let ((mark  (car pair)))
+	     (cond ((and (fixnum? mark) (> mark 0))
+		    (set-car! pair (- mark))
+		    pair)
+		   ((and (weak-pair? mark) (not (system-pair-car mark)))
+		    (set-car! pair (- (system-pair-cdr mark)))
+		    pair)
+		   (else ;assume -ve fixnum
+		    (loop (cdr pair))))))))
+
+  (let ((pair (without-interrupts allocate!)))
+    (if pair
+	(let* ((index (- (car pair)))
+	       (zone (%make-pc-sample-zone name index)))
+	  (set-car! pair (weak-cons zone index))
+	  zone)
+	(error "Out of free zone indexes"))))
+
+(define (get-zones)
+  (let loop ((list zones))
+    (cond ((null? list) '())
+	  ((and (weak-pair? (car list)) (system-pair-car (car list)))
+	   => (lambda (zone) (cons zone (loop (cdr list)))))
+	  (else (loop (cdr list))))))
+
+(define (wrap-with-zone procedure zone)
+  (define-integrable set-zone! (ucode-primitive %pc-sample/set-zone! 1))
+  (if (fixnum? (pc-sample-zone/index zone))
+      (let ()
+	;; The following wrappers need to be closed over the zone to stop it
+	;; begin GC-ed.
+	(define (default-wrapper . arguments)
+	  (cond ((set-zone! (pc-sample-zone/index zone))
+		 => (lambda (previous-zone)
+		      (let ((result (apply procedure arguments)))
+			(set-zone! previous-zone)
+			result)))
+		(else
+		 (apply procedure arguments))))
+
+	(define (wrapper/1-arg arg-1)
+	  (cond ((set-zone! (pc-sample-zone/index zone))
+		 => (lambda (previous-zone)
+		      (let ((result (procedure arg-1)))
+			(set-zone! previous-zone)
+			result)))
+		(else
+		 (procedure arg-1))))
+
+	(define (wrapper/2-args arg-1 arg-2)
+	  (cond ((set-zone! (pc-sample-zone/index zone))
+		 => (lambda (previous-zone)
+		      (let ((result (procedure arg-1 arg-2)))
+			(set-zone! previous-zone)
+			result)))
+		(else
+		 (procedure arg-1 arg-2))))
+
+	(define (wrapper/3-args arg-1 arg-2 arg-3)
+	  (cond ((set-zone! (pc-sample-zone/index zone))
+		 => (lambda (previous-zone)
+		      (let ((result (procedure arg-1 arg-2 arg-3)))
+			(set-zone! previous-zone)
+			result)))
+		(else
+		 (procedure arg-1 arg-2 arg-3))))
+	  
+	(let ((arity (procedure-arity procedure)))
+	  (cond ((equal? arity '(1 . 1)) wrapper/1-arg)
+		((equal? arity '(2 . 2)) wrapper/2-args)
+		((equal? arity '(3 . 3)) wrapper/3-args)
+		(else default-wrapper))))
+      (error "Cant wrap with" zone)))
+    
+
+(define (read-zone-counts!)
+  ((ucode-primitive %pc-sample/read-zones! 1) counts-cache))
+
+(define (reset-zone-counts!)
+  ((ucode-primitive %pc-sample/clear-zones! 0)))
+
+(define (display-zone-report)
+  (read-zone-counts!)
+  (let ((zones (get-zones)))
+    (let ((total
+	   (fold-left (lambda (sum zone) (+ sum (pc-sample-zone/count zone)))
+		      0
+		      zones)))
+      (let ((pct (if (zero? total)
+		     (lambda (zone) zone 0)
+		     (lambda (zone)
+		       (* 100. (/ (pc-sample-zone/count zone) total))))))
+	(pp (sort (map (lambda (zone)
+			 (list (pct zone) zone))
+		       zones)
+		  (lambda (x y) (> (car x) (car y)))))))))
+
+(define (initialize-zones-package!)
+  (let* ((max-zone ((ucode-primitive %pc-sample/max-zone 0))))
+    (set! zone:other (%make-pc-sample-zone 'other 0))
+    (set! zones
+	  (cons (weak-cons zone:other #f)
+		(cdr (make-initialized-list max-zone identity-procedure))))
+    (set! counts-cache (flo:vector-cons max-zone))
+    (reset-zone-counts!)
+    (read-zone-counts!)))
\ No newline at end of file