;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.8
;;; Reason:
;;;  The TCP background process depends on variable *background-wakeup-time*
;;;  to tell it that timeouts are armed.  Setting of this is not interlocked.
;;;  I noticed a TCP socket that was hung because it had a timeout armed but
;;;  the variable was NIL.  Hence, the background process did nothing.
;;;  Don't let this happen...
;;; Written 26-May-88 19:09:18 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 2
;;; with Experimental System 124.6, Experimental Local-File 74.0, Experimental File-Server 23.0, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.0, Experimental Lambda-Diag 16.0, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#291 at 26-May-88 19:09:52
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "

(defun tcp-background-process-wait (int-pkt now)
 (and (tcp-enabled *tcp-stream*)
      (or (and (or (not (fifo-empty-p *send-blocked-control-packets*))
		   (not (fifo-empty-p *send-blocked-sockets*)))
	       (or (cdr int-pkt)
		   (setf (cdr int-pkt) (net:allocate-packet nil))))
	  (and *background-wakeup-time*
	       (not (time-lessp (setf (cdr now) (zl:time))
				*background-wakeup-time*))))))

(defun tcp-background-process ()
  (loop
    (let (int-pkt now)
      (process-wait "Timeout" 'tcp-background-process-wait (locf int-pkt) (locf now))
      (tcp-background-process-1 int-pkt now))))

(defun tcp-background-process-1 (int-pkt now)
  (let (elt socket)
    (cond ((not (tcp-enabled *tcp-stream*)))	;tcp disabled -- do nothing
	  (int-pkt				;send blocked stream or packet -- send it
	   (cond ((setq elt (pop-fifo *send-blocked-control-packets*))
		  (apply 'send-control-packet (nconc elt (ncons int-pkt))))
		 ((setq socket (pop-fifo *send-blocked-sockets*))
		  (tcp-log :unblock socket)
		  (send-tcp-packets socket t int-pkt))
		 (t
		  (net:free-packet int-pkt))))
	  (t					;generic timeout
	   ;;Do the global timeouts
	   (do ((list *global-timeouts* (cdr list))
		(result nil))
	       ((null list)
		(setq *global-timeouts* result))
	     (let* ((elt (car list))
		    (time (first elt)))
	       (if (time-lessp time now)
		   (funcall (second elt) (third elt) now)
		 (push elt result))))

	   ;;And the socket specific timeouts
	   (do ((list (tcp-user-socket-alist *tcp-stream*) (cdr list)))
	       ((null list))
	     (let* ((socket (cdar list))
		    (passed (mapcan #'(lambda (x) (if (time-lessp (cdr x) now) (ncons x)))
				    (tcp-user-timeout-alist socket))))
	       (when passed
		 (setf (tcp-user-timeout-alist socket)
		       (nset-difference (tcp-user-timeout-alist socket) passed))
		 (dolist (x passed)
		   (funcall (car x) socket now)))))

	   ;;Reset next wakeup time
	   (without-interrupts
	     (let ((next-wakeup-time nil))
	       (dolist (x *global-timeouts*)
		 (when (or (null next-wakeup-time)
			   (time-lessp (first x) next-wakeup-time))
		   (setq next-wakeup-time (first x))))
	       (dolist (elt (tcp-user-socket-alist *tcp-stream*))
		 (dolist (x (tcp-user-timeout-alist (cdr elt)))
		   (when (or (null next-wakeup-time)
			     (time-lessp (cdr x) next-wakeup-time))
		     (setq next-wakeup-time (cdr x)))))
	       (setq *background-wakeup-time* next-wakeup-time)))))))

))

;;Reset the background process to use the new function.
(when tcp:*tcp-background-process*
  (send tcp:*tcp-background-process* :reset))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#291 at 26-May-88 19:13:07
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "

(defun start-timeout (interval function socket)
  (without-interrupts
    (let* ((now (zl:time))
	   (time (time-increment now (floor (* 60 interval))))
	   (elt (assoc function (tcp-user-timeout-alist socket) :test #'eq)))
      (if elt
	  (setf (cdr elt) time)
	(push (cons function time) (tcp-user-timeout-alist socket)))
      (if (or (null *background-wakeup-time*)
	      (time-lessp time *background-wakeup-time*))
	  (setq *background-wakeup-time* time)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#291 at 26-May-88 19:13:11
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "

(defun start-global-timeout (interval function arg)
  (without-interrupts
    (let ((time (time-increment (zl:time) (floor (* 60 interval)))))
      (push (list time function arg) *global-timeouts*)
      (if (or (null *background-wakeup-time*)
	      (time-lessp time *background-wakeup-time*))
	  (setq *background-wakeup-time* time)))))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#291 at 26-May-88 19:13:15
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "

(defun cancel-timeout (socket &optional function)
  (without-interrupts
    (cond (function
	   ;;Cancelling a specific timeout
	   (let ((elt (assoc function (tcp-user-timeout-alist socket) :test #'eq)))
	     (when elt
	       (tcp-log :cancel socket function)
	       (setf (tcp-user-timeout-alist socket) (delete elt (tcp-user-timeout-alist socket))))))
	  ((tcp-user-timeout-alist socket)
	   ;;Cancelling all timeouts and some are set
	   (tcp-log :cancel socket nil)
	   (setf (tcp-user-timeout-alist socket) nil))
	  (t
	   ;;timeout not set...
	   nil))))

))