| 
 \ This driver supports "block" and "byte" type bootable devices, by using standard
 \ "deblocker"and "disk-label" packages.
 fcode-version3
    hex
    headers
   
    : copyright  ( -- )  
       ." Copyright 1992 - 1995 Sun Microsystems.  All Rights Reserved" cr 
    ;
    h# 20.0000    constant scsi-offset
    h# 40         constant /scsi
    d# 25.000.000 constant clock-frequency 
  
    : identify-me ( -- )
       " SUNW,my-scsi" encode-string " name" property 
       " scsi" device-type
       my-address scsi-offset + my-space /scsi reg
  
    ;
    identify-me 
  
    h# 10.0000 constant dma-offset
    h# 10      constant /dma
    -1 instance value dma-chip
  
    external
    : decode-unit  ( addr len -- low high )          decode-2int  ;
    : dma-alloc    ( size -- vaddr )                 " dma-alloc" $call-parent  ;
    : dma-free     ( vaddr size -- )                 " dma-free" $call-parent  ;
    : dma-map-in   ( vaddr size cache? -- devaddr )  " dma-map-in" $call-parent  ;
    : dma-map-out  ( vaddr devaddr size -- )         " dma-map-out" $call-parent  ;
    
    \ Dma-sync could be dummy routine if parent device doesn't support.
    : dma-sync  ( virt-addr dev-addr size -- )
       " dma-sync" my-parent ['] $call-method catch  if
          2drop 2drop 2drop
       then                      
    ;
    
    : map-in   ( addr space size -- virt )  " map-in"  $call-parent  ;
    : map-out  ( virt size -- )             " map-out" $call-parent  ;
    
    headers
    \ variables/values for sending commands, mapping etc.
    -1 instance value scsi-init-id
    -1 instance value scsi-chip
    -1 instance value mbuf
    -1 instance value mbuf-dma
    h# 20 constant /mbuf
    ...
  
  
  
  
    \ mapping and allocation routines for scsi
    : map-scsi-chip  ( -- )
       my-address scsi-offset +  my-space /scsi map-in  to scsi-chip
    ;
  
    : unmap-scsi-chip  ( -- )  scsi-chip /scsi map-out  -1 to scsi-chip  ;
       
    : map-scsi  ( -- )
       map-scsi-chip
       \ allocate buffers etc. for "sense" command and status
       ... 
    ;
    
    : unmap-scsi  ( -- )
       \ free buffers etc. for "sense" command and status
       ... 
       unmap-scsi-chip
    ;
    
    \ words related to scsi commands and register access. 
    ...
  
  
    : reset-my-scsi ( -- error? )   ...  ; 
    : reset-bus ( -- error? )   ...  ; 
    
    : init-n-test  ( -- ok? ) ...  ;
    : get-buffers ( -- )  ...  ; 
    : give-buffers ( -- )  ...  ; 
    : scsi-selftest ( -- fail? )  ...  ;
    
    d# 512 constant ublock
    0 instance value /block
    0 instance value /tapeblock
    instance variable fixed-len?
    ...
    
    external
    : set-timeout  ( n -- ) ...  ;
    : send-diagnostic ( -- error? )
         \ run diagnostics and return any error.
         ...
    ;
    
    : device-present?  ( lun target -- present? ) ...  ;
    : mode-sense  ( -- true | block-size false ) ...  ;
    : read-capacity  ( -- true | block-size false ) ...  ;
     
    \ Spin up a SCSI disk, coping with a possible wedged SCSI bus
    : timed-spin  ( target lun -- ) ...  ;
    
    : disk-r/w-blocks ( addr block# #blocks direction? -- #xfered )
       ...                 ( #xfered )
    ;     
     
  
    \ Execute "mode-sense" command.  If failed, execute read-capacity command.
    \ If this also failed, return d# 512 as the block size.
    : disk-block-size  ( -- n )
        mode-sense  if  read-capacity  if  d# 512  then  then
        dup to /block
    ;
     
    : tape-block-size ( -- n ) ...  ;
    : fixed-or-variable  ( -- max-block fixed? )  ...  ; 
    : tape-r/w-some  ( addr block# #blks read? -- actual# error? ) ...  ;
    
    headers
  
    : dma-open  ( -- )  my-address dma-offset +  my-space /dma map-in  to dma-chip  ;
       
    : dma-close  ( -- )  dma-chip /dma map-out  -1 to dma-chip  ;
  
    \ After any changes to mbuf by cpu or any changes to mbuf-dma by device, synchronize
    \ changes by issuing " mbuf mbuf-dma /mbuf dma-sync "
    : mbuf-alloc ( -- )
       /mbuf dma-alloc to mbuf
       mbuf /mbuf false dma-map-in  to mbuf-dma
    ;
   
    \ dma-map-out and dma-free mbuf-dma
    : mbuf-free ( -- )
       mbuf mbuf-dma /mbuf dma-sync              \ redundant
       mbuf mbuf-dma /mbuf dma-map-out
       mbuf /mbuf dma-free
       -1 to mbuf
       -1 to mbuf-dma
    ;  
   
    external
  
    \ external methods for scsi bus ( "SUNW,my-scsi" node) 
    : open  ( -- okay? )  
       dma-open 
       " scsi-initiator-id" get-inherited-property 0=  if
          decode-int  to scsi-init-id
          2drop
          map-scsi
          init-n-test                    ( ok? )
          dup if                         ( true )
             get-buffers                 ( true )
          else
             unmap-scsi dma-close        ( false )
          then                           ( success? )
       else
          ." Missing initiator id" cr  false
         dma-close
       then                              ( success? )
    ;
  
    : close  ( -- )  give-buffers unmap-scsi dma-close  ;
  
    : reset  ( -- )
       dma-open map-scsi 
       ... 
       reset-my-scsi drop reset-bus drop
       unmap-scsi dma-close
    ;
  
    : selftest  ( -- fail? )
       map-scsi
       mbuf-alloc
       scsi-selftest
       mbuf-free
       unmap-scsi
    ;
    
    headers 
  
 \ start of child block device
  
    new-device  \ missing "reg" indicates SCSI "wild-card" node
  
       " sd" encode-string " name" property
       " block" device-type
  
       0 instance value offset-low
       0 instance value offset-high
       0 instance value label-package
  
       \ The "disk-label" package interprets any partition information contained in
       \ the disk label. The "load" method of the "block" device uses the load method
       \ provided by "disk-label"
       : init-label-package  ( -- okay? )
          0 to offset-high  0 to offset-low
          my-args  " disk-label"  $open-package to label-package
          label-package  if
             0 0  " offset" label-package $call-method  
             to offset-high to offset-low
             true
          else
             ." Can't open disk label package"  cr  false
          then
       ;
        
       0 instance value deblocker
       : init-deblocker  ( -- okay? )
          " "  " deblocker"  $open-package  to deblocker
          deblocker  if
             true
          else
             ." Can't open deblocker package"  cr  false
          then
       ;
        
       : device-present? ( lun target -- present? )
          " device-present?" $call-parent
       ;
       \ The following methods are needed for "block" device:
       \ open, close, selftest, reset, read, write, load, seek, block-size, 
       \ max-transfer,read-blocks, write-blocks.
       \ Carefully notice the relationship between the methods for the "block" device
       \ and the methods pre-defined for "disk-label" and "deblocker"
  
       external
       \ external methods for "block" device ( "sd" node) 
  
       : spin-up  ( -- )  my-unit  " timed-spin" $call-parent  ;
  
       : open  ( -- ok? )  
          my-unit device-present?  0=  if  false exit  then
          spin-up      \ Start the disk if necessary
       
          init-deblocker  0=  if  false exit  then
          init-label-package  0=  if
             deblocker close-package false exit
          then
          true
       ;
       
       : close  ( -- )
          label-package close-package  0 to label-package
          deblocker close-package  0 to deblocker
       ;
        
       : selftest ( -- fail? )
          my-unit device-present?  if
             " send-diagnostic" $call-parent  ( fail? )
          else
             true                             ( error )
          then
       ;
       : reset  ( -- )  ...   ;
  
       
       \ The "deblocker" package assists in the implementation of byte-oriented read and 
       \ write methods for disks and tapes. The deblocker provides a layer of buffering
       \ to implement a high level byte-oriented interface "on top of" a low-level 
       \ block-oriented interface. 
        
       \ The "seek", "read" and "write" methods of this block device use corresponding 
       \ methods provided by "deblocker"
  
       \ In order to be able to use the "deblocker" package this device has to define the
       \ following four methods, which the deblocker uses as its low-level interface
       \ to the device: 
       \ 1) block-size, 2) max-transfer, 3) read-blocks and 4) write-blocks
  
       : block-size ( -- n )   " disk-block-size" $call-parent  ;
       : max-transfer ( -- n ) block-size h# 40 * ;
       
       : read-blocks  ( addr block# #blocks -- #read )
          true " disk-r/w-blocks" $call-parent
       ;
       : write-blocks  ( addr block# #blocks -- #written )
          false " disk-r/w-blocks" $call-parent
       ;
       
       : dma-alloc ( #bytes -- vadr ) " dma-alloc" $call-parent  ;
       : dma-free  ( vadr #bytes -- ) " dma-free" $call-parent  ;
       : seek  ( offset.low offset.high -- okay? )
          offset-low offset-high  x+  " seek"   deblocker $call-method
       ;
       : read  ( addr len -- actual-len )  " read"  deblocker $call-method  ;
       : write ( addr len -- actual-len )  " write" deblocker $call-method  ;
       : load  ( addr -- size )            " load"  label-package $call-method  ;
        
    finish-device  \ finishing "block" device "sd"
  
    headers 
  
 \ start of child byte device
  
    new-device  \ missing "reg" indicates "wild-card" node
       " st" encode-string " name" property
       " byte" device-type
       
       false instance value write-eof-mark?
       instance variable file-mark? 
       true instance value scsi-tape-first-install
       
       : scsi-tape-rewind     ( -- [[xstatbuf] f-hw] error? ) ... ; 
       
       : write-eof  ( -- [[xstatbuf] f-hw] error? ) ...  ;
       
       0 instance value deblocker
       : init-deblocker  ( -- okay? )
          " "  " deblocker"  $open-package  to deblocker
          deblocker  if
             true
          else
             ." Can't open deblocker package"  cr  false
          then
       ;
        
       : flush-deblocker  ( -- )  
          deblocker close-package  init-deblocker drop
       ;
       : fixed-or-variable ( -- max-block fixed? )  
          " fixed-or-variable" $call-parent  
       ;
        
       : device-present? ( lun target -- present? )
          " device-present?" $call-parent
       ;
  
  
  
  
       
       \ The following methods are needed for "byte" devices:
       \ open, close, selftest, reset, read, write, load, seek,  block-size,
       \ max-transfer, read-blocks, write-blocks. Carefully notice the relationship
       \ between the methods for "byte" devices and the methods pre-defined for the
       \ standard deblocker package.
        
       external
       \ external methods for "byte" device ( "st" node) 
   
       \ The "deblocker" package assists in the implementation of byte-oriented read
       \ and write methods for disks and tapes. The deblocker provides a layer of
       \ buffering to implement a high level byte-oriented interface "on top of" a
       \ low-level block-oriented interface.
        
       \ The "read" and "write" methods of this "byte" device use the corresponding 
       \ methods provided by the "deblocker"
  
       \ In order to be able to use the "deblocker" package this device has to define the
       \ following four methods which the deblocker uses as its low-level interface to
       \ the device:
       \ 1) block-size, 2) max-transfer, 3) read-blocks and 4) write-blocks
       : block-size  ( -- n )   " tape-block-size" $call-parent  ;
  
       : max-transfer  ( -- n )
          fixed-or-variable  ( max-block fixed? )
          if
             \ Use the largest multiple of /tapeblock that to <= h# fe00
             h# fe00  over  / *
          then
       ;
        
       : read-blocks  ( addr block# #blocks -- #read )
          file-mark? @  0=  if
             true " tape-r/w-some" $call-parent  file-mark? !   ( #read )
          else
             3drop 0
          then
       ;
  
       : write-blocks  ( addr block# #blocks -- #written )
          false " tape-r/w-some" $call-parent file-mark? !
       ;
  
       : dma-alloc  ( #bytes -- vaddr )  " dma-alloc" $call-parent  ;
  
       : dma-free   ( vaddr #bytes -- )  " dma-free" $call-parent  ;
  
       : open  ( -- okay? )  \ open for tape
          my-unit  device-present?  0=  if  false exit  then
          scsi-tape-first-install  if
             scsi-tape-rewind  if
                ." Can't rewind tape" cr
                0= if  drop  then
                false exit
             then
             false to scsi-tape-first-install
          then
          \ Set fixed-len? and /tapeblock
          fixed-or-variable 2drop
          init-deblocker  0=  if  false exit  then
          true
       ;
  
       : close  ( -- )
          deblocker close-package  0 to deblocker
          write-eof-mark?  if
             write-eof  if
                ." Can't write EOF Marker."
                0=  if  drop  then
             then
          then
       ;
       : reset  ( -- )  ...   ;
       : selftest ( -- fail? )
          my-unit device-present?  if
             " send-diagnostic" $call-parent  ( fail? )
          else
             true                             ( error )
          then
       ;
        
        
       : read  ( addr len -- actual-len )  " read"  deblocker $call-method  ;
       : write ( addr len -- actual-len )
          true to write-eof-mark?
          " write" deblocker $call-method
       ;
       
       : load  ( addr -- size )
          \ use my-args to get tape file-no
          ...  ( addr file# )
        
          \ position at requested file
          ...  
          dup  begin                   ( start-addr next-addr )
             dup max-transfer read     ( start-addr next-addr #read )
             dup 0>                    ( start-addr next-addr #read got-some? )
          while                        ( start-addr next-addr #read )
             +                         ( start-addr next-addr' )
          repeat                       ( start-addr end-addr 0 )
          drop swap -                  ( size )
       ;
        
       : seek  ( byte# file# -- error? )
          \ position at requested file
          ...                                    ( byte# ) 
  
          flush-deblocker                        ( byte# )
          begin  dup 0>  while                   ( #remaining )
             " mbuf0" $call-parent
             over ublock min  read               ( #remaining #read )
             dup  0=  if                         ( #remaining 0 )
                2drop  true
                exit                             ( error )
             then                                ( #remaining #read )
             -                                   ( #remaining' )
          repeat                                 ( 0 )
          drop false                             ( no-error )
       ;
        
    finish-device  \ finishing "byte" device "st"
 end0 
 \ finishing "SUNW,my-scsi" 
 |