;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.33
;;; Reason:
;;;  start-failed-control-packet-send-timeout could never have worked because start-timeout
;;;  always requires a TCP socket.  Create the concept of a TCP "global timeout" -- one that
;;;  doesn't pertain to a specific connection.
;;; Written 7-Oct-87 11:01:37 by pld (Peter L. DeWolf) at site LMI Cambridge
;;; while running on Jack Flanders from band 2
;;; with Experimental System 123.32, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.0, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#277 at 7-Oct-87 11:02:02
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "


(defvar *global-timeouts* nil
  "List of timeouts (time function arg) not associated with a socket")

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#277 at 7-Oct-87 11:02:12
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "


(defun initialize-tcp-background-process ()
  (setq *send-blocked-sockets* (make-fifo))
  (setq *send-blocked-control-packets* (make-fifo))
  (setq *global-timeouts* nil)
  (send *tcp-background-process* :preset 'tcp-background-process)
  (send *tcp-background-process* :reset)
  (send *tcp-background-process* :run-reason :enable)
  (send *tcp-background-process* :revoke-arrest-reason :not-running))

))

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#277 at 7-Oct-87 11:02:18
#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)
  (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#277 at 7-Oct-87 11:03:02
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "

(defun tcp-background-process ()
  (do ((int-pkt nil nil)
       (elt nil)
       (socket nil)
       (now nil nil))
      (nil)
    
    (process-wait "Timeout"
		  #'(lambda () (and (tcp-enabled *tcp-stream*)
				    (or (and (or (not (fifo-empty-p *send-blocked-control-packets*))
						 (not (fifo-empty-p *send-blocked-sockets*)))
					     (or int-pkt
						 (setq int-pkt (net:allocate-packet nil))))
					(and *background-wakeup-time*
					     (not (time-lessp (setq now (zl:time))
							      *background-wakeup-time*)))))))

    (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))
		(next-wakeup-time nil)
		(result nil))
	       ((null list)
		(setq *global-timeouts* result)
		(setq *background-wakeup-time* next-wakeup-time))
	     (let* ((elt (car list))
		    (time (first elt)))
	       (cond ((time-lessp time now)
		      (funcall (second elt) (third elt) now))
		     (t
		      (when (or (null next-wakeup-time)
				(time-lessp time next-wakeup-time))
			(setq next-wakeup-time time))
		      (push elt result)))))

	   ;;And the socket specific timeouts
	   (do ((list (tcp-user-socket-alist *tcp-stream*) (cdr list))
		(next-wakeup-time *background-wakeup-time*))
	       ((null list)
		(setq *background-wakeup-time* next-wakeup-time))
	     (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)))
	       (dolist (x (tcp-user-timeout-alist socket))
		 ;;If new timeout set, see if earliest
		 (when (or (null next-wakeup-time)
			   (time-lessp (cdr x) next-wakeup-time))
		   (setq next-wakeup-time (cdr x))))))))))

))

(send tcp:*tcp-background-process* :reset)

; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#277 at 7-Oct-87 11:03:39
#10R TCP#: 
(COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  "


(defun start-failed-control-packet-send-timeout (header ip-header tp)
  (tcp-log :failed-send tp)
  (tcp-stat-incf tp failed-sends)
  (start-global-timeout *failed-send-retry-interval*
			'failed-control-packet-send-timeout
			;;Note that we don't save tp -- the connection could be aborting
			(list header ip-header nil)))

))