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