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

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: tcp.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.fth 1.1 04/09/07
purpose: TCP support
copyright: Copyright 2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ RFC 793: Transmission Control Protocol

fload ${BP}/pkg/netinet/tcp-h.fth
fload ${BP}/pkg/netinet/tcpbuf.fth
fload ${BP}/pkg/netinet/tcb.fth
fload ${BP}/pkg/netinet/tcp-trace.fth

headerless

/queue-head  instance buffer:  tcp-inpcb-list	\ Head of TCP's INPCB list

: tcp-init ( -- )
   tcp-inpcb-list queue-init
[ifdef] DEBUG
   tcptrace-init
[then]
;

: tcp-close ( -- )  ;

\ Compute TCP packet checksum.
: tcp-checksum ( ip-pkt -- chksum )
   IPPROTO_TCP  over >ip-src  /ip-addr    (in-cksum)
                over >ip-dest /ip-addr    (in-cksum)
   swap  ippkt>payload  rot over +  -rot  in-cksum
;

\ ISN selection. This must be a reasonably random number.
: tcp-iss ( -- iss )  random ;

\ Initialize TCP send sequence variables.
: tcp-sendseq-init ( tcb -- )
   tcp-iss swap  2dup snd-una!  2dup snd-nxt!  2dup snd-wl2!  snd-max!
;

\ Estimating mean round trip time and variance. Use the "fast algorithm
\ for RTT mean and variation" from "Congestion Avoidance and Control",
\ Jacobson, V. and M. Karels, Nov 1988.
\
\ SRTT and RTTVAR are stored as fixed point numbers with scaling factors
\ of 8 and 4 respectively. On the first RTT measurement (SRTT = 0), the 
\ values stored in SRTT and RTTVAR reflect their scaling factors. For 
\ subsequent measurements, the code becomes 
\
\	error = measurement - (average >> 3);
\	average = average + error;
\	if (error < 0)
\		error = -error;
\	error = error - (variance >> 2);
\	variance = variance + error;
\	RTO = (average >> 3) + variance;
\
\ reflecting alpha = 1/8, beta = 1/4, and RTO = A + 4D. 

\ Set next retransmission timeout interval, enforcing lower and upper
\ bounds for the timeout.
: tcp-set-rto ( tcb rto -- ) d# 1000 max  d# 60000 min  swap tcb-rto! ;

