[OpenSPARC-T2-SAM] / obp / obp / pkg / netinet / tcp-output.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: tcp-output.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)tcp-output.fth 1.1 04/09/07
purpose: TCP output routines
copyright: Copyright 2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

headerless

\ Flags used when sending segments. Basic flags are determined by state. A
\ FIN is sent only if all data queued for output is included in the segment.
create tcp-outflags
   TH_RST TH_ACK or     c,          \ CLOSED
   0                    c,          \ LISTEN
   TH_SYN               c,          \ SYN_SENT
   TH_SYN TH_ACK or     c,          \ SYN_RCVD
   TH_ACK               c,          \ ESTABLISHED
   TH_ACK               c,          \ CLOSE_WAIT
   TH_FIN TH_ACK or     c,          \ FIN_WAIT_1
   TH_FIN TH_ACK or     c,          \ CLOSING
   TH_FIN TH_ACK or     c,          \ LAST_ACK
   TH_ACK               c,          \ FIN_WAIT_2
   TH_ACK               c,          \ TIME_WAIT

: tcp-outflags@ ( tcb -- flags )  tcp-outflags  swap tcb-state@ ca+  c@ ;

\ Fill options in outgoing SYN.
: tcp-fill-options ( tcb pkt -- )
   dup is-tcpsyn?  if						( tcb pkt )
      swap tcb-mss@  over dup tcpip-hlen@ ca+			( pkt mss adr )
      TCPOPT_MSS over c!  ca1+  4 over c!  ca1+  htonw!		( pkt )
      dup tcp-hlen@  4 +  swap tcp-hlen!			( )
   else								( tcb pkt )
      2drop							( )
   then								( )
;

\ Set retransmission timer based on current RTO value.
: tcp-set-rexmit-timer ( tcb -- )
   dup >tcbt-rexmit  swap tcb-rto@  set-timer
;

\ Cancel retranmission timer event.
: tcp-clear-rexmit-timer ( tcb -- )
   >tcbt-rexmit clear-timer  drop
;

\ Determine the location (as offset in current send window) and size of 
\ data that can be sent in a segment. The usable send window is the minimum 
\ of the offered and congestion windows, minus any data in flight. The 
\ size of data we could send is the minimum of the usable window, the MSS, 
\ or the amount of data at hand.

