\ 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"
|