[OpenSPARC-T2-SAM] / obp / obp / dev / deblock.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: deblock.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: @(#)deblock.fth 2.20 97/02/04
purpose:
copyright: Copyright 1990-1994 Sun Microsystems, Inc.  All Rights Reserved

\ Block-to-byte conversion package using the Forth file system code to
\ do the deblocking.  Creates a file type which accesses the underlying
\ block device and opens a file descriptor for a file of that type.
\ The file descriptor is stored in the "my-data" field of the instance
\ record.  The "fid" field of file descriptor contains the address of
\ the private data for this device instance.

headerless
decimal

" /packages" find-device
new-device

0 invert 1 >> constant maxint	\ Assumes 2's complement, I suppose

0 instance value block#         \ Internal state; holds offset from last seek
0 instance value buffer         \ Buffer we use for file I/O
0 instance value bufsize 	\ Size of buffer
0 instance value blocksize	\ Sector size of underlying device
/fd instance buffer: deblock-fd

\ Closes an open file, freeing its descriptor for reuse.

: block-fclose  ( fid -- )
   drop   buffer  if
      buffer  bufsize " dma-free" ['] $call-parent catch  if
         \ If dma-free method doesn't exist, we fall back on the
         \ system free-virtual function.  This is a hack, and can
         \ probably be eliminated in future systems.
         2drop 2drop  buffer bufsize free-virtual
      then
   then
;

\ Writes "count" bytes from the buffer at address "adr" to a file.
\ Returns the number of bytes actually written.

: block-fwrite  ( adr #bytes fid -- #written )
   drop  block#                  ( adr #bytes block# )
   swap blocksize  /             ( adr #blocks block# )
   " write-blocks" $call-parent  ( actual-#blocks )
   blocksize *                   ( #bytes-written )
;


\ Reads at most "count" bytes into the buffer at address "adr" from a file.
\ Returns the number of bytes actually read.

: block-fread  ( adr #bytes fid -- #read )
   drop  block#                  ( adr #bytes block# )
   swap blocksize  /             ( adr block# #blocks )
   " read-blocks" $call-parent   ( actual-#blocks )
   blocksize  *                  ( #bytes-read )
;


\ Positions to byte number "d.byte#" in a file

: block-fseek  ( d.byte# fid -- )  drop  blocksize um/mod  to block#  drop  ;


\ Returns the current size "d.size" of a file

: block-fsize  ( fid -- d.size )  drop -1 maxint  ;


\ Aligns a number to a block boundary.

: block-falign  ( d.byte# fid -- d.aligned-byte# )
   drop  blocksize um/mod nip  blocksize um*
;

: block-size    ( -- n )
   " block-size"  ['] $call-parent catch  if  2drop d# 512  then
;

\ Prepares a file for later access.  Name is the pathname of the file
\ and mode is the mode (0 read, 1 write, 2 modify).  If the operation
\ succeeds, returns the addresses of routines to perform I/O on the
\ open file and true.  If the operation fails, returns false.
: buffer-size  ( -- n )
   " max-transfer"  ['] $call-parent catch  if  2drop  maxint  then

   \ Don't allocate more than 64K, unless the block size is larger than that.
   block-size h# 10000  max  min    ( n )
;

headers
\ Externally-visible routines follow.

" deblocker" device-name

\ This property indicates that bug 1074409 has been fixed.
\ If this property is not present, client programs must install a patch.
0 0 " disk-write-fix" property

: open  ( -- okay? )

   0 to block#                          ( )
   0 to buffer                          ( )

   block-size   to blocksize            ( )
   buffer-size  to bufsize              ( )

   bufsize  " dma-alloc"                ( size adr len )
   ['] $call-parent  catch  if          ( x y z )
      3drop  bufsize allocate-dma       ( dma-addr|0 )
      dup 0=  if  exit  then            ( dma-addr )
   then                                 ( dma-addr )
   to buffer                            ( )

   file @ >r  deblock-fd file !         ( )

   buffer  bufsize  initbuf             ( )

   my-self  modify                      ( fid mode )
   ['] block-fsize   ['] block-falign   ( fid mode ops.. )
   ['] block-fclose  ['] block-fseek    ( fid mode ops.. )
   ['] block-fwrite  ['] block-fread    ( fid mode ops.. )
   setupfd                              ( )

   true                                 ( true )
   r> file !
;

: seek   ( offset.low offset.high -- error? )
   deblock-fd  ['] dfseek catch  if  2drop true  else  false  then
;
: read   ( adr len -- actual-len )
   deblock-fd  ['] fgets catch  if  3drop 0  then
;
: write  ( adr len -- actual-len )
   tuck  deblock-fd  ['] fputs catch  if  2drop 2drop -1  then
;
: close  ( -- )
   deblock-fd ['] fclose catch  ?dup  if  .error drop  then
;

finish-device
device-end
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: deblock.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	id: @(#)deblock.fth 2.20 97/02/04
	43	purpose:
	44	copyright: Copyright 1990-1994 Sun Microsystems, Inc. All Rights Reserved
	45
	46	\ Block-to-byte conversion package using the Forth file system code to
	47	\ do the deblocking. Creates a file type which accesses the underlying
	48	\ block device and opens a file descriptor for a file of that type.
	49	\ The file descriptor is stored in the "my-data" field of the instance
	50	\ record. The "fid" field of file descriptor contains the address of
	51	\ the private data for this device instance.
	52
	53	headerless
	54	decimal
	55
	56	" /packages" find-device
	57	new-device
	58
	59	0 invert 1 >> constant maxint \ Assumes 2's complement, I suppose
	60
	61	0 instance value block# \ Internal state; holds offset from last seek
	62	0 instance value buffer \ Buffer we use for file I/O
	63	0 instance value bufsize \ Size of buffer
	64	0 instance value blocksize \ Sector size of underlying device
65	/fd instance buffer: deblock-fd
66
67	\ Closes an open file, freeing its descriptor for reuse.
68
69	: block-fclose ( fid -- )
70	drop buffer if
71	buffer bufsize " dma-free" ['] $call-parent catch if
72	\ If dma-free method doesn't exist, we fall back on the
73	\ system free-virtual function. This is a hack, and can
74	\ probably be eliminated in future systems.
75	2drop 2drop buffer bufsize free-virtual
76	then
77	then
78	;
79
80	\ Writes "count" bytes from the buffer at address "adr" to a file.
81	\ Returns the number of bytes actually written.
82
83	: block-fwrite ( adr #bytes fid -- #written )
84	drop block# ( adr #bytes block# )
85	swap blocksize / ( adr #blocks block# )
86	" write-blocks" $call-parent ( actual-#blocks )
87	blocksize * ( #bytes-written )
88	;
89
90
91	\ Reads at most "count" bytes into the buffer at address "adr" from a file.
92	\ Returns the number of bytes actually read.
93
94	: block-fread ( adr #bytes fid -- #read )
95	drop block# ( adr #bytes block# )
96	swap blocksize / ( adr block# #blocks )
97	" read-blocks" $call-parent ( actual-#blocks )
98	blocksize * ( #bytes-read )
99	;
100
101
102	\ Positions to byte number "d.byte#" in a file
103
104	: block-fseek ( d.byte# fid -- ) drop blocksize um/mod to block# drop ;
105
106
107	\ Returns the current size "d.size" of a file
108
109	: block-fsize ( fid -- d.size ) drop -1 maxint ;
110
111
112	\ Aligns a number to a block boundary.
113
114	: block-falign ( d.byte# fid -- d.aligned-byte# )
115	drop blocksize um/mod nip blocksize um*
116	;
117
118	: block-size ( -- n )
119	" block-size" ['] $call-parent catch if 2drop d# 512 then
120	;
121
122	\ Prepares a file for later access. Name is the pathname of the file
123	\ and mode is the mode (0 read, 1 write, 2 modify). If the operation
124	\ succeeds, returns the addresses of routines to perform I/O on the
125	\ open file and true. If the operation fails, returns false.
126	: buffer-size ( -- n )
127	" max-transfer" ['] $call-parent catch if 2drop maxint then
128
129	\ Don't allocate more than 64K, unless the block size is larger than that.
130	block-size h# 10000 max min ( n )
131	;
132
133	headers
134	\ Externally-visible routines follow.
135
136	" deblocker" device-name
137
138	\ This property indicates that bug 1074409 has been fixed.
139	\ If this property is not present, client programs must install a patch.
140	0 0 " disk-write-fix" property
141
142	: open ( -- okay? )
143
144	0 to block# ( )
145	0 to buffer ( )
146
147	block-size to blocksize ( )
148	buffer-size to bufsize ( )
149
150	bufsize " dma-alloc" ( size adr len )
151	['] $call-parent catch if ( x y z )
152	3drop bufsize allocate-dma ( dma-addr\|0 )
153	dup 0= if exit then ( dma-addr )
154	then ( dma-addr )
155	to buffer ( )
156
157	file @ >r deblock-fd file ! ( )
158
159	buffer bufsize initbuf ( )
160
161	my-self modify ( fid mode )
162	['] block-fsize ['] block-falign ( fid mode ops.. )
163	['] block-fclose ['] block-fseek ( fid mode ops.. )
164	['] block-fwrite ['] block-fread ( fid mode ops.. )
165	setupfd ( )
166
167	true ( true )
168	r> file !
169	;
170
171	: seek ( offset.low offset.high -- error? )
172	deblock-fd ['] dfseek catch if 2drop true else false then
173	;
174	: read ( adr len -- actual-len )
175	deblock-fd ['] fgets catch if 3drop 0 then
176	;
177	: write ( adr len -- actual-len )
178	tuck deblock-fd ['] fputs catch if 2drop 2drop -1 then
179	;
180	: close ( -- )
181	deblock-fd ['] fclose catch ?dup if .error drop then
182	;
183
184	finish-device
185	device-end