\ Update RTT estimators and compute RTO, enforcing lower and upper
\ bounds for the timeout
: tcp-update-rto ( tcb rtt -- )
   2dup swap >tcb-rtt l!				( tcb rtt )
   over tcb-srtt@ 0<>  if				( tcb rtt )
      over tcb-srtt@  3 rshift  -			( tcb error )
      2dup over tcb-srtt@ +  swap tcb-srtt!		( tcb error )
      abs  over tcb-rttvar@  2 rshift -			( tcb error' )
      over tcb-rttvar@ +  over tcb-rttvar!		( tcb )
   else							( tcb rtt )
      2dup 3 lshift  swap tcb-srtt!			( tcb rtt )
      1 lshift       over tcb-rttvar!			( tcb )
   then							( tcb )
   dup tcb-srtt@ 3 rshift  over tcb-rttvar@ +		( tcb rto )
   tcp-set-rto						( )
;

\ Back off the timer on retransmissions.
: tcp-backoff ( tcb -- )  dup tcb-rto@ 2*  tcp-set-rto ;

headers

fload ${BP}/pkg/netinet/tcp-output.fth
fload ${BP}/pkg/netinet/tcp-timer.fth
fload ${BP}/pkg/netinet/tcp-input.fth

headerless

: tcp-connected? ( tcb -- flag )
   tcb-state@  TCPS_ESTABLISHED =
;

: tcp-disconnected? ( tcb -- flag )
   tcb-state@  dup TCPS_CLOSED =  swap TCPS_TIME_WAIT =  or
;

\ Process packets until desired state is reached or an error is seen.
: tcp-state-wait ( tcb acf -- )
   begin						( tcb acf )
      2dup execute 0=  2 pick tcb-error@ 0=  and	( tcb acf flag )
   while						( tcb acf )
      tcp-poll						( tcb acf )
   repeat  2drop					( )
;

\ Pushed data can be delivered if we have received all data up through 
\ the recorded push sequence. 

: tcp-pushdata? ( tcb -- flag )
   dup tcb-flags@ TF_PUSH and  if			( tcb )
      dup rcv-nxt@  swap >tcb-pushseq l@  seq>=		( flag )
   else							( tcb )
      drop false					( false )
   then							( flag )
;

\ Check if the read request can be satisfied. Data in the receive
\ buffer can be read if we have enough data, or we are not expecting
\ any more data, or data is being pushed. 

: tcp-cangetdata? ( tcb len -- cangetdata? )
   over tcb-error@ 0=  if				( tcb len )
      over tcb>rcvbuf tcpbuf-count@ <=			( tcb flag )
      over tcp-pushdata? or				( tcb flag' )
      swap tcp-receive-done?  or			( cangetdata? )
   else							( tcb len )
      2drop false					( false )
   then							( cangetdata? )
;

\ Copy data from TCP receive buffer to an user buffer. If the window can
\ now be opened up at least 50% of the maximum window we ever advertised,
\ send a window update. 
 
: tcp-getdata ( tcb adr len -- nread )
   rot >r						( adr len ) ( r: tcb )

   \ Read data from the receive buffer
   r@ tcb>rcvbuf  dup  2swap 0 -rot tcpbuf-read		( buf nread )
   2dup tcpbuf-drop					( buf nread )

   \ Clear PUSH state if all outstanding data has been
   \ delivered to the application.
   over tcpbuf-count@ 0=  if				( buf nread )
      r@ TF_PUSH tcb-clear-flags			( buf nread )
   then							( buf nread )

   \ Schedule a window update if one can be sent. 
   over tcpbuf-space@ r@ rcv-wnd@ -			( buf nread incr )
   rot  tcpbuf-size@ 2/  >=  if				( nread )
      r@ TF_ACKNOW tcb-set-flags			( nread )
   then							( nread )

   r> tcp-output					( nread ) ( r: )
;

\ Check if we can accept a send request. 
: tcp-canputdata? ( tcb len -- flag )
   over tcb-error@ 0=  if			( tcb len )
      swap  tcb>sndbuf  tcpbuf-space@  <=	( flag )
   else						( tcb len )
      2drop false				( false )
   then						( flag )
;

\ Copy data from an user buffer to the end of the send buffer.
: tcp-putdata ( tcb adr len -- len' )
   rot tcb>sndbuf  dup >r			( adr len buf ) ( r: buf )
   dup tcpbuf-count@  2swap  tcpbuf-write	( len' )
   r> over tcpbuf-count+!			( len' ) ( r: )
;

\ Initiate a connection. 
: tcp-open-connection ( tcb -- 0 | error )
   tcp-start-timers					( tcb )
   dup tcp-sendseq-init					( tcb )
   dup >tcbt-connect TCP_CONN_TIMEOUT set-timer		( tcb )
   TCPS_SYN_SENT over tcb-state!			( tcb )
   dup tcp-output					( tcb )
   dup ['] tcp-connected? tcp-state-wait		( tcb )
   dup >tcbt-connect clear-timer drop			( tcb )
   tcb-error@						( result )
;

\ Accept incoming connections.
: tcp-accept-connection ( tcb -- 0 | error# )
   tcp-start-timers					( tcb )
   dup ['] tcp-connected? tcp-state-wait		( tcb )
   tcb-error@						( result )
;

\ Initiate a TCP disconnect.
: tcp-disconnect ( tcb -- )
   dup tcb-state@  case
      TCPS_SYN_RCVD    of  TCPS_FIN_WAIT_1 over tcb-state!  endof
      TCPS_ESTABLISHED of  TCPS_FIN_WAIT_1 over tcb-state!  endof
      TCPS_CLOSE_WAIT  of  TCPS_LAST_ACK   over tcb-state!  endof
   endcase
   tcp-output
;

\ Close a connection.
: tcp-close-connection ( tcb -- )
   tcp-drain-input					( tcb )
   dup tcb-state@  TCPS_SYN_SENT <=  if			( tcb )
      TCPS_CLOSED swap tcb-state!			( )
   else							( tcb )
      dup tcb>rcvbuf tcpbuf-count@ 0<>	if		( tcb )
         TCPS_CLOSED over tcb-state!  tcp-output	( )
         tcp-drain-input				( )
      else						( tcb )
         dup tcp-disconnect				( tcb )
         ['] tcp-disconnected? tcp-state-wait		( )
      then						( )
   then							( )
;

fload ${BP}/pkg/netinet/tcp-debug.fth	\ Post-mortem debugging routines

headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: tcp.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.fth 1.1 04/09/07
	43	purpose: TCP support
	44	copyright: Copyright 2004 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ RFC 793: Transmission Control Protocol
	48
	49	fload ${BP}/pkg/netinet/tcp-h.fth
	50	fload ${BP}/pkg/netinet/tcpbuf.fth
	51	fload ${BP}/pkg/netinet/tcb.fth
	52	fload ${BP}/pkg/netinet/tcp-trace.fth
	53
	54	headerless
	55
	56	/queue-head instance buffer: tcp-inpcb-list \ Head of TCP's INPCB list
	57
	58	: tcp-init ( -- )
	59	tcp-inpcb-list queue-init
	60	[ifdef] DEBUG
	61	tcptrace-init
	62	[then]
	63	;
	64
65	: tcp-close ( -- ) ;
66
67	\ Compute TCP packet checksum.
68	: tcp-checksum ( ip-pkt -- chksum )
69	IPPROTO_TCP over >ip-src /ip-addr (in-cksum)
70	over >ip-dest /ip-addr (in-cksum)
71	swap ippkt>payload rot over + -rot in-cksum
72	;
73
74	\ ISN selection. This must be a reasonably random number.
75	: tcp-iss ( -- iss ) random ;
76
77	\ Initialize TCP send sequence variables.
78	: tcp-sendseq-init ( tcb -- )
79	tcp-iss swap 2dup snd-una! 2dup snd-nxt! 2dup snd-wl2! snd-max!
80	;
81
82	\ Estimating mean round trip time and variance. Use the "fast algorithm
83	\ for RTT mean and variation" from "Congestion Avoidance and Control",
84	\ Jacobson, V. and M. Karels, Nov 1988.
85	\
86	\ SRTT and RTTVAR are stored as fixed point numbers with scaling factors
87	\ of 8 and 4 respectively. On the first RTT measurement (SRTT = 0), the
88	\ values stored in SRTT and RTTVAR reflect their scaling factors. For
89	\ subsequent measurements, the code becomes
90	\
91	\ error = measurement - (average >> 3);
92	\ average = average + error;
93	\ if (error < 0)
94	\ error = -error;
95	\ error = error - (variance >> 2);
96	\ variance = variance + error;
97	\ RTO = (average >> 3) + variance;
98	\
99	\ reflecting alpha = 1/8, beta = 1/4, and RTO = A + 4D.
100
101	\ Set next retransmission timeout interval, enforcing lower and upper
102	\ bounds for the timeout.
103	: tcp-set-rto ( tcb rto -- ) d# 1000 max d# 60000 min swap tcb-rto! ;
104
105	\ Update RTT estimators and compute RTO, enforcing lower and upper
106	\ bounds for the timeout
107	: tcp-update-rto ( tcb rtt -- )
108	2dup swap >tcb-rtt l! ( tcb rtt )
109	over tcb-srtt@ 0<> if ( tcb rtt )
110	over tcb-srtt@ 3 rshift - ( tcb error )
111	2dup over tcb-srtt@ + swap tcb-srtt! ( tcb error )
112	abs over tcb-rttvar@ 2 rshift - ( tcb error' )
113	over tcb-rttvar@ + over tcb-rttvar! ( tcb )
114	else ( tcb rtt )
115	2dup 3 lshift swap tcb-srtt! ( tcb rtt )
116	1 lshift over tcb-rttvar! ( tcb )
117	then ( tcb )
118	dup tcb-srtt@ 3 rshift over tcb-rttvar@ + ( tcb rto )
119	tcp-set-rto ( )
120	;
121
122	\ Back off the timer on retransmissions.
123	: tcp-backoff ( tcb -- ) dup tcb-rto@ 2* tcp-set-rto ;
124
125	headers
126
127	fload ${BP}/pkg/netinet/tcp-output.fth
128	fload ${BP}/pkg/netinet/tcp-timer.fth
129	fload ${BP}/pkg/netinet/tcp-input.fth
130
131	headerless
132
133	: tcp-connected? ( tcb -- flag )
134	tcb-state@ TCPS_ESTABLISHED =
135	;
136
137	: tcp-disconnected? ( tcb -- flag )
138	tcb-state@ dup TCPS_CLOSED = swap TCPS_TIME_WAIT = or
139	;
140
141	\ Process packets until desired state is reached or an error is seen.
142	: tcp-state-wait ( tcb acf -- )
143	begin ( tcb acf )
144	2dup execute 0= 2 pick tcb-error@ 0= and ( tcb acf flag )
145	while ( tcb acf )
146	tcp-poll ( tcb acf )
147	repeat 2drop ( )
148	;
149
150	\ Pushed data can be delivered if we have received all data up through
151	\ the recorded push sequence.
152
153	: tcp-pushdata? ( tcb -- flag )
154	dup tcb-flags@ TF_PUSH and if ( tcb )
155	dup rcv-nxt@ swap >tcb-pushseq l@ seq>= ( flag )
156	else ( tcb )
157	drop false ( false )
158	then ( flag )
159	;
160
161	\ Check if the read request can be satisfied. Data in the receive
162	\ buffer can be read if we have enough data, or we are not expecting
163	\ any more data, or data is being pushed.
164
165	: tcp-cangetdata? ( tcb len -- cangetdata? )
166	over tcb-error@ 0= if ( tcb len )
167	over tcb>rcvbuf tcpbuf-count@ <= ( tcb flag )
168	over tcp-pushdata? or ( tcb flag' )
169	swap tcp-receive-done? or ( cangetdata? )
170	else ( tcb len )
171	2drop false ( false )
172	then ( cangetdata? )
173	;
174
175	\ Copy data from TCP receive buffer to an user buffer. If the window can
176	\ now be opened up at least 50% of the maximum window we ever advertised,
177	\ send a window update.
178
179	: tcp-getdata ( tcb adr len -- nread )
180	rot >r ( adr len ) ( r: tcb )
181
182	\ Read data from the receive buffer
183	r@ tcb>rcvbuf dup 2swap 0 -rot tcpbuf-read ( buf nread )
184	2dup tcpbuf-drop ( buf nread )
185
186	\ Clear PUSH state if all outstanding data has been
187	\ delivered to the application.
188	over tcpbuf-count@ 0= if ( buf nread )
189	r@ TF_PUSH tcb-clear-flags ( buf nread )
190	then ( buf nread )
191
192	\ Schedule a window update if one can be sent.
193	over tcpbuf-space@ r@ rcv-wnd@ - ( buf nread incr )
194	rot tcpbuf-size@ 2/ >= if ( nread )
195	r@ TF_ACKNOW tcb-set-flags ( nread )
196	then ( nread )
197
198	r> tcp-output ( nread ) ( r: )
199	;
200
201	\ Check if we can accept a send request.
202	: tcp-canputdata? ( tcb len -- flag )
203	over tcb-error@ 0= if ( tcb len )
204	swap tcb>sndbuf tcpbuf-space@ <= ( flag )
205	else ( tcb len )
206	2drop false ( false )
207	then ( flag )
208	;
209
210	\ Copy data from an user buffer to the end of the send buffer.
211	: tcp-putdata ( tcb adr len -- len' )
212	rot tcb>sndbuf dup >r ( adr len buf ) ( r: buf )
213	dup tcpbuf-count@ 2swap tcpbuf-write ( len' )
214	r> over tcpbuf-count+! ( len' ) ( r: )
215	;
216
217	\ Initiate a connection.
218	: tcp-open-connection ( tcb -- 0 \| error )
219	tcp-start-timers ( tcb )
220	dup tcp-sendseq-init ( tcb )
221	dup >tcbt-connect TCP_CONN_TIMEOUT set-timer ( tcb )
222	TCPS_SYN_SENT over tcb-state! ( tcb )
223	dup tcp-output ( tcb )
224	dup ['] tcp-connected? tcp-state-wait ( tcb )
225	dup >tcbt-connect clear-timer drop ( tcb )
226	tcb-error@ ( result )
227	;
228
229	\ Accept incoming connections.
230	: tcp-accept-connection ( tcb -- 0 \| error# )
231	tcp-start-timers ( tcb )
232	dup ['] tcp-connected? tcp-state-wait ( tcb )
233	tcb-error@ ( result )
234	;
235
236	\ Initiate a TCP disconnect.
237	: tcp-disconnect ( tcb -- )
238	dup tcb-state@ case
239	TCPS_SYN_RCVD of TCPS_FIN_WAIT_1 over tcb-state! endof
240	TCPS_ESTABLISHED of TCPS_FIN_WAIT_1 over tcb-state! endof
241	TCPS_CLOSE_WAIT of TCPS_LAST_ACK over tcb-state! endof
242	endcase
243	tcp-output
244	;
245
246	\ Close a connection.
247	: tcp-close-connection ( tcb -- )
248	tcp-drain-input ( tcb )
249	dup tcb-state@ TCPS_SYN_SENT <= if ( tcb )
250	TCPS_CLOSED swap tcb-state! ( )
251	else ( tcb )
252	dup tcb>rcvbuf tcpbuf-count@ 0<> if ( tcb )
253	TCPS_CLOSED over tcb-state! tcp-output ( )
254	tcp-drain-input ( )
255	else ( tcb )
256	dup tcp-disconnect ( tcb )
257	['] tcp-disconnected? tcp-state-wait ( )
258	then ( )
259	then ( )
260	;
261
262	fload ${BP}/pkg/netinet/tcp-debug.fth \ Post-mortem debugging routines
263
264	headers