;;; -*- Mode:LISP; Package:NETWORK; Readtable:CL; Base:10 -*- #| Copyright LISP Machine, Inc. 1987 See filename "Copyright.Text" for licensing and release information. |# (export '( make-fifo fifo-empty-p fifo-as-list last-element-in-fifo push-fifo pushnew-fifo push-fifo-front pop-fifo rotate-fifo remove-from-fifo move-to-end-of-fifo priority-insert-fifo make-key-list original-array nth-value byte-array-or-string-p milliseconds-since-midnight-gmt find-network-address-for-other-processor set-gauges add-gauges delete-gauges with-tcp-favored with-chaos-favored )) (defsubst make-fifo () "Make a FIFO queue" (cons nil nil)) (defsubst fifo-empty-p (f) (null (car f))) (defsubst fifo-as-list (f) (car f)) (defsubst last-element-in-fifo (f) (cadr f)) (defun push-fifo (elem f) "Push an element onto the tail of a FIFO queue" (without-interrupts (let ((new (ncons elem)) (tail (cdr f))) (if tail (setf (cdr tail) new) (setf (car f) new)) (setf (cdr f) new))) elem) (defun pushnew-fifo (elem f) "Add an element to the end of a FIFO queue unless it already appears in the queue" (without-interrupts (do ((this (car f) (cdr this))) ((null this) ;;If element not found, simply add to end (let ((new (ncons elem)) (tail (cdr f))) (if tail (setf (cdr tail) new) (setf (car f) new)) (setf (cdr f) new)) elem) (when (eql elem (car this)) (return elem))))) (defun push-fifo-front (elem f) "Push an element onto the front of a FIFO queue" (without-interrupts (let ((new (ncons elem))) (setf (car f) (nconc new (car f))) (unless (cdr f) (setf (cdr f) new)))) elem) (defun pop-fifo (f) "Remove the first element from a FIFO queue and return it" (without-interrupts (let ((l (car f))) (prog1 (car l) (or (setf (car f) (cdr l)) (setf (cdr f) nil)))))) (defun rotate-fifo (f) "Like (push-fifo (pop-fifo f) f)" (without-interrupts (let ((new (car f))) (if (setf (car f) (cdr new)) (setf (cdr new) nil) (setf (cdr f) nil)) (if (cdr f) (setf (cddr f) new) (setf (car f) new)) (setf (cdr f) new))) (car f)) (defun remove-from-fifo (elem f) "Remove all copies of a specific element from a FIFO queue" (without-interrupts (do ((this (car f) (cdr this)) (prev nil this)) ((null this)) (when (eql elem (car this)) (if prev (setf (cdr prev) (cdr this)) (setf (car f) (cdr this))) (if (eql elem (cadr f)) (setf (cdr f) prev))))) elem) (defun move-to-end-of-fifo (elem f) "Move the first copy of a specific element to the end of a FIFO queue" (without-interrupts (do ((this (car f) (cdr this)) (prev nil this)) ((null this) ;;If element not found, simply add to end (let ((new (ncons elem)) (tail (cdr f))) (if tail (setf (cdr tail) new) (setf (car f) new)) (setf (cdr f) new)) elem) (when (eql elem (car this)) (unless (null (cdr this)) ;;Remove element from fifo (if prev (setf (cdr prev) (cdr this)) (setf (car f) (cdr this))) (if (eql elem (cadr f)) (setf (cdr f) prev)) ;;Stick on end of fifo (setf (cdr this) nil) (if (cdr f) (setf (cddr f) this) (setf (car f) this)) (setf (cdr f) this)) (return elem))))) (defun priority-insert-fifo (elem func f) "Inserts an element into a fifo at the end of like-priority items, before lower-priority items. FUNC is a function that returns a number rating the priority of an element" (without-interrupts (do ((this (car f) (cdr this)) (prev nil this) (priority (funcall func elem)) (new (ncons elem))) ((null this) ;If lower-priority element not found, add to end (if (cdr f) (setf (cddr f) new) (setf (car f) new)) (setf (cdr f) new) elem) (when (> priority (funcall func (car this))) (cond (prev ;Adding between two elements (setf (cdr new) this) (setf (cdr prev) new)) (t ;Adding at front (setf (cdr new) (car f)) (setf (car f) new))) (return elem))))) (defun nrotate (list) "Given a list, destructively rotate the elements towards the front. I.e. the first element becomes the last, the second the first, the third the second, etc." (do ((save (car list)) (rest list (cdr rest))) ((null (cdr rest)) (rplaca rest save) list) (rplaca rest (cadr rest)))) ;;;utility routine: set up (check-type key (member ...)) by doing (check-type key #.(make-key-list alist)) (defun make-key-list (alist &aux result) (push 'member result) (dolist (elt alist) (push (car elt) result)) (nreverse result)) (defun original-array (array) "Follows array displacements to find the original array" (do () ((not (si:array-indirect-p array)) array) (setq array (si:array-indirect-to array)))) (defmacro nth-value (n exp) `(nth ,n (multiple-value-list ,exp))) (defun byte-array-or-string-p (array) "Returns T if the argument is a string or an art-8b vector" #-lambda (typep array '(or (vector (unsigned-byte 8)) string)) #+lambda (and (eq (sys:%data-type array) sys:dtp-array-pointer) (= (array-rank array) 1) (let ((type (nth (sys:%p-ldb-offset sys:%%array-type-field array 0) sys:array-types))) (or (eq type 'sys:art-8b) (eq type 'sys:art-string)))) ) (defun milliseconds-since-midnight-gmt () "Number of milliseconds since midnight GMT; suitable for timestamp option" (multiple-value-bind (seconds minutes hours ignore ignore ignore ignore dst-p time-zone) (get-decoded-time) (* 1000 (+ seconds (* 60 minutes) (* 3600 (rem (+ hours time-zone (if dst-p 1 0)) 24)))))) (defun find-host-for-other-processor (op) (let* ((host-name (nth (si:op-proc-number op) (multiple-value-list (si:get-pack-name)))) (host (si:parse-host host-name t nil))) host)) (defun find-network-address-for-other-processor (op domain) (let ((host (find-host-for-other-processor op))) (cond (host (send host :network-address domain)) ((eq domain :chaos) ;;***Kludge -- system either isn't in pack name or isn't in site files. ;;***Get the chaos address the old way (let* ((conf (si:op-proc-conf op)) (address (and conf (si:%processor-conf-chaos-address conf)))) (cond ((null address) ;No configuration structure or no address nil) ((zerop address) ;Bad address -- not set up yet nil) (t ;Good address address)))) (t nil)))) ;;;NETWORK CLOCK FUNCTION ;;;This function is called by the scheduler every N 60ths of a second. It maintains statistics for all ;;;network-statistics blocks on the list net:*network-statistics-blocks* (defparameter *averaging-constant* 0.95s0) (defparameter *minimum-60ths* 60) (defvar *accumulated-60ths* 0) (defvar *network-clock-enabled* t) (defun network-clock (n) (when *network-clock-enabled* (when (>= (incf *accumulated-60ths* n) *minimum-60ths*) (without-floating-underflow-traps (let* ((alpha *averaging-constant*) (1-alpha (- 1s0 alpha)) (interval (short-float *accumulated-60ths*))) (dolist (array *network-statistics-blocks*) (dotimes (stat 4) (let* ((current (aref array stat STAT-CURR)) (last (aref array stat STAT-LAST)) (instant (if (= current last) 0s0 (/ (short-float (- current (aref array stat STAT-LAST))) (/ interval 60s0))))) (setf (aref array stat STAT-INST) instant) (setf (aref array stat STAT-AVRG) (+ (* alpha (aref array stat STAT-AVRG)) (* 1-alpha instant))) (if (> instant (aref array stat STAT-MAX)) (setf (aref array stat STAT-MAX) instant)) (setf (aref array stat STAT-LAST) current))))) (setf *accumulated-60ths* 0))))) (defun time-network-clock (n) (let* ((block (make-statistics-block)) (net:*network-statistics-blocks* (ncons block)) (net:*accumulated-60ths* 0)) (declare (special net:*network-statistics-blocks* net:*accumulated-60ths*)) (dotimes (i n) (dotimes (stat 4) (incf (aref block stat STAT-CURR))) (network-clock *minimum-60ths*)) block)) ;;;Network Gauge functions (defun pps->gauge (pps array stat bytes?) "Convert a Packets-Per-Second figure in range of 0 - RANGE into range -1 to 1 Auto-scaling -- statistics array maximum value used to determine RANGE" (without-floating-underflow-traps (let* ((max (aref array stat STAT-MAX)) (limit (if (zerop max) 1.0 (/ (if bytes? (/ (* 8.0 max) 1000.0) max) 2.0)))) (min 1.0 (max -1.0 (- (/ pps limit) 1.0)))))) (defun pps-in-label (last-value value keyword) (declare (values new-label changed?)) (if (= value last-value) (values nil nil) (values (format nil "~A:~D" keyword value) t))) (defun make-network-gauge (array keyword name inactive-gauges) (declare (special tv:*control-panel*)) (let ((g (assoc keyword (cdr inactive-gauges)))) (when g (setf (cdr inactive-gauges) (delete g (cdr inactive-gauges))) (return-from make-network-gauge (cdr g)))) (let* ((stat (case keyword ((:ipr :apr) STAT-PR) ((:ips :aps) STAT-PS) ((:ibr :abr) STAT-BR) ((:ibs :abs) STAT-BS))) (inst-or-avrg (case keyword ((:ipr :ips :ibr :ibs) STAT-INST) ((:apr :aps :abr :abs) STAT-AVRG))) (bytes? (member keyword '(:ibr :abr :ibs :abs)))) (make-instance 'tv:probe-map-gauge-with-value-and-name :superior tv:*control-panel* :mapping-function #'(lambda (pps) (pps->gauge pps array stat bytes?)) :label `(:string ,(format nil "~A:0" keyword)) :label-function (let ((last-value 0)) #'(lambda (value) (pps-in-label (prog1 last-value (setq last-value value)) value keyword))) :margin-name name :probe-function (if bytes? #'(lambda () (round (/ (* 8.0 (aref array stat inst-or-avrg)) 1000.0))) #'(lambda () (round (aref array stat inst-or-avrg))))))) (defun set-gauges (array active-gauges inactive-gauges gauge-name gauge-list) (declare (special tv:fancy-landscape)) (when (and (boundp 'tv:fancy-landscape) tv:fancy-landscape) (let* ((current-gauges (mapcar 'car (cdr active-gauges))) (new-gauges (set-difference gauge-list current-gauges)) (killed-gauges (set-difference current-gauges gauge-list)) (windows nil)) (dolist (keyword killed-gauges) (let ((g (assoc keyword (cdr active-gauges)))) (push g (cdr inactive-gauges)) (push (cdr g) windows) (setf (cdr active-gauges) (delete g (cdr active-gauges))))) (apply 'tv:delete-network-gauges windows) (setq windows nil) (dolist (keyword new-gauges) (let ((g (make-network-gauge array keyword gauge-name inactive-gauges))) (push (cons keyword g) (cdr active-gauges)) (push g windows))) (apply 'tv:add-network-gauges windows) t))) (defun add-gauges (array active-gauges inactive-gauges gauge-name gauge-list) (declare (special tv:fancy-landscape)) (when (and (boundp 'tv:fancy-landscape) tv:fancy-landscape) (let* ((current-gauges (mapcar 'car (cdr active-gauges))) (new-gauges (set-difference gauge-list current-gauges)) (windows nil)) (dolist (keyword new-gauges) (let ((g (make-network-gauge array keyword gauge-name inactive-gauges))) (push (cons keyword g) (cdr active-gauges)) (push g windows))) (apply 'tv:add-network-gauges windows) t))) (defun delete-gauges (active-gauges inactive-gauges gauge-list) (declare (special tv:fancy-landscape)) (when (and (boundp 'tv:fancy-landscape) tv:fancy-landscape) (let* ((current-gauges (mapcar 'car (cdr active-gauges))) (killed-gauges (intersection gauge-list current-gauges)) (windows nil)) (dolist (keyword killed-gauges) (let ((g (assoc keyword (cdr active-gauges)))) (push g (cdr inactive-gauges)) (push (cdr g) windows) (setf (cdr active-gauges) (delete g (cdr active-gauges))))) (apply 'tv:delete-network-gauges windows)))) (defmacro with-tcp-favored (&body body) `(let ((*network-protocols* (cons :internet (remove :internet *network-protocols*)))) ,@body)) (defmacro with-chaos-favored (&body body) `(let ((*network-protocols* (cons :chaos (remove :chaos *network-protocols*)))) ,@body))