9 Network Devices





Network devices are packet-oriented devices capable of sending and receiving packets addressed according to IEEE 802.2 (Ethernet). OpenBoot firmware typically uses network devices for diskless booting. The standard obp-tftp support package assists in the implementation of the load method for this device type.

This chapter describes how to implement network device drivers. First, the developer of a network driver needs to cooperate with the developers of OS driver to agree on the structure of the device tree, based on the functionalities of the drivers. Then they need to define all necessary properties used by OS or OpenBoot firmware.

Normally the network device driver could have a one level tree or a two level tree. While it is unlikely it will have more than two level tree, if necessary, the user can create more than a two level tree by applying new-device and finish-device.

A one level tree could have several nodes, depending on how many net channels the SBus card can support, each node corresponds to one net channel.

For a two level tree, it could have one "control" node on the top level, one or more nodes at the bottom level, depending on the number of net channels it supports. The simplest driver is to support has only one net channel and will only create one node, all properties and all methods being under this node.

This chapter shows three sample network device drivers for the Quad Ethernet device card. The structure of the device tree for the examples is as follows:

Each QED SBus card defines two levels:

    Figure 9-1 QED Device Tree

The general pathname (after sbus or sbi) for a qe node is

----------------------------
qec@S,20000/qe@C,0 ----------------------------

where S is the SBus slot number, C is the network channel number.

Required Methods

The network device FCode must declare the network device-type, and must implement the methods open and close, as well as the following methods:

load
( adr -- len )

Read the default stand-alone program into memory starting at adr using the default network booting protocol. len is the size in bytes of the program read in.

read
( adr len -- actual )

Receive a network packet, placing at most the first len bytes in memory at adr. Return the actual number of bytes received (not the number copied), or 0 if no packet is currently available. Packets with hardware-detected errors are discarded as though they were not received. Do not wait for a packet (non- blocking).

write
( adr len -- actual )

Transmit the network packet of size len bytes starting at memory address adr. Return the number of bytes actually transmitted. The packet must be complete with all addressing information, including source hardware address.

Required Device Properties

The required properties for a network device are

    Table 9-1 Required Network Device Properties

--------------------------------------------------------------------------
Name Typical Value --------------------------------------------------------------------------
             
name         "SUNW,my-net" {any name chosen by the manufacturer}
             
reg          list of registers {depends on the device}
             
device_type  "network"
             
mac-address  8 0 0x20 0x0c 0xea 0x41 {the currently using MAC address.}

--------------------------------------------------------------------------

Optional Device Properties

Several other properties may be declared for network devices:

    Table 9-2 Optional Network Device Properties

--------------------------------------------------------------------------------------
Property Name Typical Property Value --------------------------------------------------------------------------------------
                   
max-frame-size     0x4000
                   
address-bits       48
                   
slave-burst-sizes  0x7f {depends on the number of entries in the reg property}
                   
local-mac-address  8 0 0x20 0x0c 0xea 0x41 {the built-in Media Access Control addr.}

--------------------------------------------------------------------------------------

Device Driver Examples

If the network device is not to be bootable, it likely needs only one level tree. The examples below, however, show device drivers for two-level trees.

Simple Network Device Example

At minimum, a network device driver need only provide the desired tree structure and to publish all the necessary properties to identify the devices.

------------------------------------------------------------------------------
\ QED identification PROM
\ qed-idprom.fth
fcode-version1
   fload board.fth
   headers
   : copyright ( -- )
      ." Two-level QED-IDPROM 1.1 " cr
      ." Copyright 1992-1993 Sun Microsystems, Inc.  All Rights Reserved" cr
   ;
   : identify-qed  ( -- )
      create-qec-attributes
      4 0  do
         new-device
         i create-qe-attributes
         finish-device
      loop
   ;
   identify-qed
end0
\ -----------------------------------------------------------------
\ board.fth
\ To define required properties for QED devices.
   headers
   my-address   constant my-sbus-addr
   my-space     constant my-sbus-space
   headerless
\ Define the address map.
\ MED Address Map PA[18:0] (totally 512KB address space).
\  h# 00.0000   constant eprom-pa
\  h# 00.8000   constant /eprom                 \ 32KB used, 64KB total
   h# 01.0000   constant mace-regs-offset
   h# 01.0000   constant mace0-base
   h# 01.4000   constant mace1-base
   h# 01.8000   constant mace2-base
   h# 01.c000   constant mace3-base
   h# 00.4000   constant /mace-regs             \ 16KB per channel, 64KB total
   h# 02.0000   constant global-regs-offset
   h# 01.0000   constant /global-regs           \ 64KB total
   h# 03.0000   constant channel-regs-offset
   h# 03.0000   constant channel0-base
   h# 03.4000   constant channel1-base
   h# 03.8000   constant channel2-base
   h# 03.c000   constant channel3-base
   h# 00.4000   constant /channel-regs          \ 16KB per channel, 64KB total
   h# 04.0000   constant locmem-pa
   h# 01.0000   constant /locmem                \ 64KB used, 256KB total
\ Real size of mace/qec-global/qec-channel registers.
   20 constant /qec-mace-regs
   14 constant /qec-global-regs
   34 constant /qec-channel-regs
\ Miscellaneous constant definitions.
   1            constant #channels
   h# 4000      constant max-frame-size         ( d# 1536 for le )
   d# 48        constant address-bits
\ Hardwired SBus interrupt level for MED.
   4  constant sbus-qe-intr
   : xdrreg  ( addr space size -- adr len )  r xdrphys  r xdrint  xdr+  ;
   : xdrranges  ( offs bustype  phys offset size -- adr len )
      r r r  xdrphys  r r r xdrreg  xdr+
   ;
   : offsetphysical-addr  ( offset -- paddr.lo paddr.hi )
      my-sbus-addr + my-sbus-space
   ;