: tcp-snddata,len ( tcb -- offset len )
   dup >r						( tcb ) ( r: tcb )
   tcb>sndbuf tcpbuf-count@				( nbytes )
   r@  dup snd-nxt@  swap snd-una@ -			( nbytes #sent )
   tuck -  swap						( tosend #sent )
   r@  dup snd-wnd@  swap snd-cwnd@  min  over -	( tosend #sent wnd )
   rot  min   0 max					( #sent cansend )
   r>  tcb-mss@  min					( #sent len ) ( r: )
;

\ Fill segment data.
: tcp-fill-segdata ( tcb pkt -- datalen )
   over tcp-snddata,len  ?dup if		( tcb pkt offset len )
      >r >r					( tcb pkt ) ( r: len offset )
      dup tcpip-hlen@ ca+  swap tcb>sndbuf	( adr buf )
      r> rot r> tcpbuf-read			( len' ) ( r: )
   else						( tcb pkt offset )
      3drop 0					( 0 )
   then						( datalen )
;

\ Format segment that must be sent. Set PSH if all data in the send buffer 
\ is being sent in this segment. If the send buffer is not being emptied
\ by this output operation, clear FIN (in case it is set by tcp-outflags).

: tcp-fill-segment ( tcb pkt -- )
   >r
   IPPROTO_TCP              r@ >ip-protocol  c!			( tcb )
   my-ip-addr               r@ >ip-src       copy-ip-addr	( tcb )
   dup tcb>inpcb >in-faddr  r@ >ip-dest      copy-ip-addr	( tcb )
   IP_DEFAULT_TTL           r@ >ip-ttl       c!			( tcb )
   0                        r@ >ip-service   c!			( tcb )
   dup tcb>inpcb in-lport@  r@ >tcp-sport    htonw!		( tcb )
   dup tcb>inpcb in-fport@  r@ >tcp-dport    htonw!		( tcb )
   dup snd-nxt@             r@ >tcp-seq      htonl!		( tcb )
   dup rcv-nxt@             r@ >tcp-ack      htonl!		( tcb )
   dup rcv-wnd@             r@ >tcp-window   htonw!		( tcb )
   0                        r@ >tcp-urgptr   htonw!		( tcb )
   /tcp-header 2 lshift     r@ >tcp-offset   c!			( tcb )
   dup tcp-outflags@        r@ >tcp-flags    c!			( tcb )

   dup r@  tcp-fill-options					( tcb )
   dup r@  tcp-fill-segdata					( tcb len )
   r@ tcpip-hlen@  over +   r@ >ip-len       htonw!		( tcb len )

   ?dup  if							( tcb len )
      over snd-nxt@ +						( tcb s1 )
      over dup tcb>sndbuf tcpbuf-count@  swap snd-una@ +	( tcb s1 s2 )
      2dup  seq<  if						( tcb s1 s2 )
         2drop  r@ TH_FIN tcp-clear-flags			( tcb )
      else							( tcb s1 s2 )
         seq=  if						( tcb )
            r@ tcp-flags@  TH_PSH or  r@ tcp-flags!		( tcb )
         then							( tcb )
      then  							( tcb )
   then  drop							( )

   0                        r@ >tcp-cksum   htonw!		( )
   r@ tcp-checksum          r@ >tcp-cksum   htonw!		( )
   r> drop							( ) ( r: )
;

\ Determine if a segment must be sent. A segment must be sent if we need
\ to transmit data, critical controls (SYN, FIN or RST), or if we owe
\ peer an ACK. If we are sending data, we send more only if all outstanding
\ data has been acknowledged or we can send a full-sized segment.

: tcp-send-segment? ( tcb -- flag )
   \ Send if we owe peer an ACK
   dup tcb-flags@ TF_ACKNOW and  if  drop true exit  then	( tcb )

   \ Send if we need to send a SYN or RST
   dup tcp-outflags@  TH_SYN TH_RST or  and  if			( tcb )
      drop true exit						( true )
   then								( tcb )
   
   \ If we need to send a FIN but haven't yet done so, or we are
   \ retransmitting the FIN, we need to send this segment.
   dup tcp-outflags@ TH_FIN and  if				( tcb )
      dup tcb-flags@ TF_SENTFIN and 0=  if			( tcb )
         drop true exit						( true )
      then							( tcb )
      dup snd-nxt@  over snd-una@  seq=  if			( tcb )
         drop true exit						( true )
      then							( tcb  )
   then								( tcb )

   \ Determine length of data we can send in this segment
   dup  tcp-snddata,len nip					( tcb len )

   \ If there is unacknowledged data, we can send if we
   \ have at least one full-sized segment to send.
   over dup snd-nxt@  swap snd-una@ -  if			( tcb len )
      2dup swap tcb-mss@ <  if					( tcb len )
         2drop false exit					( false )
      then							( tcb len )
   then								( tcb len )

   \ Send segment if it contains data
   nip  0<>                                                     ( flag )
;

\ Compute receive window size to be advertised. Never shrink the window,
\ and perform receive side SWS avoidance. Don't advertise a window
\ larger than the one we are currently advertising (which can be 0) until
\ the window can be increased by either one segment or by one-half of
\ the receive buffer space.

: tcp-rwindow-update ( tcb -- )
   dup tcb>rcvbuf						( tcb buf )
   2dup tcpbuf-space@  swap rcv-wnd@ -				( tcb buf incr )
   >r  tcpbuf-size@ 2/  over tcb-mss@ min  r> tuck swap >=  if	( tcb incr )
      over rcv-wnd@  +  swap rcv-wnd!				( )
   else								( tcb incr )
      2drop
   then
;

\ Format and send the TCP segment. If we are sending data or SYN/FIN
\ segments, schedule retransmission and arrange to gather round trip
\ time estimates.

: tcp-send-segment ( tcb -- )

   \ Allocate a packet buffer
   pkt-alloc ?dup 0=  if  drop exit  then		( tcb pkt )

   \ Dont use a new sequence number if resending a FIN.
   swap  dup tcp-outflags@ TH_FIN and  if		( pkt tcb )
      dup tcb-flags@ TF_SENTFIN and  if			( pkt tcb )
         dup snd-nxt@  over snd-max@  seq=  if		( pkt tcb )
            dup snd-nxt@ 1-  over snd-nxt!		( pkt tcb )
         then						( pkt tcb )
      then						( pkt tcb )
   then  swap						( tcb pkt )

   \ Determine window size to advertise.
   over tcp-rwindow-update				( tcb pkt )

   \ Fill in the segment.
   2dup tcp-fill-segment				( tcb pkt )

   \ Mark transmission of FIN.
   tuck is-tcpfin? if					( pkt tcb )
      dup TF_SENTFIN tcb-set-flags			( pkt tcb )
   then							( pkt tcb )

   \ Advance SND.NXT over sequence space of this segment.
   over seg-len@  over snd-nxt@ +  over snd-nxt!	( pkt tcb )

   \ Update SND.MAX, and time this transmission if this is
   \ not a retransmission and we are not timing anything.
   dup snd-nxt@  over snd-max@  seq>  if		( pkt tcb )
      dup snd-nxt@  over snd-max!			( pkt tcb )
      dup tcb-flags@ TF_RTTGET and  0= if		( pkt tcb )
         dup TF_RTTGET tcb-set-flags			( pkt tcb )
         over seg-seq@  over >tcb-rttseq l!		( pkt tcb )
      then						( pkt tcb )
   then							( pkt tcb )

   \ Set retransmit timer if it isn't currently set and
   \ this is not just an ACK.
   over seg-len@ 0<>  if				( pkt tcb )
      dup >tcbt-rexmit timer-running? 0=  if		( pkt tcb )
         dup tcp-set-rexmit-timer			( pkt tcb )
      then						( pkt tcb )
   then  swap						( tcb pkt )

   2dup TR_OUTPUT 0 tcp-trace				( tcb pkt )

   \ Send the segment. Any pending ACK has now been sent. 
   \ Failures are recorded in the TCB.
   ip-output  dup 0<  if				( tcb error# )
      swap tcb-error!					( )
   else							( tcb #sent )
      drop  TF_ACKNOW TF_DELACK or tcb-clear-flags	( )
   then							( )
;

\ Generate an acceptable reset (RST) in response to a bad incoming packet.
\ A RST is never sent in response to a RST.

: tcp-reset ( tcb pkt -- )
   dup is-tcprst?     if  2drop exit  then		( tcb pkt )
   pkt-alloc ?dup 0=  if  2drop exit  then   		( tcb pkt rstpkt )

   IPPROTO_TCP             over >ip-protocol  c!
   my-ip-addr              over >ip-src       copy-ip-addr
   over >ip-src            over >ip-dest      copy-ip-addr
   IP_DEFAULT_TTL          over >ip-ttl       c!
   0                       over >ip-service   c!
   over >tcp-dport ntohw@  over >tcp-sport    htonw!
   over >tcp-sport ntohw@  over >tcp-dport    htonw!

   over is-tcpack?  if
      over seg-ack@        over >tcp-seq      htonl!
      TH_RST               over >tcp-flags    c!
   else
      0                    over >tcp-seq      htonl!
      TH_RST TH_ACK or     over >tcp-flags    c!
   then							( tcb pkt rstpkt )
   swap seg-lastseq@ 1+    over >tcp-ack      htonl!	( tcb rstpkt )

   0                       over >tcp-window   htonw!    
   0                       over >tcp-urgptr   htonw!
   /tcp-header 2 lshift    over >tcp-offset   c!
   0                       over >tcp-cksum    htonw!
   /tcpip-header           over >ip-len       htonw!
   dup tcp-checksum        over >tcp-cksum    htonw!	( tcb rstpkt )

   tuck TR_OUTPUT 0 tcp-trace				( rstpkt ) 

   ip-output  drop					( )
;

\ TCP output routine. Send all the data we can.
: tcp-output ( tcb -- )
   dup  tcb>sndbuf tcpbuf-count@			( tcb nbytes )
   over dup snd-nxt@  swap snd-una@ - -			( tcb #unsent )
   over tcb-mss@ >  if					( tcb )
      begin  dup tcp-send-segment?  while		( tcb )
         dup tcp-send-segment				( tcb )
      repeat  drop					( )
   else							( tcb )
      dup tcp-send-segment?  if				( tcb )
         dup tcp-send-segment				( tcb )
      then  drop					( )
   then  						( )
;

\ Force the connection to be dropped, reporting the specified error.
\ If the connection is synchronized, then a RST must be sent to peer.

: tcp-drop ( tcb error# -- )
   swap  dup tcb-state@ TCPS_SYN_RCVD >=  if		( error# tcb )
      TCPS_CLOSED over tcb-state!			( error# tcb )
      dup tcp-output					( error# tcb )
   then							( error# tcb )
   dup tcb-kill-timers					( error# tcb )
   tcb-error!						( )
;

\ Handle retransmission timeouts.
: tcp-retransmit ( tcb -- )

   \ Clear timer and apply backoff.
   dup tcp-clear-rexmit-timer  dup tcp-backoff		( tcb )

   \ Enforce maximum retransmission count.
   dup >tcb-nrexmits l@  1+  dup TCP_MAXRETRIES >  if	( tcb ntries )
      drop  ETIMEDOUT tcp-drop  exit			( )
   then  over >tcb-nrexmits l!				( tcb )

   \ Reduce ssthresh to max(flightsize/2, 2*mss)
   dup snd-nxt@  over snd-una@ -  2/			( tcb flightsize/2 )
   over tcb-mss@ 2*  max  over ssthresh!		( tcb )

   \ Shrink congestion window to 1 segment.
   dup tcb-mss@  over snd-cwnd!				( tcb )

   \ Force retransmission of oldest unacknowledged data.
   dup snd-una@  over snd-nxt!				( tcb )
   tcp-output						( )
;

headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: tcp-output.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	id: @(#)tcp-output.fth 1.1 04/09/07
	43	purpose: TCP output routines
	44	copyright: Copyright 2004 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	headerless
	48
	49	\ Flags used when sending segments. Basic flags are determined by state. A
	50	\ FIN is sent only if all data queued for output is included in the segment.
	51	create tcp-outflags
	52	TH_RST TH_ACK or c, \ CLOSED
	53	0 c, \ LISTEN
	54	TH_SYN c, \ SYN_SENT
	55	TH_SYN TH_ACK or c, \ SYN_RCVD
	56	TH_ACK c, \ ESTABLISHED
	57	TH_ACK c, \ CLOSE_WAIT
	58	TH_FIN TH_ACK or c, \ FIN_WAIT_1
	59	TH_FIN TH_ACK or c, \ CLOSING
	60	TH_FIN TH_ACK or c, \ LAST_ACK
	61	TH_ACK c, \ FIN_WAIT_2
	62	TH_ACK c, \ TIME_WAIT
	63
	64	: tcp-outflags@ ( tcb -- flags ) tcp-outflags swap tcb-state@ ca+ c@ ;
65
66	\ Fill options in outgoing SYN.
67	: tcp-fill-options ( tcb pkt -- )
68	dup is-tcpsyn? if ( tcb pkt )
69	swap tcb-mss@ over dup tcpip-hlen@ ca+ ( pkt mss adr )
70	TCPOPT_MSS over c! ca1+ 4 over c! ca1+ htonw! ( pkt )
71	dup tcp-hlen@ 4 + swap tcp-hlen! ( )
72	else ( tcb pkt )
73	2drop ( )
74	then ( )
75	;
76
77	\ Set retransmission timer based on current RTO value.
78	: tcp-set-rexmit-timer ( tcb -- )
79	dup >tcbt-rexmit swap tcb-rto@ set-timer
80	;
81
82	\ Cancel retranmission timer event.
83	: tcp-clear-rexmit-timer ( tcb -- )
84	>tcbt-rexmit clear-timer drop
85	;
86
87	\ Determine the location (as offset in current send window) and size of
88	\ data that can be sent in a segment. The usable send window is the minimum
89	\ of the offered and congestion windows, minus any data in flight. The
90	\ size of data we could send is the minimum of the usable window, the MSS,
91	\ or the amount of data at hand.
92
93	: tcp-snddata,len ( tcb -- offset len )
94	dup >r ( tcb ) ( r: tcb )
95	tcb>sndbuf tcpbuf-count@ ( nbytes )
96	r@ dup snd-nxt@ swap snd-una@ - ( nbytes #sent )
97	tuck - swap ( tosend #sent )
98	r@ dup snd-wnd@ swap snd-cwnd@ min over - ( tosend #sent wnd )
99	rot min 0 max ( #sent cansend )
100	r> tcb-mss@ min ( #sent len ) ( r: )
101	;
102
103	\ Fill segment data.
104	: tcp-fill-segdata ( tcb pkt -- datalen )
105	over tcp-snddata,len ?dup if ( tcb pkt offset len )
106	>r >r ( tcb pkt ) ( r: len offset )
107	dup tcpip-hlen@ ca+ swap tcb>sndbuf ( adr buf )
108	r> rot r> tcpbuf-read ( len' ) ( r: )
109	else ( tcb pkt offset )
110	3drop 0 ( 0 )
111	then ( datalen )
112	;
113
114	\ Format segment that must be sent. Set PSH if all data in the send buffer
115	\ is being sent in this segment. If the send buffer is not being emptied
116	\ by this output operation, clear FIN (in case it is set by tcp-outflags).
117
118	: tcp-fill-segment ( tcb pkt -- )
119	>r
120	IPPROTO_TCP r@ >ip-protocol c! ( tcb )
121	my-ip-addr r@ >ip-src copy-ip-addr ( tcb )
122	dup tcb>inpcb >in-faddr r@ >ip-dest copy-ip-addr ( tcb )
123	IP_DEFAULT_TTL r@ >ip-ttl c! ( tcb )
124	0 r@ >ip-service c! ( tcb )
125	dup tcb>inpcb in-lport@ r@ >tcp-sport htonw! ( tcb )
126	dup tcb>inpcb in-fport@ r@ >tcp-dport htonw! ( tcb )
127	dup snd-nxt@ r@ >tcp-seq htonl! ( tcb )
128	dup rcv-nxt@ r@ >tcp-ack htonl! ( tcb )
129	dup rcv-wnd@ r@ >tcp-window htonw! ( tcb )
130	0 r@ >tcp-urgptr htonw! ( tcb )
131	/tcp-header 2 lshift r@ >tcp-offset c! ( tcb )
132	dup tcp-outflags@ r@ >tcp-flags c! ( tcb )
133
134	dup r@ tcp-fill-options ( tcb )
135	dup r@ tcp-fill-segdata ( tcb len )
136	r@ tcpip-hlen@ over + r@ >ip-len htonw! ( tcb len )
137
138	?dup if ( tcb len )
139	over snd-nxt@ + ( tcb s1 )
140	over dup tcb>sndbuf tcpbuf-count@ swap snd-una@ + ( tcb s1 s2 )
141	2dup seq< if ( tcb s1 s2 )
142	2drop r@ TH_FIN tcp-clear-flags ( tcb )
143	else ( tcb s1 s2 )
144	seq= if ( tcb )
145	r@ tcp-flags@ TH_PSH or r@ tcp-flags! ( tcb )
146	then ( tcb )
147	then ( tcb )
148	then drop ( )
149
150	0 r@ >tcp-cksum htonw! ( )
151	r@ tcp-checksum r@ >tcp-cksum htonw! ( )
152	r> drop ( ) ( r: )
153	;
154
155	\ Determine if a segment must be sent. A segment must be sent if we need
156	\ to transmit data, critical controls (SYN, FIN or RST), or if we owe
157	\ peer an ACK. If we are sending data, we send more only if all outstanding
158	\ data has been acknowledged or we can send a full-sized segment.
159
160	: tcp-send-segment? ( tcb -- flag )
161	\ Send if we owe peer an ACK
162	dup tcb-flags@ TF_ACKNOW and if drop true exit then ( tcb )
163
164	\ Send if we need to send a SYN or RST
165	dup tcp-outflags@ TH_SYN TH_RST or and if ( tcb )
166	drop true exit ( true )
167	then ( tcb )
168
169	\ If we need to send a FIN but haven't yet done so, or we are
170	\ retransmitting the FIN, we need to send this segment.
171	dup tcp-outflags@ TH_FIN and if ( tcb )
172	dup tcb-flags@ TF_SENTFIN and 0= if ( tcb )
173	drop true exit ( true )
174	then ( tcb )
175	dup snd-nxt@ over snd-una@ seq= if ( tcb )
176	drop true exit ( true )
177	then ( tcb )
178	then ( tcb )
179
180	\ Determine length of data we can send in this segment
181	dup tcp-snddata,len nip ( tcb len )
182
183	\ If there is unacknowledged data, we can send if we
184	\ have at least one full-sized segment to send.
185	over dup snd-nxt@ swap snd-una@ - if ( tcb len )
186	2dup swap tcb-mss@ < if ( tcb len )
187	2drop false exit ( false )
188	then ( tcb len )
189	then ( tcb len )
190
191	\ Send segment if it contains data
192	nip 0<> ( flag )
193	;
194
195	\ Compute receive window size to be advertised. Never shrink the window,
196	\ and perform receive side SWS avoidance. Don't advertise a window
197	\ larger than the one we are currently advertising (which can be 0) until
198	\ the window can be increased by either one segment or by one-half of
199	\ the receive buffer space.
200
201	: tcp-rwindow-update ( tcb -- )
202	dup tcb>rcvbuf ( tcb buf )
203	2dup tcpbuf-space@ swap rcv-wnd@ - ( tcb buf incr )
204	>r tcpbuf-size@ 2/ over tcb-mss@ min r> tuck swap >= if ( tcb incr )
205	over rcv-wnd@ + swap rcv-wnd! ( )
206	else ( tcb incr )
207	2drop
208	then
209	;
210
211	\ Format and send the TCP segment. If we are sending data or SYN/FIN
212	\ segments, schedule retransmission and arrange to gather round trip
213	\ time estimates.
214
215	: tcp-send-segment ( tcb -- )
216
217	\ Allocate a packet buffer
218	pkt-alloc ?dup 0= if drop exit then ( tcb pkt )
219
220	\ Dont use a new sequence number if resending a FIN.
221	swap dup tcp-outflags@ TH_FIN and if ( pkt tcb )
222	dup tcb-flags@ TF_SENTFIN and if ( pkt tcb )
223	dup snd-nxt@ over snd-max@ seq= if ( pkt tcb )
224	dup snd-nxt@ 1- over snd-nxt! ( pkt tcb )
225	then ( pkt tcb )
226	then ( pkt tcb )
227	then swap ( tcb pkt )
228
229	\ Determine window size to advertise.
230	over tcp-rwindow-update ( tcb pkt )
231
232	\ Fill in the segment.
233	2dup tcp-fill-segment ( tcb pkt )
234
235	\ Mark transmission of FIN.
236	tuck is-tcpfin? if ( pkt tcb )
237	dup TF_SENTFIN tcb-set-flags ( pkt tcb )
238	then ( pkt tcb )
239
240	\ Advance SND.NXT over sequence space of this segment.
241	over seg-len@ over snd-nxt@ + over snd-nxt! ( pkt tcb )
242
243	\ Update SND.MAX, and time this transmission if this is
244	\ not a retransmission and we are not timing anything.
245	dup snd-nxt@ over snd-max@ seq> if ( pkt tcb )
246	dup snd-nxt@ over snd-max! ( pkt tcb )
247	dup tcb-flags@ TF_RTTGET and 0= if ( pkt tcb )
248	dup TF_RTTGET tcb-set-flags ( pkt tcb )
249	over seg-seq@ over >tcb-rttseq l! ( pkt tcb )
250	then ( pkt tcb )
251	then ( pkt tcb )
252
253	\ Set retransmit timer if it isn't currently set and
254	\ this is not just an ACK.
255	over seg-len@ 0<> if ( pkt tcb )
256	dup >tcbt-rexmit timer-running? 0= if ( pkt tcb )
257	dup tcp-set-rexmit-timer ( pkt tcb )
258	then ( pkt tcb )
259	then swap ( tcb pkt )
260
261	2dup TR_OUTPUT 0 tcp-trace ( tcb pkt )
262
263	\ Send the segment. Any pending ACK has now been sent.
264	\ Failures are recorded in the TCB.
265	ip-output dup 0< if ( tcb error# )
266	swap tcb-error! ( )
267	else ( tcb #sent )
268	drop TF_ACKNOW TF_DELACK or tcb-clear-flags ( )
269	then ( )
270	;
271
272	\ Generate an acceptable reset (RST) in response to a bad incoming packet.
273	\ A RST is never sent in response to a RST.
274
275	: tcp-reset ( tcb pkt -- )
276	dup is-tcprst? if 2drop exit then ( tcb pkt )
277	pkt-alloc ?dup 0= if 2drop exit then ( tcb pkt rstpkt )
278
279	IPPROTO_TCP over >ip-protocol c!
280	my-ip-addr over >ip-src copy-ip-addr
281	over >ip-src over >ip-dest copy-ip-addr
282	IP_DEFAULT_TTL over >ip-ttl c!
283	0 over >ip-service c!
284	over >tcp-dport ntohw@ over >tcp-sport htonw!
285	over >tcp-sport ntohw@ over >tcp-dport htonw!
286
287	over is-tcpack? if
288	over seg-ack@ over >tcp-seq htonl!
289	TH_RST over >tcp-flags c!
290	else
291	0 over >tcp-seq htonl!
292	TH_RST TH_ACK or over >tcp-flags c!
293	then ( tcb pkt rstpkt )
294	swap seg-lastseq@ 1+ over >tcp-ack htonl! ( tcb rstpkt )
295
296	0 over >tcp-window htonw!
297	0 over >tcp-urgptr htonw!
298	/tcp-header 2 lshift over >tcp-offset c!
299	0 over >tcp-cksum htonw!
300	/tcpip-header over >ip-len htonw!
301	dup tcp-checksum over >tcp-cksum htonw! ( tcb rstpkt )
302
303	tuck TR_OUTPUT 0 tcp-trace ( rstpkt )
304
305	ip-output drop ( )
306	;
307
308	\ TCP output routine. Send all the data we can.
309	: tcp-output ( tcb -- )
310	dup tcb>sndbuf tcpbuf-count@ ( tcb nbytes )
311	over dup snd-nxt@ swap snd-una@ - - ( tcb #unsent )
312	over tcb-mss@ > if ( tcb )
313	begin dup tcp-send-segment? while ( tcb )
314	dup tcp-send-segment ( tcb )
315	repeat drop ( )
316	else ( tcb )
317	dup tcp-send-segment? if ( tcb )
318	dup tcp-send-segment ( tcb )
319	then drop ( )
320	then ( )
321	;
322
323	\ Force the connection to be dropped, reporting the specified error.
324	\ If the connection is synchronized, then a RST must be sent to peer.
325
326	: tcp-drop ( tcb error# -- )
327	swap dup tcb-state@ TCPS_SYN_RCVD >= if ( error# tcb )
328	TCPS_CLOSED over tcb-state! ( error# tcb )
329	dup tcp-output ( error# tcb )
330	then ( error# tcb )
331	dup tcb-kill-timers ( error# tcb )
332	tcb-error! ( )
333	;
334
335	\ Handle retransmission timeouts.
336	: tcp-retransmit ( tcb -- )
337
338	\ Clear timer and apply backoff.
339	dup tcp-clear-rexmit-timer dup tcp-backoff ( tcb )
340
341	\ Enforce maximum retransmission count.
342	dup >tcb-nrexmits l@ 1+ dup TCP_MAXRETRIES > if ( tcb ntries )
343	drop ETIMEDOUT tcp-drop exit ( )
344	then over >tcb-nrexmits l! ( tcb )
345
346	\ Reduce ssthresh to max(flightsize/2, 2*mss)
347	dup snd-nxt@ over snd-una@ - 2/ ( tcb flightsize/2 )
348	over tcb-mss@ 2* max over ssthresh! ( tcb )
349
350	\ Shrink congestion window to 1 segment.
351	dup tcb-mss@ over snd-cwnd! ( tcb )
352
353	\ Force retransmission of oldest unacknowledged data.
354	dup snd-una@ over snd-nxt! ( tcb )
355	tcp-output ( )
356	;
357
358	headers