headers
   : create-qec-attributes  ( -- )
      " qec"      name
      " SUNW,595-3198" xdrstring " model" attribute     \ 595-3198-01
      global-regs-offset offsetphysical-addr /global-regs xdrreg
      locmem-pa  offsetphysical-addr /locmem xdrreg xdr+
      " reg" attribute
      0 0 channel0-base  offsetphysical-addr /channel-regs xdrranges
      0 1 channel1-base  offsetphysical-addr /channel-regs xdrranges xdr+
      0 2 channel2-base  offsetphysical-addr /channel-regs xdrranges xdr+
      0 3 channel3-base  offsetphysical-addr /channel-regs xdrranges xdr+
      0 h# 10 mace0-base offsetphysical-addr /mace-regs    xdrranges xdr+
      0 h# 11 mace1-base offsetphysical-addr /mace-regs    xdrranges xdr+
      0 h# 12 mace2-base offsetphysical-addr /mace-regs    xdrranges xdr+
      0 h# 13 mace3-base offsetphysical-addr /mace-regs    xdrranges xdr+
      " ranges" attribute
      #channels xdrint " #channels" attribute
    \ One interrupt per qec, not one interrupt per channel.
      sbus-qe-intr  xdrint  " interrupts"  attribute
      sbus-qe-intr 0 intr       \ Create intr property.
   ;
   : create-qe-attributes  ( chan# -- )
      r
      " qe" xdrstring  " name"   attribute
      r@ xdrint " channel#" attribute
      max-frame-size xdrint " max-frame-size" attribute
      address-bits xdrint " address-bits" attribute
      0 r@ /channel-regs xdrreg
        0 r@ h# 10 + /mace-regs xdrreg xdr+
        " reg" attribute
      r drop
   ;

------------------------------------------------------------------------------

Sample Driver With Test and Debugging Methods

This version of a network device driver is still non-bootable, but it shows how an intermediate step of driver can be used to debug and test the device during or after development.

The coding techniques shown in this and the following examples are:

-------------------------------------------------------------------------------
\ QED test PROM.
\ qed-test.fth
fcode-version2
   headers
   fload board.fth
   : copyright ( -- )
      ." QED-TEST 1.1 " cr
      ." Copyright 1992-1993 Sun Microsystems, Inc.  All Rights Reserved" cr
   ;
\
\ ***** The following is the FCode driver for version2 CPU PROMs. *****
\
   \ Tokenizer 2.1 or later has the word 'instance'
   : instance ( -- ) version 20001 =  if  instance  then  ;
\ Create qec device node.
   create-qec-attributes
   fload qec-test.fth   \ qec test code.
\ Create qe0 device node.
   new-device
      0 create-qe-attributes
      : dma-sync  ( virt-addr dev-addr size -- )  " dma-sync" $call-parent  ;
      \ ***** qe0 instance variables *****
      0 instance value mace   \ virtual address of Mace registers base
      0 instance value qecc   \ virtual address of Qec channel registers base
      instance variable my-channel# \ qe channel#
      my-channel# off
      fload qe-test.fth       \ qe test code.
      \ ***** qe0 external methods *****
      external
      : selftest  ( -- fail? )
         qe0-selftest
      ;
      : open  ( -- okay? )
         qe0-open
      ;
      : close  ( -- )
         qe0-close
      ;
      : reset  ( -- )
         qe0-reset
      ;
      headers
   finish-device
\ Create qe1 device node.
   new-device
      1 create-qe-attributes
      \ ***** qe1 instance variables *****
      0 instance value mace   \ virtual address of Mace registers base
      0 instance value qecc   \ virtual address of Qec channel registers base
      instance variable my-channel# \ qe channel#
      my-channel# off
      \ ***** qe1 external methods *****
      external
      : selftest  ( -- fail? )
         qe0-selftest
      ;
      : open  ( -- okay? )
         qe0-open
      ;
      : close  ( -- )
         qe0-close
      ;
      : reset  ( -- )
         qe0-reset
      ;
      headers
   finish-device
\ Create qe2 device node.
   new-device
      2 create-qe-attributes
      \ ***** qe2 instance variables *****
      0 instance value mace   \ virtual address of Mace registers base
      0 instance value qecc   \ virtual address of Qec channel registers base
      instance variable my-channel# \ qe channel#
      my-channel# off
      \ ***** qe2 external methods *****
      external
      : selftest  ( -- fail? )
         qe0-selftest
      ;
      : open  ( -- okay? )
         qe0-open
      ;
      : close  ( -- )
         qe0-close
      ;
      : reset  ( -- )
         qe0-reset
      ;
      headers
   finish-device
\ Create qe3 device node.
   new-device
      3 create-qe-attributes
      \ ***** qe3 instance variables *****
      0 instance value mace   \ virtual address of Mace registers base
      0 instance value qecc   \ virtual address of Qec channel registers base
      instance variable my-channel# \ qe channel#
      my-channel# off
      \ ***** qe3 external methods *****
      external
      : selftest  ( -- fail? )
         qe0-selftest
      ;
      : open  ( -- okay? )
         qe0-open
      ;
      : close  ( -- )
         qe0-close
      ;
      : reset  ( -- )
         qe0-reset
      ;
      headers
   finish-device
end0
\ ---------------------------------------------------------------------
\ qec-test.fth
\ Test code for the qec node.
/locmem #channels / value chmem
chmem 2/ value rxbufsize
\ ***** qed utility (from qed-util.fth) *****
: lwrt-rd-cmp ( mask data adr -- success? )
   2dup rl! rl@ rot and =
;
: cwrt-rd-cmp ( mask data adr -- success? )
   2dup rb! rb@ rot and =
;
instance defer wrt-rd-cmp
' lwrt-rd-cmp is wrt-rd-cmp
d# 32 instance value #bits
external
: wlk-test ( mask adr #bits -- success? )
   dup is #bits
   d# 32 =  if  ['] lwrt-rd-cmp  else  ['] cwrt-rd-cmp  then  is wrt-rd-cmp
   true -rot     ( true mask adr )
   #bits 0
   do      ( flag0 mask adr )
      over 1 i << and ?dup  if   ( flag0 mask adr data )
         r 2dup r swap wrt-rd-cmp false =     ( flag0 mask adr flag )
         if  rot drop false -rot leave  then
      then
   loop
   2drop
;
headers
instance variable ms-timeout
external
: set-ms-timeout  ( #ms -- ) ms-timeout !  ;
: ms-timeout?  ( -- flag )
   ms-timeout @ dup  if
      1- ms-timeout ! 1 ms false
   else
      drop true
   then
;
headers
\ ***** qec global register (from global.h.fth) *****
\
\ QEC Global register set.
\
\ Virtual addresses of QEC global registers.
\ The actual addresses will be assigned later.
0 instance value qecg
hex
\ global control register (RW)
: qecg-control  ( -- vaddr )  qecg  ;
: qecg-control@ ( -- data )  qecg-control rl@  ;
: qecg-control! ( data -- )  qecg-control rl!  ;
headerless
\ For Global Control Register.
f000.0000 constant gcr-mode     \ Mode mask
4000.0000 constant gcr-mace     \ Mace mode
1 constant gcr-reset    \ Reset bit (0), 1 to enable reset. 
headers
\ ***** qec map (from qecmap.fth ) *****
0 instance value locmem-base
false value dma-sync?
0 value dma-sync-adr
: find-dma-sync  ( -- )
   " dma-sync" my-parent ihandlephandle find-method  if
      true is dma-sync?
      is dma-sync-adr
   then
;
find-dma-sync
external
: decode-unit   ( adr len -- address space )  decode-2int  ;
: map-in ( offset slot# #bytes -- virtual ) " map-in" $call-parent  ;
: map-out  ( adr len -- )  " map-out" $call-parent  ;
: dma-map-in  ( vaddr n cache? -- devaddr ) " dma-map-in" $call-parent  ;
: dma-map-out  ( vaddr devaddr n -- )  " dma-map-out" $call-parent  ;
: dma-alloc ( size -- addr )  " dma-alloc" $call-parent  ;
: dma-free ( addr size -- )  " dma-free" $call-parent  ;
\ Dma-sync could be dummy routine if parent device doesn't support.
\ sun4c Proms may not support it.
: dma-sync  ( virt-adr dev-adr size -- )
   dma-sync?  if
      dma-sync-adr my-parent call-package
   else
      3drop
   then
;
headers
: map-qec-regs  ( -- )
   global-regs-offset my-sbus-addr + my-sbus-space /qec-global-regs
   " map-in" $call-parent is qecg
;
: unmap-qec-regs  ( -- )
   qecg /qec-global-regs " map-out" $call-parent
   0 is qecg
;
: map-locmem  ( -- )
   locmem-pa my-sbus-addr + my-sbus-space /locmem
   " map-in" $call-parent is locmem-base
;
: unmap-locmem  ( -- )
   locmem-base /locmem " map-out" $call-parent
   0 is locmem-base
;
\ ***** qec test (from qectest.fth) *****
hex
headerless
\ 18 constant /qec-global-regs
\ Define the mask bits that can be tested for each global register.
create gl-reg-masks
        0000.001e , 0000.0000 , 0000.0000 , 0001.e000 ,
        0000.f000 , 0000.f000 ,
\ Test Qec global registers.
: gl-reg-test  ( -- success? )
   true
   /qec-global-regs 0  do                       ( flag0 )
      gl-reg-masks i + @
      qecg i + d# 32 wlk-test                   ( flag0 flag )
      false =  if  drop false leave  then       ( flag0 )
   4  +loop
;
\ Perform register test for the qec node.
:  qec-reg-test ( -- success? )
   diagnostic-mode?  if
      ."  Qec register test -- "
   then
   gl-reg-test
   diagnostic-mode?  if
      dup  if  ." succeeded."  else  ." failed."  then  cr
   then
;
headers
\ ***** qec package *****
: reset-qec-global  ( -- fail? )
   gcr-reset qecg-control!           \ Issue global reset.
   d# 100 set-ms-timeout
   begin
      qecg-control@ gcr-reset and
   while
      ms-timeout?  if ." Global reset failed" cr true exit then
   repeat
   false
;
: identify-chip  ( -- okay? )
   qecg-control@ gcr-mode and gcr-mace =
;
external
: open  ( -- true )
   map-qec-regs
   identify-chip dup 0=  if
      unmap-qec-regs
   then
;
: close ( -- )
   qecg  if unmap-qec-regs then
;
: selftest ( -- fail? )
   qecg                 ( qecg )
   map-qec-regs
   qec-reg-test         ( qecg success? )
   unmap-qec-regs
   swap is qecg         ( success? )
   0=                   ( fail? )
;
: reset  ( -- )
   qecg
   map-qec-regs
   reset-qec-global drop
   unmap-qec-regs
   is qecg
;
headers
\ ---------------------------------------------------------------------
\ qe-test.fth
\ Test code for the qe node.
: wlk-test ( mask adr #bits -- success? )  " wlk-test" $call-parent  ;
: set-ms-timeout  ( #ms -- )  " set-ms-timeout" $call-parent  ;
: ms-timeout?  ( -- flag )  " ms-timeout?" $call-parent  ;
\ ***** qe map (from qemap.fth) *****
headers
\ instance variable my-channel# my-channel# off
: my-channel#!  ( channel# -- )  my-channel# !  ;
: my-chan#  ( -- channel# )
   my-channel# @
;
: mace-regs  ( -- devaddr space size )
   my-sbus-addr mace-regs-offset + /mace-regs my-chan# * +
   my-sbus-space /qec-mace-regs
;
: map-mace    ( -- )
   mace-regs " map-in" my-parent $call-method is mace
;
: unmap-mace  ( -- )
   mace /qec-mace-regs " map-out" my-parent $call-method
   0 is mace
;
: channel-regs  ( -- devaddr space size )
   my-sbus-addr channel-regs-offset + /channel-regs my-chan# * +
   my-sbus-space /qec-channel-regs
;
: map-channel    ( -- )
   channel-regs " map-in" my-parent $call-method is qecc
;
: unmap-channel  ( -- )
   qecc /qec-channel-regs " map-out" my-parent $call-method
   0 is qecc
;
: map-chips  ( -- )
   mace 0=  if          \  Do mapping if it is unmapped.
      map-mace
      map-channel
   then
;
: unmap-chips  ( -- )
   mace  if             \ Do unmapping if it is mapped.
      unmap-channel
      unmap-mace
   then
;
\ ***** qe test (from qeregtst.fth) *****
hex
\ Define the mask bits that can be tested for each register.
create ch-reg-masks
        0000.0004 , 0000.0000 , ffff.f800 , ffff.f800 ,
        0000.0001 , 0000.0001 , 001f.001f , 1fc0.3fc0 ,
        0000.fffe , 0000.fffe , 0000.fffe , 0000.fffe ,
        0000.00ff ,
create mace-reg-masks
        00 c, 00 c, 89 c, 00 c, 00 c, 0d c, 00 c, 00 c,
        00 c, 67 c, 00 c, 70 c, f3 c, ef c, 04 c, 5f c,
        00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
        00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c, 00 c,
\ Test Qec per channel registers.
: ch-reg-test  ( -- flag )
   true
   /qec-channel-regs 0 do                       ( flag0 )
      ch-reg-masks i + @
      qecc i + d# 32 wlk-test                   ( flag0 flag )
      false =  if  drop false leave  then       ( flag0 )
   4 +loop
;
\ Test Mace registers.
: mace-reg-test  ( -- flag )
   true
   /qec-mace-regs 0 do                          ( flag0 )
      mace-reg-masks i + c@
      mace i + 8 wlk-test                       ( flag0 flag )
      false =  if  drop false leave  then       ( flag0 )
   loop
;
\ Perform register test for the qe node.
:  qe-reg-test ( -- success? )
   diagnostic-mode?  if
      ."  Qe register test -- "
   then
   ch-reg-test
   mace-reg-test and
   diagnostic-mode?  if
      dup  if  ." succeeded."  else  ." failed."  then  cr
   then
;
\ ***** qe0 package *****
headerless
\ For MACE BIU Configuration Control (R11). (RW)
01 constant m-swrst             \ software reset
: mace-biucc  ( -- vaddr )  h# 0b mace +  ;
: mace-biucc@   ( -- data )  mace-biucc rb@  ;
: mace-biucc!   ( data -- )  mace-biucc rb!  ;
\ For QEC per channel control reg. (RW)
02 constant c-rst
: qecc-control  ( -- vaddr ) qecc  ;
: qecc-control@         ( -- data )  qecc-control rl@  ;
: qecc-control!         ( data -- )  qecc-control rl!  ;
headers
: set-my-channel#  ( -- )
\ If don't find the channel attribute, use 0.
   " channel#" get-my-attribute  if  0  else  xdrtoint nip nip  then
   my-channel#!
;
\ Reset (or stop) the qec channel.
\       Issue a soft reset to the desired Mace.
\       Then issue a soft reset to the desired channel in QEC.
\ Chip reset algorithm:
\       Set the reset bit then wait until the reset bit cleared.
\ Timeout in 0.1 sec if fail.
\
: channel-reset  ( -- fail? )
   m-swrst mace-biucc!          \ Issue Mace reset.
   d# 100 set-ms-timeout
   begin
      mace-biucc@ m-swrst and
   while
      ms-timeout? if ." Cannot reset Mace" cr true exit then
   repeat
   c-rst qecc-control!          \ Reset QEC channel registers.
   d# 100 set-ms-timeout
   begin
      qecc-control@ c-rst and
   while
      ms-timeout?  if  ." Cannot reset QEC channel" cr true exit  then
   repeat
   false
;
external
: qe0-selftest  ( -- flag )     \ Flag 0 if passes test.
   set-my-channel#
   map-chips
   qe-reg-test          ( success? )
   unmap-chips
   0=                   ( fail? )
;
: qe0-open  ( -- okay? )
   set-my-channel#
   mac-address drop 6 xdrstring  " mac-address" attribute
   true
;
: qe0-close  ( -- )
;
: qe0-reset  ( -- )
   set-my-channel#
   map-chips channel-reset drop unmap-chips
;
headers

-------------------------------------------------------------------------------

Bootable Network Device Driver Example

The example below shows a complete version of a bootable network driver. It implements the selftest method callable by OpenBoot test and test-all commands and the watch-net method callable by OpenBoot watch-net and watch-net-all commands.

-------------------------------------------------------------------------------------
\ QED bootable driver
\ qed.fth
fcode-version1
   headers
   fload board.fth
   : copyright ( -- )
      ." QED 1.1 " cr
      ." Copyright 1992-1993 Sun Microsystems, Inc.  All Rights Reserved" cr
   ;
\
\ ***** The following is the FCode driver for version2 CPU PROMs. *****
\
   \ Tokenizer 2.1 or later has the word 'instance'
   : instance ( -- ) version 20001 =  if  instance  then  ;
\ Create qec device node.
   create-qec-attributes
   fload qec.fth                \ qec driver.
\ Create qe0 device node.
   new-device
      0 create-qe-attributes
      " network" device-type
      fload qeinstance.fth      \ qe instance variables.
      : dma-sync  ( virt-addr dev-addr size -- )  " dma-sync" $call-parent  ;
      fload qe.fth              \ qe driver.
      fload qe-package.fth      \ qe external methods.
   finish-device
\ Create qe1 device node.
   new-device
      1 create-qe-attributes
      " network" device-type
      fload qeinstance.fth      \ qe instance variables.
      fload qe-package.fth      \ qe external methods.
   finish-device
\ Create qe2 device node.
   new-device
      2 create-qe-attributes
      " network" device-type
      fload qeinstance.fth      \ qe instance variables.
      fload qe-package.fth      \ qe external methods.
   finish-device
\ Create qe3 device node.
   new-device
      3 create-qe-attributes
      " network" device-type
      fload qeinstance.fth      \ qe instance variables.
      fload qe-package.fth      \ qe external methods.
   finish-device
end0
\ -----------------------------------------------------------------
\ qec.fth
/locmem #channels / value chmem
chmem 2/ value rxbufsize
fload qed-util.fth      \ Not included, refer to example 2.
fload global.h.fth      \ Not included.
fload qecmap.fth        \ Not included, refer to example 2.
fload qectest.fth       \ Not included, refer to example 2.
: reset-qec-global  ( -- fail? )
   gcr-reset qecg-control!      \ Issue global reset.
   d# 100 set-ms-timeout
   begin
      qecg-control@ gcr-reset and
   while
      ms-timeout?  if ." Global reset failed" cr true exit then
   repeat
   false
;
: qec-init  ( -- )
   chmem qecg-memsize!
   rxbufsize qecg-rxsize!
   chmem rxbufsize - qecg-txsize!
   gcr-burst16 qecg-control!    \ SBus parity disabled, Rx/Tx equal priority.
;
: identify-chip  ( -- okay? )
   qecg-control@ gcr-mode and gcr-mace =
;
external
: open  ( -- true )
   map-qec-regs
   identify-chip dup  if
      qec-init
   else unmap-qec-regs
   then
;
: close ( -- )
   qecg  if unmap-qec-regs then
;
: selftest ( -- fail? )
   qecg                 ( qecg )
   map-qec-regs
   qec-reg-test         ( qecg success? )
   unmap-qec-regs
   swap is qecg         ( success? )
   0=                   ( fail? )
;
: reset  ( -- )
   qecg
   map-qec-regs
   reset-qec-global drop
   unmap-qec-regs
   is qecg
;
headers
\ -----------------------------------------------------------------
\ qeinstance.fth
\ Define instance words for qe driver.
\ headerless
\ mace.h.fth:
0 instance value mace           \ virtual address of Mace registers base
\ channel.h.fth:
0 instance value qecc           \ virtual address of Qec channel registers base
\ qemap.fth:
instance variable my-channel#   \ qe channel#
        my-channel# off
\ qecore.fth:
\ CPU base address of tmd, rmd, tbuf, rbuf rings.
0 instance value cpu-dma-base   \ base address of dma memory object viewed by cpu
0 instance value tmd0           \ transmit message descriptor#0
0 instance value rmd0           \ receive message descriptor#0
0 instance value tbuf0          \ base address of transmit buffer
0 instance value rbuf0          \ base address of receive buffers
\ IO (or dvice) base address of tmd, rmd, tbuf, rbuf rings.
0 instance value io-dma-base    \ base addr of dma memory object viewed by device
0 instance value io-tmd0        \ transmit message descriptor#0
0 instance value io-rmd0        \ receive message descriptor#0
0 instance value io-tbuf0       \ base address of transmit buffer
0 instance value io-rbuf0       \ base address of receive buffers
\ Required total Dma buffer size for all rings.
0 instance value qe-dma-size    \ Amount of memory mapped
\ *** Define required variables ***
instance variable status        \ Accumulated channel status word.
instance variable restart?      \ Restart? flag on after serious error.
instance variable nextrmd       \ Point to next rmd.
instance variable nexttmd       \ tmd0 nexttmd !, never changes presently
instance variable mode          \ To store loopback control & promiscuous info.
6 instance buffer: this-en-addr \ Contain ethernet address
instance defer .receive-error
instance defer .error
instance defer .transmit-error
\ timed-receive.fth:
instance variable alarmtime
instance defer handle-broadcast-packet
\ qetest.fth:
instance variable qe-verbose?   \ Flag for displaying diagnostic message.
        qe-verbose? off
instance variable ext-lbt?      \ Flag for execution of external loopback test.
        ext-lbt? off
\ qe0-package.fth:
6 instance buffer: macbuf       \ Contain mac address.
0 instance value obp-tftp       \ Contain ihandle of TFTP package.
instance variable qe-nbytes     \ Buffer size of higher layer receiver.
instance variable qe-buf        \ Buffer address of higher layer receiver.
headers
\ -----------------------------------------------------------------
\ qe.fth
: wlk-test ( mask adr #bits -- success? )  " wlk-test" $call-parent  ;
: set-ms-timeout  ( #ms -- )  " set-ms-timeout" $call-parent  ;
: ms-timeout?  ( -- flag )  " ms-timeout?" $call-parent  ;
fload mace.h.fth        \ Not included.
fload channel.h.fth     \ Not included.
fload qemap.fth         \ Not included, refer to example 2.
fload qecore.fth
fload timed-receive.fth
fload qeregtest.fth     \ Not included, refer to example 2.
fload qetest.fth
fload qe0-package.fth
\ -----------------------------------------------------------------
\ qe0-package.fth
\ Define the required methods for the network qe driver
set-my-channel#
external
: read  ( buf len -- -2 | actual-len )
   qe0-read
;
: write  ( buf len -- actual-len )
   qe0-write
;
: selftest  ( -- flag ) \ Flag 0 if passes test.
   qe0-selftest
;
: watch-net  ( -- )
   qe0-watch-net
;
: load  ( adr -- len )
   qe0-load
;
: open  ( -- okay? )
   qe0-open
;
: close  ( -- )
   qe0-close
;
: reset  ( -- )
   qe0-reset
;
headers
\ -----------------------------------------------------------------
\ qecore.fth
\ Main core of QEC/MACE per channel Tx/Rx drivers.
\
\ SQEC has the following features:
\       - Supports four independent IEEE 802.3 10BASE-T twisted pair interfaces.
\       - Supports SBus parity checking.
\       - Supports 32 bit of DVMA addressing.
\       - Automatic rejection/discard of receive/transmit packets
\         when receive/transmit suffers from errors.
\
headerless
\ *** Rx/Tx Ring Descriptor Layout ***
struct ( Rx/Tx Descriptor )
4 field flags                  \ OWN, SOP, EOP, size/length
4 field addr                   \ buffer address
( total-length )  constant /md
hex
\ Definition for flag field.
\ Bit[10:0] - Rx for W is buffer size, Rx for R is byte count, Tx for W is byte count.
8000.0000       constant own    \ For both Rx & Tx.
4000.0000       constant stp    \ For Tx only.
2000.0000       constant enp    \ For Tx only.
     07ff       constant lenmask
\ Value to write to message descriptor to enable it for use
enp stp or own or       constant ready
\ *** buffer sizes and counts ***
\ Xmit/receive buffer structure.
\ This structure is organized to meet the following requirements:
\       - starts on an QEBURSTSIZE (64) boundary.
\       - qebuf is an even multiple of QEBURSTSIZE.
\       - qebuf is large enough to contain max frame (1518) plus
\               QEBURSTSIZE for alignment adjustments.
\
\ Similar to the 7990 ethernet controller, the QEC and the Software driver
\ communicate via ring descriptors. There are separate Rx & Tx descriptor
\ rings of 256 entries. Unlike 7990 the number of descriptor entries
\ is not programmable (fixed at 256 entries).
decimal
 /md constant /rmd      \ rmd size = 8
 /md constant /tmd      \ tmd size = 8
1792 constant /rbuf     \ 7*256 receive buffer size at least 1518+128=1636
1600 constant /tbuf     \ transmit buffer size
 256 constant #rmds
 256 constant #tmds
\  1 constant #tbufs    \ Just allocate one buffer for transmiter buffer pool.
  32 constant #rbufs    \ # buffers allocated for receiver buffer pool.
#rmds /rmd *       value /rmds
#tmds /tmd *       value /tmds
headers
: restart?-on  ( -- ) restart? on  ;
\ Conversion between cpu dma address and io dma address.
: cpuio-adr  ( cpu-adr -- io-adr )  cpu-dma-base - io-dma-base +  ;
: iocpu-adr  ( io-adr -- cpu-adr )  io-dma-base - cpu-dma-base +  ;
\ buffer# to address calculations
: rmd#rmdaddr  ( n -- addr )  /rmd * rmd0 +  ;
: rbuf#rbufaddr  ( n -- addr )  #rbufs mod /rbuf * io-rbuf0 +  ;
: tmd#tmdaddr  ( n -- addr )  /tmd * tmd0 +  ;
\ address to buffer# calculations
: rmdaddrrmd#  ( addr -- n )  rmd0 - /rmd /  ;
\ *** Qe message descriptor ring access ***
\ Get current rx/tx message descriptor ring pointer (on CPU side).
: nextrmd@  ( -- cpu-rmd-addr )  nextrmd @  ;
: nexttmd@  ( -- cpu-tmd-addr )  nexttmd @  ;
\ get location of buffer
: addr@  ( rmd/tmd-addr -- buff-addr )
   addr rl@
;
: status@  ( rmd/tmd-addr -- statusflag ) flags rl@  ;
\ gets length of incoming message, receive only
: length@  ( rmdaddr -- messagelength )  flags rl@ lenmask and  ;
\ Set current rx/tx message descriptor ring pointer (on CPU side).
: nextrmd!  ( cpu-rmd-addr -- )  nextrmd !  ;
: nexttmd!  ( cpu-tmd-addr -- )  nexttmd !  ;
\ Store buffer address into message descriptor
: addr!  ( buff-addr  rmd/tmd-addr -- )
   addr rl!
;
\ Set length of message to be sent - transmit only
: length!  ( length rmd/tmd-addr -- )  flags rl!  ;
\ *** Qe synchronization ***
\ Sync the message descriptor after cpu or device writes it.
: qesynciopb ( md -- )
   dup cpuio-adr /md           ( cpu-addr io-addr size )
   dma-sync
;
\ Sync the transmitting/received buffer after cpu/device writes it.
: qesyncbuf  ( md -- )
   dup addr@ dup iocpu-adr swap        ( md cpu-buf-addr io-buf-addr )
   rot length@                          ( cpu-buf-addr io-buf-addr size )
   dma-sync
;
\ The buffer was already put back, put the descriptor in the chip's ready list
: give-buffer  ( rmd/tmd-addr -- )
   dup flags dup rl@ ready or swap rl!         ( md )
  \ Sync the descriptor so the device sees it.
   qesynciopb                                   ( )
;
\ *** Qe error handling ***
: get-qe-status  ( -- channel-status )
   qecc-status@ status @ or dup status !
;
\ get receive errors, receive only
: rerrors@  ( -- errorsflag )  get-qe-status c-rerr-mask and ;
\ gets transmit errors, transmit only
: xerrors@  ( -- errorsflag ) get-qe-status c-terr-mask and ;
\ Clear transmit/receive/all error flags
: clear-terrors  ( -- ) status @ c-terr-mask not and status !  ;
: clear-rerrors  ( -- )  status @ c-rerr-mask not and status !  ;
: clear-errors  ( -- )  status off restart? off  ;
: clear-tint  ( -- ) status @ c-tint not and status !  ;
\ *** Basic initialization routines ***
\ words to set loopback control mode in UTR(R29) & promiscuous mode in MACCC(R13)
\ Bit<7 to control promiscuous mode, Bits<2:1 to control loopback mode,
\ Bit<0 to test the cable connection.
1 constant m-cable
: set-loop-mode  ( -- )  mode @ m-loop-mask and m-rpa or mace-utr!  ;
: set-prom-mode  ( -- ) mode @ m-prom and mace-maccc!  ;
: check-cable-mode?  ( -- flag )  mode @ m-cable =  ;
: external-loopback?  ( -- flag )  mode @ m-loop-mask and m-loop-ext =  ;
\ Check existence of no-tpe-test property to initialize disable-tpe-link-test bit.
\ Enable tpe-link-test if the property doesn't exist,
\       or disable tpe-link-test if the property exists.
: init-link-test  ( -- )
  \ Disable link test for external loopback mode.
   external-loopback?  if  m-dlnktst mace-phycc! exit  then
   " no-tpe-test" get-my-attribute  if  0
   else  2drop m-dlnktst  then
   mace-phycc!
;
\ Enable/disable tpe-link-test
: setup-link-test  ( enable-flag -- )
   " no-tpe-test" " get-attribute" eval  if
                \ Property doesn't exist, already enabled.
      0=  if  0 0 " no-tpe-test" attribute  then
   else  2drop                          \ Currently disabled.
      if  " no-tpe-test" delete-attribute  then
   then
;
\
\ After doing a port select of the twisted pair port, the
\ driver needs to give ample time for the MACE to start
\ sending pulses to the hub to mark the link state up.
\ Loop here and check of the link state has gone into a
\ pass state.
\
: link-state-fail?  ( -- fail? )
   d# 1000 set-ms-timeout
   begin
      mace-phycc@ m-lnkst and
   while
      ms-timeout?  if
         check-cable-mode?  if
            ."  failed, transceiver cable problem? or check the hub." cr
            true
         else
\           m-dlnktst mace-phycc!
            false
         then
         exit
      then
   repeat
   check-cable-mode?  if  ." passed."  cr  then
   false
;
: set-physical-address  ( -- )
   m-addrchg mace-iac!
   begin  mace-iac@ m-addrchg and 0=  until
   m-phyaddr mace-iac!
  \ Store least significant byte first.
   this-en-addr 6 bounds  do  i c@ mace-padr!  loop
   0 mace-iac!
;
: set-address  ( en-addr len -- )
  drop  this-en-addr 6 cmove  ;
: set-logaddr-filter  ( -- )
   m-addrchg mace-iac!
   begin  mace-iac@ m-addrchg and 0=  until
   m-logaddr mace-iac!
   8 0  do  0 mace-ladrf!  loop
   0 mace-iac!
;
\ Reset (or stop) the qec channel.
\       Issue a soft reset to the desired Mace.
\       Then issue a soft reset to the desired channel in QEC.
\ Chip reset algorithm:
\       Set the reset bit then wait until the reset bit cleared.
\ Timeout in 0.1 sec if fail.
\
: channel-reset  ( -- fail? )
   m-swrst mace-biucc!          \ Issue Mace reset.
   d# 100 set-ms-timeout
   begin
      mace-biucc@ m-swrst and
   while
      ms-timeout? if ." Cannot reset Mace" cr true exit then
   repeat
   c-rst qecc-control!          \ Reset QEC channel registers.
   d# 100 set-ms-timeout
   begin
      qecc-control@ c-rst and
   while
      ms-timeout?  if  ." Cannot reset QEC channel" cr true exit  then
   repeat
   false
;
\ Initialize a single message descriptor
: rmd-init  ( rbufaddr rmdaddr -- )
   /rbuf over length!             \ Buffer length
   addr!                          \ Buffer address
;
\ Set up the data structures necessary to receive a packet
: init-rxring  ( -- )
   rmd0 nextrmd!
   #rmds 0  do   i rbuf#rbufaddr  i rmd#rmdaddr  rmd-init  loop
;
\
\ Initially first N=#rbufs descriptors with one-to-one association with a
\ buffer are made ready, the rest (256-N) not ready, then turn on receiver.
\ Whenver a receive buffer is processed, the information is copied out,
\ the buffer will be linked to the ((current+N)%256) entry then make the
\ entry is ready. Ie. The window of N ready descriptor/buffer pair is
\ moving around the ring.
\
: enable-rxring  ( -- )
   #rbufs 0  do  i rmd#rmdaddr give-buffer  loop
;
\ transmit buffer initialize routine
: init-txring ( -- )
   tmd0 nexttmd!
   #tmds 0  do io-tbuf0 i tmd#tmdaddr addr!  loop
;
\ *** Receive packet routines ***
\ Utility words used in .rerr-text & .terr-text.
: bits  ( mask #right-bits -- mask' right-bits )
   r dup d# 32 r@ - tuck << swap >    ( mask bits ; RS: #bits )
   swap r > swap                      ( mask' bits )
;
: 1bit  ( mask -- mask' rightest-bit-value )
   1 bits
;
: .rerr-text  ( -- )
   rerrors@
   1bit  if  ." SBus Rx Error Ack  " restart?-on  then
   1bit  if  ." SBus Rx Parity  " restart?-on  then
   1bit  if  ." SBus Rx Late  " restart?-on  then
   1bit  if  ." Data Buffer Too Small  "  then
\  1bit  if  ." Rx packet Dropped  "  then
   1bit drop                            \ Skip drop error, happens all the time
   1bit drop                            \ Skip receive interrupt bit.
   1bit  if  ." CRC error  "  then
   1bit  if  ." Framing error  "  then
   1bit  if  ." MACE Rx Late Collision  "  then
   1bit  if  ." MACE FIFO overflow "  then
   1bit  if  ." MACE Missed Counter Overflow  "  then
   1bit  if  ." MACE Runt Counter Overflow  "  then
   1bit  if  ." MACE Rx Coll Counter Overflow  "  then
   1bit  if  ." Collision error " then
   drop cr
;
: (.receive-error  ( -- )
   rerrors@  if  .rerr-text  then
;
' (.receive-error is .receive-error
' (.receive-error is .error
: to-next-rmd  ( -- )
   /rmd nextrmd +!
   nextrmd@ rmd0 - /rmds =  if  rmd0 nextrmd!  then
;
\  *** Transmit packet routines ***
: to-next-tmd  ( -- )
   /tmd nexttmd +!
   nexttmd@ tmd0 - /tmds =  if  tmd0 nexttmd!  then
;
\ Ignores the size argument, and uses the standard buffer.
: get-buffer  ( dummysize -- buffer )
   drop  nexttmd@ addr@         ( io-tbuf )
   iocpu-adr                           ( cpu-tbuf )
;
\ Display time domain reflectometry information
\ : .tdr  ( -- )  ;
: .terr-text  ( -- )
   xerrors@
   d# 16 bits drop                      \ Skip the receiver bits.
   1bit  if  ." SBus Tx Error Ack  " restart?-on  then
   1bit  if  ." SBus Tx Parity  " restart?-on  then
   1bit  if  ." SBus Tx Late  " restart?-on  then
   1bit  if  ." QEC Chained Tx Descriptor Error  " restart?-on  then
   1bit  if  ." QEC Tx Retry Counter Overflow  "  then
   1bit drop                            \ Skip transmit interrupt bit
   1bit  if  ." MACE 1518 Babble  "  then
   1bit  if  ." MACE Jabber  "  then
   1bit  if  ." MACE FIFO Underflow  "  then
   1bit  if  ." Tx Late Collision  "  then
   1bit  if  ." Too Many Retries  "  then
   1bit  if  ." Lost Carrier  (transceiver cable problem?)  "  then
   1bit  if  ." Excessive Defer  "  then
   drop cr
;
\ print summary of any HARD errors
: (.transmit-error  ( -- )
   xerrors@  if  .terr-text  then
;
' (.transmit-error is .transmit-error
\ Set up CPU page maps
: map-qe-buffers  ( -- )
   #rbufs /rbuf *
\ 2KB (8*256) for tmds & 2KB (8*256) for rmds & 4KB for tbuf
\ ie. one page for tmds & rmds, one page for tbuf, the rest for rbufs.
   h# 2000 +
   is qe-dma-size
   \ Allocate and map that space
   qe-dma-size dma-alloc                ( dma-adr )
   \ Set the addresses of the various DMA regions used by the cpu.
   dup  is cpu-dma-base
   dup  is tmd0    h# 800 +  ( next-address )
   dup  is rmd0    h# 800 +  ( next-address ) \ Enough for 256 entries
   dup  is tbuf0   h# 1000 + ( next-address ) \ Enough for max packet
        is rbuf0             ( )
   tmd0 qe-dma-size false dma-map-in    ( io-dma-adr )
   \ Set the addresses of the various DMA regions used by the qec chip.
   dup  is io-dma-base
   dup  is io-tmd0    h# 800 +  ( next-address )
   dup  is io-rmd0    h# 800 +  ( next-address ) \ Enough for 256 entries
   dup  is io-tbuf0   h# 1000 + ( next-address ) \ Enough for max packet
        is io-rbuf0             ( )
;
: unmap-qe-buffers  ( -- )
   tmd0 io-tmd0 qe-dma-size dma-map-out
   tmd0 qe-dma-size dma-free
   0 is tmd0
;
\ *** Chips initialization routines ***
\ Initializes the QEC/Mace chips.
: channel-init ( -- fail? )
  \ *** Initialize QEC per channel registers.
   io-rmd0 qecc-rxring!
   io-tmd0 qecc-txring!
   c-rintmask qecc-rintmask!            \ Mask RINT.
   c-tintmask qecc-tintmask!            \ Mask XINT.
   my-chan# chmem * dup qecc-lmrxwrite! dup qecc-lmrxread!
   rxbufsize + dup qecc-lmtxwrite! qecc-lmtxread!
   c-qecerrmask qecc-qecerrmask!
   c-macerrmask qecc-macerrmask!
  \ *** Initialize MACE registers.
\  0 mace-xmtfc!
   m-apadxmt mace-xmtfc!        \ Set auto pad transmit for transmit frame control
   0 mace-rcvfc!                \ Init. receive frame control.
  \ Init. Interrupt Mask Register to mask rcvint & cerr and unmask xmtint
  \     according QEC spec.
   m-cerrm m-rcvintm or mace-imr!
  \ Init. Bus Interface Unit Configuration Control to transmit after 64 bytes
  \     have been loaded & byte swap.
   m-xmtsp64 m-xmtspshift << m-bswp or mace-biucc!
  \ Init. FIFO Conf Control to set transmit/receive fifo watermark update
   m-xmtfw16 m-rcvfw32 or m-xmtfwu or m-rcvfwu or mace-fifocc!
   m-10base-t mace-plscc!       \ Select twisted pair mode.
   init-link-test               \ Init. tpe link test mode.
   set-physical-address         \ Set mac address.
   set-logaddr-filter           \ Set logical address filter.
   0 mace-iac!
   link-state-fail?             \ Wait and check the link state marked up.
   mace-mpc@ drop       \ Read to reset counter and to prevent an invalid int.
   set-loop-mode        \ Set UTR
   set-prom-mode        \ Set MACCC
   m-apadxmt not mace-xmtfc@ and mace-xmtfc!
   m-astrprcv not mace-rcvfc@ and mace-rcvfc!
;
\ Turn on the Mace, ready to tx/rx packets.
: enable-mace  ( -- )
   m-enxmt m-enrcv or mace-maccc@ or mace-maccc!
;
\ *** Ethernet on/off routines ***
\ Initializes the QEC/Mace chips, allocating the necessary memory,
\ and enabling the transmitter and receiver.
: net-on  ( -- flag )           \ true if net-on succeeds
   clear-errors
   mac-address set-address
   channel-reset 0=  if
      init-txring
      init-rxring
      channel-init 0= dup  if
         enable-rxring
         enable-mace
      then
   else  false
   then
;
\ Stop the activity of this net channel.
: net-off  ( -- )  channel-reset drop init-link-test  ;
\ *** Main receive routines ***
\
\ Whenver a receive buffer is processed, the information is copied out,
\ the buffer will be linked to the ((current+N)%256)th entry then make the
\ entry is ready. Ie. The window of N ready descriptor/buffer pair is
\ moving around the ring.
\
\ If 256 (#rmds) is multiples of N (#rbufs=32), we don't need to link the
\ next-ready-rmd with the current processed rx buffer dynamically. They can
\ be set at the initialization time statically. For run time, we just need
\ to make the ((current+N)%256)th rmd ready.
\
: return-buffer ( buf-handle -- )
   rmdaddrrmd#                         ( [io-rbuf] rmd# )
   #rbufs + #rmds mod                   ( [io-rbuf] next-ready-rmd# )
   rmd#rmdaddr                         ( [io-rbuf] next-ready-rmd )
   dup addr@ over rmd-init              ( next-ready-rmd ; Set length )
   give-buffer                          ( ; Make it ready )
   to-next-rmd                          \ Bump SW nextrmd to next one
;
: receive-ready? ( -- packet-waiting? )
   restart? @  if  net-on drop  then
   nextrmd@                                     ( rmd )
  \ Sync RMD before CPU looking at it.
   dup qesynciopb                               ( rmd )
   status@ own and 0=                           ( flag )
;
: receive  ( -- buf-handle buffer len )         \ len non-zero if packet ok
   nextrmd@ dup addr@                   ( rmd io-rbuf-addr )
   iocpu-adr                           ( rmd cpu-rbuf-addr )
   over length@                         ( rmd cpu-rbuf-addr len )
   rerrors@  if
      .receive-error clear-rerrors
   then
   dup  if                              ( rmd cpu-rbuf-addr len )
  \ Sync the received buffer before CPU looking at it.
      nextrmd@ qesyncbuf                ( rmd cpu-rbuf-addr len )
   then
;
\ *** Main transmit routines ***
: set-timeout  ( interval -- )  get-msecs  +  alarmtime !  ;
: timeout?  ( -- flag )  get-msecs  alarmtime @ =  ;
: 10us-wait  ( -- )  d# 10 begin 1- dup 0= until drop  ;
 
\ Wait until transmission completed
: send-wait  ( -- )
\ Wait the packet to get to the local memory, ready for MACE to xmit.
   d# 2000 set-timeout          \ 2 second timeout.
   begin 
      get-qe-status
      c-tint and                \ Transmit interrupt bit set?
      timeout? or               \ Or timeout?
   until
   timeout?  if
      ." TINT was not set!" cr true exit
   then
  \ Transmit completion, sync TMD before looking at it.
   nexttmd@ dup qesynciopb      ( tmd )
   status@ own and  if          ( flag )
      ." Tx descriptor still owned by QEC!" cr
   then
\ Wait the packet to get to net, make sure at most one xmit packet in MACE FIFO.
   d# 1000 set-timeout          \ 1 second timeout.
   begin
      10us-wait
      qecc-lmtxwrite@ qecc-lmtxread@ =
      timeout? or
   until
   timeout?  if
      ." Tx packet not out to net!" cr
   then
   false
;
\ This send routine does not enforce the minimum packet length.  It is
\ used by the loopback test routines.
:  short-send  ( buffer length -- error? )
   clear-tint                   \ Erase tint status bit.
  \ discard buffer address, assumes using nexttmd
   nip nexttmd@                 ( length tmd )
   tuck length!                 ( tmd ; Set length )
  \ Sync the transmit buffer so the device sees it.
   dup qesyncbuf                ( tmd )
   give-buffer                  ( ; Give tmd to chip )
   c-tdmd qecc-control!         \ Bang the chip, let chip look at it right away
   send-wait                    ( fail? )       \ wait for completion
   xerrors@ dup  if             ( fail? error? )
      .transmit-error clear-terrors
   then  or                     ( error? )
   to-next-tmd                  ( error? )
   restart? @  if  net-on drop  then    ( error? )
   c-hard-terr-mask and         ( hard-error? )
;
\ Transmit packet routine, no S/W retry on this layer.
: net-send  ( buffer length -- error? )  \ error? is contents of chan-status
   d# 64 max                    \ force minimum length to be 64
   short-send                   ( error? )
;
\ -----------------------------------------------------------------
\ timed-receive.fth
\ Implements a network receive that will timeout after a certain interval.
decimal
 
: multicast? ( handle data-address length -- handle data-address length flag )
   \ Check for multicast/broadcast packets
   over                        ( ... data-address )
   c@ h# 80 and dup  if        \ Look at the multicast bit
       ( handle data-address length multicast? )
       handle-broadcast-packet
   then
;
: receive-good-packet  ( -- [ buffer-handle data-address length ]  | 0 )
   begin
      begin
         timeout?  if  false exit  then
         receive-ready?
      until
      receive dup 0=
   while
      .error  2drop return-buffer
   repeat
;
: receive-unicast-packet  ( -- [ buffer-handle data-address length ] | 0 )
   begin
      receive-good-packet  dup 0=  if  exit  then
      multicast?
   while
      2drop return-buffer
   repeat
;
\ Receive a packet, filtering out broadcast packets and timing
\ out if no packet comes in within a certain time.
: timed-receive ( timeout-msecs -- [ buffer-handle data-address length ] err?)
   set-timeout  receive-unicast-packet ?dup 0=
;
\ -----------------------------------------------------------------
\ qetest.fth
\ Define Qec/Mace loopback-test, net-init & watch-test routines.
\ This file contains Qec/Mace selftest routines.
\ It defines the following external words:
\       loopback-test  ( internal/external-flag -- success? )
\       net-init  ( -- success? )
\       watch-test ( -- )
\ Also it defines the following external variable.
\       qe-verbose?     - Flag to indicate if want the test messages displayed.
\       ext-lbt?        - Flag to indicate if run the external loopback test.
\
\ The algorithme for the loopback test:
\       Set internal or external loopback with no promiscuous mode.
\       Turn on the Qec/Mace Ethernet port.
\       If it succeeds, send out a short packet containing walking 0/1 patterns.
\       If it succeeds, wait for a period, check if receive the loopback packet.
\       If so, verify the length of the received packet is right.
\       Also check if the data of the received packet is right.
\       Return true if everything is fine, otherwise return false.
\
hex
headerless
create loopback-prototype
   ff c, 00 c,                                      \ Ones and zeroes
   01 c, 02 c, 04 c, 08 c, 10 c, 20 c, 40 c, 80 c,  \ Walking ones
   fe c, fd c, fb c, f7 c, ef c, 0df c, 0bf c, 7f c,  \ Walking zeroes
   55 c, aa c,
: loopback-buffer  ( -- adr len )
   d# 32 get-buffer  ( adr )
   mac-address drop    over              6 cmove   \ Set source address
   mac-address drop    over 6 +          6 cmove   \ Set destination address
   loopback-prototype  over d# 12 +  d# 20 cmove   \ Set buffer contents
   d# 32
;
: pdump  ( adr -- )
   base @ r  hex
   dup      d# 10  bounds  do  i c@  3 u.r  loop  cr
   d# 10 +  d# 10  bounds  do  i c@  3 u.r  loop  cr
   r base !
;
\ Print loopback control type for verbose mode.
: .loopback  ( -- )
   mode @  m-loop-mask and
   ?dup  if
      dup m-loop-ext =  if  ." External " drop
      else  ." Internal " m-loop-intmen =  if  ." (including Mendec) "  then
      then
      ." loopback test -- "
   then
;
\ Print loopback control type for non-verbose mode,
\ it is used after any error occurs.
: ?.loopback  ( -- )
   qe-verbose? @  0=  if  .loopback  then  ;
: switch-off  ( -- false )
   qe-verbose? off  false
;
: bad-rx-data  ( buf-handle data-address -- false )
   ?.loopback
   ." Received packet contained incorrect data.  Expected: " cr
   loopback-prototype pdump
   ." Observed:" cr
   d# 12 + pdump
   switch-off
;
 
\ Check the data of the received packet, return true if data is ok.
: check-data  ( buf-handle data-address length -- ok? )
   drop  ( buf-handle data-address )
   dup d# 12 +  loopback-prototype  d# 20 comp
   if  bad-rx-data
   else  drop   ( buf-handle )
     return-buffer
     qe-verbose? @  if  ." succeeded." cr  then
     mode off   true
   then
;
\ Check the length & data of the received packet, return true if data & len ok.
: check-len&data  ( buf-handle data-address length -- ok? )
   \ The CRC is appended to the packet, thus it is 4 bytes longer than
   \ the packet we sent.
   dup d# 36 <'>
   if  ?.loopback
     ." Wrong packet length; expected 36, observed " .d cr
     switch-off
   else  check-data
   then
;
headers
\ Run internal or external loopback test, return true if the test passes.
: loopback-test  ( internal/external -- pass? )
   mode !
   qe-verbose? @  if  ."  " .loopback  then
   net-on  if
      loopback-buffer short-send  if
         ?.loopback  ." send failed." cr
         switch-off
      else
         d# 2000 timed-receive  if
            ?.loopback
            ." Did not receive expected loopback packet." cr
            switch-off
         else         (  buf-handle data-address length )
            check-len&data
         then
      then
   else
      switch-off
   then
   net-off  mode off
;
\ If there is a normal external loopback test, then we don't need this.
\ MACE external loopback test requires a special cable. Don't run external
\ loopback test for selftest & watch-net.
: check-cable?  ( -- ok? )
   m-cable mode !
   ."  Link state check -- "
   net-on               ( success? )
   net-off mode off
;
\ Turn on the Ethernet port after pass loopback test.
\ Return true if net-init succeeds, otherwise return false if it fails.
: net-init  ( -- flag )
   mode @               \ Save requested mode because loopback changes it.
   m-loop-int loopback-test
   if                   ( mode-saved ; Pass internal loopback test. )
      ext-lbt? @        \ Run external loopback test if the ext-lbt? flag is set.
   \ qe internal loopback with mendec is equivalent to external loopback of le.
      if  m-loop-intmen loopback-test  else  true  then ( mode-saved )
      swap mode !       \ Restore the mode.
      if  net-on        \ Pass loopback test, turn on the ethernet port.
      else  false
      then
   else  mode ! false
   then
;
headerless
: wait-for-packet  ( -- )
   begin  key?  receive-ready?  or  until
;
headers
\ Check for incoming Ethernet packets.
\ Use promiscuous mode to check for all incoming packets.
: watch-test  ( -- )
   ." Looking for Ethernet packets." cr
   ." '.' is a good packet.  'X' is a bad packet."  cr
   ." Type any key to stop."  cr
   begin
      wait-for-packet
      receive-ready?
      if  receive
        if   ." ."  else  ." X"  then
          drop  return-buffer
      then
      key? dup  if  key drop  then
   until
;
\ -----------------------------------------------------------------
\ qe0-package.fth
\ Implement the architectural interface for the qe driver
headerless
\
\ The network driver uses the standard "obp-tftp" support package for
\ implementation. The "obp-ftfp" package implements the Internet Trivial File
\ Transfer Protocol (TFTP) for use in network booting. The "obp-tftp" package
\ defines the following methods to be used by the network driver:
\       open    ( -- okay? )
\       close   ( -- )
\       load    ( addr -- size )
\ The "obp-tftp" package uses the read and write methods of the network driver
\ for receiving and transmitting packets. The package assums the size of the
\ maximum transfer packet is 1518 bytes. If the network driver needs bigger
\ maximum packet size, then it requires the method "max-transfer" defined,
\ the method will be called by the obp-tftp package to define the maximum
\ transfer packet size.
\
: init-obp-tftp  ( -- okay? )
   " obp-tftp" find-package  if         ( phandle )
      my-args rot open-package          ( ihandle )
   else  0
   then
   dup is obp-tftp                      ( ihandle | 0 )
   dup 0=  if
      ." Can't open OBP standard TFTP package"  cr
   then
;
: set-my-channel#  ( -- )
\ If don't find the channel attribute, use 0.
   " channel#" get-my-attribute  if  0  else  xdrtoint nip nip  then
   my-channel#!
;
headers
: qe-xmit  ( bufaddr nbytes -- #sent )
   tuck get-buffer                      ( nbytes bufaddr ether-buffer )
   tuck  3 pick  cmove                  ( nbytes ether-buffer )
   over net-send  if  drop 0  then      ( #sent )
;
: qe-poll  ( bufaddr nbytes -- #received )
   qe-nbytes ! qe-buf !                 ( )
   receive-ready?  0=  if  0 exit  then    \ Bail out if no packet ready
   receive ?dup  if                     ( rmd ether-buffer length )
      dup r                            ( rmd ether-buffer length )
      qe-nbytes @ min                   ( rmd ether-buffer length' )
      qe-buf @ swap cmove               ( rmd )
      return-buffer  r                 ( #received )
   else
      drop return-buffer 0              ( 0 )
   then
;
: set-vectors  ( -- )
   ['] (.receive-error  is .error
   ['] (.transmit-error is .transmit-error
   ['] noop is handle-broadcast-packet
;
: map-qe  ( -- )
   mace 0=  if          \ Do mapping if it is unmapped.
      map-chips
      map-qe-buffers
   then
;
: unmap-qe  ( -- )
   mace  if             \ Do unmapping if it is mapped.
      unmap-qe-buffers
      unmap-chips
   then
;
: qe-loopback-test  ( -- flag )         \ flag true if passes test
   set-vectors
   mode off  qe-verbose? on
   ext-lbt? on
   net-init
   ext-lbt? off
   dup  if  net-off drop check-cable?  then
   qe-verbose? off
;
: (watch-net) ( -- )
   map-qe
   set-vectors
   m-prom mode !
   qe-verbose? off
   ext-lbt? off
   net-init  if  watch-test net-off  then
   unmap-qe
;
external
: qe0-read  ( buf len -- -2 | actual-len )
   qe-poll  ?dup  0=  if  -2  then
;
: qe0-write  ( buf len -- actual-len )  qe-xmit  ;
: qe0-selftest  ( -- flag )     \ Flag 0 if passes test.
   map-qe
   qe-reg-test       ( success? )
   if
      qe-loopback-test 0=       \ Alternate the return flag.
   else
      true
   then           ( failure? )
   unmap-qe
;
: qe0-watch-net  ( -- )
   qe0-selftest 0=  if  (watch-net)  then
;
: qe0-load  ( adr -- len ) " load" obp-tftp $call-method  ;
: qe0-open  ( -- okay? )
   map-qe
   set-vectors
   mode off  qe-verbose? off
   net-init 0=  if  unmap-qe false exit  then
   mac-address drop macbuf 6 cmove      \ Update macbuf.
   macbuf 6 xdrstring  " mac-address" attribute
   init-obp-tftp 0=  if  close false exit  then
   true
;
: qe0-close  ( -- )
   obp-tftp ?dup  if  close-package  then
   mace  if  net-off  then
   unmap-qe
;
: qe0-reset  ( -- )
   mace  if  net-off
   else  map-chips net-off unmap-chips  then
;
headers

-------------------------------------------------------------------------------------