| blob | a9524186d995ec57e326c1d9cf1a20f347722264 |
1 \
2 \ CDDL HEADER START
3 \
4 \ The contents of this file are subject to the terms of the
5 \ Common Development and Distribution License (the "License").
6 \ You may not use this file except in compliance with the License.
7 \
8 \ You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
9 \ or http://www.opensolaris.org/os/licensing.
10 \ See the License for the specific language governing permissions
11 \ and limitations under the License.
12 \
13 \ When distributing Covered Code, include this CDDL HEADER in each
14 \ file and include the License file at usr/src/OPENSOLARIS.LICENSE.
15 \ If applicable, add the following below this CDDL HEADER, with the
16 \ fields enclosed by brackets "[]" replaced with your own identifying
17 \ information: Portions Copyright [yyyy] [name of copyright owner]
18 \
19 \ CDDL HEADER END
20 \
21 \
22 \ Copyright 2010 Sun Microsystems, Inc. All rights reserved.
23 \ Use is subject to license terms.
24 \
25 \ Copyright 2015 Toomas Soome <tsoome@me.com>
28 purpose: ZFS file system support package
29 copyright: Copyright 2010 Sun Microsystems, Inc. All Rights Reserved
31 " /packages" get-package push-package
33 new-device
34 fs-pkg$ device-name diag-cr?
36 0 instance value temp-space
39 \ 64b ops
40 \ fcode is still 32b on 64b sparc-v9, so
41 \ we need to override some arithmetic ops
42 \ stack ops and logical ops (dup, and, etc) are 64b
43 : xcmp ( x1 x2 -- -1|0|1 )
44 xlsplit rot xlsplit ( x2.lo x2.hi x1.lo x1.hi )
45 rot 2dup u< if ( x2.lo x1.lo x1.hi x2.hi )
46 2drop 2drop -1 ( lt )
47 else u> if ( x2.lo x1.lo )
48 2drop 1 ( gt )
49 else swap 2dup u< if ( x1.lo x2.lo )
50 2drop -1 ( lt )
51 else u> if ( )
52 1 ( gt )
53 else ( )
54 0 ( eq )
55 then then then then ( -1|0|1 )
56 ;
57 : x< ( x1 x2 -- <? ) xcmp -1 = ;
58 : x> ( x1 x2 -- >? ) xcmp 1 = ;
59 \ : x= ( x1 x2 -- =? ) xcmp 0= ;
60 : x<> ( x1 x2 -- <>? ) xcmp 0<> ;
61 : x0= ( x -- 0=? ) xlsplit 0= swap 0= and ;
63 /buf-len instance buffer: numbuf
65 : (xu.) ( u -- u$ )
66 numbuf /buf-len + swap ( adr u )
67 begin
68 d# 10 /mod swap ( adr u' rem )
69 ascii 0 + ( adr u' c )
70 rot 1- tuck c! ( u adr' )
71 swap dup 0= ( adr u done? )
72 until drop ( adr )
73 dup numbuf - /buf-len swap - ( adr len )
74 ;
76 \ pool name
77 /buf-len instance buffer: bootprop-buf
78 : bootprop$ ( -- prop$ ) bootprop-buf cscount ;
80 \ decompression
81 \
82 \ kernel/os/compress.c has a definitive theory of operation comment
83 \ on lzjb, but here's the reader's digest version:
84 \
85 \ repeated phrases are replaced by referenced to the original
86 \ e.g.,
87 \ y a d d a _ y a d d a _ y a d d a , _ b l a h _ b l a h _ b l a h
88 \ becomes
89 \ y a d d a _ 6 11 , _ b l a h 5 10
90 \ where 6 11 means memmove(ptr, ptr - 6, 11)
91 \
92 \ data is separated from metadata with embedded copymap entries
93 \ every 8 items e.g.,
94 \ 0x40 y a d d a _ 6 11 , 0x20 _ b l a h 5 10
95 \ the copymap has a set bit for copy refercences
96 \ and a clear bit for bytes to be copied directly
97 \
98 \ the reference marks are encoded with match-bits and match-min
99 \ e.g.,
100 \ byte[0] = ((mlen - MATCH_MIN) << (NBBY - MATCH_BITS) | (off >> NBBY)
101 \ byte[1] = (uint8_t)off
102 \
104 : pow2 ( n -- 2**n ) 1 swap lshift ;
106 \ assume MATCH_BITS=6 and MATCH_MIN=3
107 6 constant mbits
108 3 constant mmin
109 8 mbits - constant mshift
110 d# 16 mbits - pow2 1- constant mmask
112 : decode-src ( src -- mlen off )
113 dup c@ swap 1+ c@ ( c[0] c[1] )
114 over mshift rshift mmin + ( c[0] c[1] mlen )
115 -rot swap bwjoin mmask and ( mlen off )
116 ;
118 \ equivalent of memmove(dst, dst - off, len)
119 \ src points to a copy reference to be decoded
120 : mcopy ( dend dst src -- dend dst' )
121 decode-src ( dend dst mlen off )
122 2 pick swap - >r ( dent dst mlen r: cpy )
123 begin
124 1- dup 0>= ( dend dst mlen' any? r: cpy )
125 2over > and ( dend dst mlen !done? r : cpy )
126 while ( dend dst mlen r: cpy )
127 swap r> dup 1+ >r c@ ( dend mlen dst c r: cpy' )
128 over c! 1+ swap ( dend dst' mlen r: cpy )
129 repeat ( dend dst' mlen r: cpy )
130 r> 2drop ( dend dst )
131 ;
134 : lzjb ( src dst len -- )
135 over + swap ( src dend dst )
136 rot >r ( dend dst r: src )
138 \ setup mask so 1st while iteration fills map
139 0 7 pow2 2swap ( map mask dend dst r: src )
141 begin 2dup > while
142 2swap 1 lshift ( dend dst map mask' r: src )
144 dup 8 pow2 = if
145 \ fetch next copymap
146 2drop ( dend dst r: src )
147 r> dup 1+ >r c@ 1 ( dend dst map' mask' r: src' )
148 then ( dend dst map mask r: src' )
150 \ if (map & mask) we hit a copy reference
151 \ else just copy 1 byte
152 2swap 2over and if ( map mask dend dst r: src )
153 r> dup 2+ >r ( map mask dend dst src r: src' )
154 mcopy ( map mask dend dst' r: src )
155 else
156 r> dup 1+ >r c@ ( map mask dend dst c r: src' )
157 over c! 1+ ( map mask dend dst' r: src )
158 then
159 repeat ( map mask dend dst r: src )
160 2drop 2drop r> drop ( )
161 ;
163 \ decode lz4 buffer header, returns src addr and len
164 : lz4_sbuf ( addr -- s_addr s_len )
165 dup C@ 8 lshift swap 1+ ( byte0 addr++ )
166 dup C@ ( byte0 addr byte1 )
167 rot ( addr byte1 byte0 )
168 or d# 16 lshift swap 1+ ( d addr++ )
170 dup C@ 8 lshift ( d addr byte2 )
171 swap 1+ ( d byte2 addr++ )
172 dup C@ swap 1+ ( d byte2 byte3 addr++ )
173 -rot ( d s_addr byte2 byte3 )
174 or ( d s_addr d' )
175 rot ( s_addr d' d )
176 or ( s_addr s_len )
177 ;
179 4 constant STEPSIZE
180 8 constant COPYLENGTH
181 5 constant LASTLITERALS
182 4 constant ML_BITS
183 d# 15 constant ML_MASK \ (1<<ML_BITS)-1
184 4 constant RUN_BITS \ 8 - ML_BITS
185 d# 15 constant RUN_MASK \ (1<<RUN_BITS)-1
187 \ A32(d) = A32(s); d+=4; s+=4
188 : lz4_copystep ( dest source -- dest' source')
189 2dup swap 4 move
190 swap 4 +
191 swap 4 + ( dest+4 source+4 )
192 ;
194 \ do { LZ4_COPYPACKET(s, d) } while (d < e);
195 : lz4_copy ( e d s -- e d' s' )
196 begin ( e d s )
197 lz4_copystep
198 lz4_copystep ( e d s )
199 over ( e d s d )
200 3 pick < 0=
201 until
202 ;
204 \ lz4 decompress translation from C code
205 \ could use some factorisation
206 : lz4 ( src dest len -- )
207 swap dup >r swap \ save original dest to return stack.
208 rot ( dest len src )
209 lz4_sbuf ( dest len s_buf s_len )
210 over + ( dest len s_buf s_end )
211 2swap ( s_buf s_end dest len )
212 over + ( s_buf s_end dest dest_end )
213 2swap ( dest dest_end s_buf s_end )
215 \ main loop
216 begin 2dup < while
217 swap dup C@ ( dest dest_end s_end s_buf token )
218 swap CHAR+ swap ( dest dest_end s_end s_buf++ token )
219 dup ML_BITS rshift ( dest dest_end s_end s_buf token length )
220 >r rot rot r> ( dest dest_end token s_end s_buf length )
221 dup RUN_MASK = if
222 d# 255 begin ( dest dest_end token s_end s_buf length s )
223 swap ( dest dest_end token s_end s_buf s length )
224 >r >r ( ... R: length s )
225 2dup > ( dest dest_end token s_end s_buf flag )
226 r@ d# 255 = and ( dest dest_end token s_end s_buf flag R: length s )
227 r> swap r> swap ( dest dest_end token s_end s_buf s length flag )
228 >r swap r> ( dest dest_end token s_end s_buf length s flag )
229 while
230 drop >r ( dest dest_end token s_end s_buf R: length )
231 dup c@ swap CHAR+ ( dest dest_end token s_end s s_buf++ )
232 swap ( dest dest_end token s_end s_buf s )
233 dup ( dest dest_end token s_end s_buf s s )
234 r> + swap ( dest dest_end token s_end s_buf length s )
235 repeat
236 drop ( dest dest_end token s_end s_buf length )
237 then
239 -rot ( dest dest_end token length s_end s_buf )
240 swap >r >r ( dest dest_end token length R: s_end s_buf )
241 swap >r ( dest dest_end length R: s_end s_buf token )
242 rot ( dest_end length dest )
243 2dup + ( dest_end length dest cpy )
245 2dup > if ( dest > cpy )
246 " lz4 overflow" die
247 then
249 3 pick COPYLENGTH - over < ( dest_end length dest cpy flag )
250 3 pick ( dest_end length dest cpy flag length )
251 r> ( dest_end length dest cpy flag length token )
252 r> ( dest_end length dest cpy flag length token s_buf R: s_end )
253 rot ( dest_end length dest cpy flag token s_buf length )
254 over + ( dest_end length dest cpy flag token s_buf length+s_buf )
255 r@ COPYLENGTH - > ( dest_end length dest cpy flag token s_buf flag )
256 swap >r ( dest_end length dest cpy flag token flag R: s_end s_buf )
257 swap >r ( dest_end length dest cpy flag flag R: s_end s_buf token )
258 or if ( dest_end length dest cpy R: s_end s_buf token )
260 3 pick over swap > if
261 " lz4 write beyond buffer end" die ( write beyond the dest end )
262 then ( dest_end length dest cpy )
264 2 pick ( dest_end length dest cpy length )
265 r> r> swap ( dest_end length dest cpy length s_buf token R: s_end )
266 r> ( dest_end length dest cpy length s_buf token s_end )
267 swap >r >r ( dest_end length dest cpy length s_buf R: token s_end )
269 swap over + ( dest_end length dest cpy s_buf s_buf+length )
270 r@ > if ( dest_end length dest cpy s_buf R: token s_end )
271 " lz4 read beyond source" die \ read beyond source buffer
272 then
274 nip ( dest_end length dest s_buf R: token s_end )
275 >r ( dest_end length dest R: token s_end s_buf )
276 over r@ ( dest_end length dest length s_buf )
277 -rot move ( dest_end length )
279 r> + r> r> drop < if
280 " lz4 format violation" die \ LZ4 format violation
281 then
283 r> drop \ drop original dest
284 drop
285 exit \ parsing done
286 then
288 swap ( dest_end length cpy dest R: s_end s_buf token )
289 r> r> swap >r ( dest_end length cpy dest s_buf R: s_end token )
291 lz4_copy ( dest_end length cpy dest s_buf)
293 -rot ( dest_end length s_buf cpy dest )
294 over - ( dest_end length s_buf cpy dest-cpy )
295 rot ( dest_end length cpy dest-cpy s_buf )
296 swap - ( dest_end length cpy s_buf )
298 dup C@ swap ( dest_end length cpy b s_buf )
299 dup 1+ C@ 8 lshift ( dest_end length cpy b s_buf w )
300 rot or ( dest_end length cpy s_buf w )
301 2 pick swap - ( dest_end length cpy s_buf ref )
302 swap 2 + ( dest_end length cpy ref s_buf+2 )
303 \ note: cpy is also dest, remember to save it
304 -rot ( dest_end length s_buf cpy ref )
305 dup ( dest_end length s_buf cpy ref ref )
307 \ now we need original dest
308 r> r> swap r@ ( dest_end length s_buf cpy ref ref s_end token dest )
309 -rot swap >r >r
310 < if
311 " lz4 reference outside buffer" die \ reference outside dest buffer
312 then ( dest_end length s_buf op ref )
314 2swap ( dest_end op ref length s_buf )
315 swap ( dest_end op ref s_buf length R: dest s_end token )
317 \ get matchlength
318 drop r> ML_MASK and ( dest_end op ref s_buf length R: dest s_end )
319 dup ML_MASK = if ( dest_end op ref s_buf length R: dest s_end )
320 -1 \ flag to top
321 begin
322 rot ( dest_end op ref length flag s_buf )
323 dup r@ < ( dest_end op ref length flag s_buf flag )
324 rot and ( dest_end op ref length s_buf flag )
325 while
326 dup c@ ( dest_end op ref length s_buf s )
327 swap 1+ ( dest_end op ref length s s_buf++ )
328 -rot ( dest_end op ref s_buf length s )
329 swap over + swap ( dest_end op ref s_buf length+s s )
330 d# 255 =
331 repeat
332 swap
333 then ( dest_end op ref s_buf length R: dest s_end )
335 2swap ( dest_end s_buf length op ref )
337 \ copy repeated sequence
338 2dup - STEPSIZE < if ( dest_end s_buf length op ref )
339 \ 4 times *op++ = *ref++;
340 dup c@ >r ( dest_end s_buf length op ref R: C )
341 CHAR+ swap ( dest_end s_buf length ref++ op )
342 dup r> swap c! CHAR+ swap ( dest_end s_buf length op ref )
343 dup c@ >r ( dest_end s_buf length op ref R: C )
344 CHAR+ swap ( dest_end s_buf length ref++ op )
345 dup r> swap c! CHAR+ swap ( dest_end s_buf length op ref )
346 dup c@ >r ( dest_end s_buf length op ref R: C )
347 CHAR+ swap ( dest_end s_buf length ref++ op )
348 dup r> swap c! CHAR+ swap ( dest_end s_buf length op ref )
349 dup c@ >r ( dest_end s_buf length op ref R: C )
350 CHAR+ swap ( dest_end s_buf length ref++ op )
351 dup r> swap c! CHAR+ swap ( dest_end s_buf length op ref )
352 2dup - ( dest_end s_buf length op ref op-ref )
353 case
354 1 of 3 endof
355 2 of 2 endof
356 3 of 3 endof
357 0
358 endcase
359 - \ ref -= dec
360 2dup swap 4 move ( dest_end s_buf length op ref )
361 swap STEPSIZE 4 - +
362 swap ( dest_end s_buf length op ref )
363 else
364 lz4_copystep ( dest_end s_buf length op ref )
365 then
366 -rot ( dest_end s_buf ref length op )
367 swap over ( dest_end s_buf ref op length op )
368 + STEPSIZE 4 - - ( dest_end s_buf ref op cpy R: dest s_end )
370 \ if cpy > oend - COPYLENGTH
371 4 pick COPYLENGTH - ( dest_end s_buf ref op cpy oend-COPYLENGTH )
372 2dup > if ( dest_end s_buf ref op cpy oend-COPYLENGTH )
373 swap ( dest_end s_buf ref op oend-COPYLENGTH cpy )
375 5 pick over < if
376 " lz4 write outside buffer" die \ write outside of dest buffer
377 then ( dest_end s_buf ref op oend-COPYLENGTH cpy )
379 >r ( dest_end s_buf ref op oend-COPYLENGTH R: dest s_end cpy )
380 -rot swap ( dest_end s_buf oend-COPYLENGTH op ref )
381 lz4_copy ( dest_end s_buf oend-COPYLENGTH op ref )
382 rot drop swap r> ( dest_end s_buf ref op cpy )
383 begin
384 2dup <
385 while
386 >r ( dest_end s_buf ref op R: cpy )
387 over ( dest_end s_buf ref op ref )
388 c@ ( dest_end s_buf ref op C )
389 over c! ( dest_end s_buf ref op )
390 >r 1+ r> 1+ r> ( dest_end s_buf ref++ op++ cpy )
391 repeat
393 nip ( dest_end s_buf ref op )
394 dup 4 pick = if
395 \ op == dest_end we are done, cleanup
396 r> r> 2drop 2drop 2drop
397 exit
398 then
399 ( dest_end s_buf ref op R: dest s_end )
400 nip ( dest_end s_buf op )
401 else
402 drop ( dest_end s_buf ref op cpy R: dest s_end)
403 -rot ( dest_end s_buf cpy ref op )
404 swap ( dest_end s_buf cpy op ref )
405 lz4_copy
406 2drop ( dest_end s_buf op )
407 then
409 -rot r> ( op dest_end s_buf s_end R: dest )
410 repeat
412 r> drop
413 2drop
414 2drop
415 ;
417 \
418 \ ZFS block (SPA) routines
419 \
421 1 constant def-comp#
422 2 constant no-comp#
423 3 constant lzjb-comp#
424 d# 15 constant lz4-comp#
426 h# 2.0000 constant /max-bsize
427 d# 512 constant /disk-block
428 d# 128 constant /blkp
430 alias /gang-block /disk-block
432 \ the ending checksum is larger than 1 byte, but that
433 \ doesn't affect the math here
434 /gang-block 1-
435 /blkp / constant #blks/gang
437 : blk_offset ( bp -- n ) h# 8 + x@ -1 h# 7fff.ffff lxjoin and ;
438 : blk_gang ( bp -- n ) h# 8 + x@ xlsplit nip d# 31 rshift ;
439 : blk_etype ( bp -- n ) h# 32 + c@ ;
440 : blk_comp ( bp -- n ) h# 33 + c@ h# 7f and ;
441 : blk_embedded? ( bp -- flag ) h# 33 + c@ h# 80 and h# 80 = ;
442 : blk_psize ( bp -- n ) h# 34 + w@ ;
443 : blk_lsize ( bp -- n ) h# 36 + w@ ;
444 : blk_birth ( bp -- n ) h# 50 + x@ ;
446 : blke_psize ( bp -- n ) h# 34 + c@ 1 rshift h# 7f and 1+ ;
447 : blke_lsize ( bp -- n ) h# 34 + l@ h# 1ff.ffff and 1+ ;
449 0 instance value dev-ih
450 0 instance value blk-space
451 0 instance value gang-space
453 : foff>doff ( fs-off -- disk-off ) /disk-block * h# 40.0000 + ;
454 : fsz>dsz ( fs-size -- disk-size ) 1+ /disk-block * ;
456 : bp-dsize ( bp -- dsize )
457 dup blk_embedded? if
458 blke_psize
459 else
460 blk_psize fsz>dsz
461 then
462 ;
464 : bp-lsize ( bp -- lsize )
465 dup blk_embedded? if
466 blke_lsize
467 else
468 blk_lsize fsz>dsz
469 then
470 ;
472 : (read-dva) ( adr len dva -- )
473 blk_offset foff>doff dev-ih read-disk
474 ;
476 : gang-read ( adr len bp gb-adr -- ) tokenizer[ reveal ]tokenizer
478 \ read gang block
479 tuck /gang-block rot (read-dva) ( adr len gb-adr )
481 \ loop through indirected bp's
482 dup /blkp #blks/gang * ( adr len gb-adr bp-list bp-list-len )
483 bounds do ( adr len gb-adr )
484 i blk_offset x0= ?leave
486 \ calc subordinate read len
487 over i bp-dsize min ( adr len gb-adr sub-len )
488 2swap swap ( gb-adr sub-len len adr )
490 \ nested gang block - recurse with new gang block area
491 i blk_gang if
492 2swap ( len adr gb-adr sub-len )
493 3dup swap /gang-block + ( len adr gb-adr sub-len adr sub-len gb-adr' )
494 i swap gang-read ( len adr gb-adr sub-len )
495 2swap ( gb-adr sub-len len adr )
496 else
497 3dup nip swap ( gb-adr sub-len len adr adr sub-len )
498 i (read-dva) ( gb-adr sub-len len adr )
499 then ( gb-adr sub-len len adr )
501 \ adjust adr,len and check if done
502 -rot over - ( gb-adr adr sub-len len' )
503 -rot + swap ( gb-adr adr' len' )
504 dup 0= ?leave
505 rot ( adr' len' gb-adr )
506 /blkp +loop
507 3drop ( )
508 ;
510 : read-dva ( adr len dva -- )
511 dup blk_gang if
512 gang-space gang-read
513 else
514 (read-dva)
515 then
516 ;
518 : read-embedded ( adr len bp -- )
519 \ loop over buf len, w in comment is octet count
520 \ note, we dont increment bp, but use index value of w
521 \ so we can skip the non-payload octets
522 swap 0 0 ( adr bp len 0 0 )
523 rot 0 do ( adr bp 0 0 )
524 I 8 mod 0= if ( adr bp w x )
525 drop ( adr bp w )
526 2dup ( adr bp w bp w )
527 xa+ ( adr bp w bp+w*8 )
528 x@ swap ( adr bp x w )
529 1+ dup 6 = if 1+ else \ skip 6th word
530 dup h# a = if 1+ then \ skip 10th word
531 then ( adr bp x w )
532 swap ( adr bp w x )
533 then
534 2swap ( w x adr bp )
535 -rot ( w bp x adr )
536 swap dup ( w bp adr x x )
537 I 8 mod 4 < if
538 xlsplit ( w bp adr x x.lo x.hi )
539 drop ( w bp adr x x.lo )
540 else
541 xlsplit ( w bp adr x x.lo x.hi )
542 nip ( w bp adr x x.hi )
543 then
544 I 4 mod 8 * rshift h# ff and ( w bp adr x c )
545 rot ( w bp x c adr )
546 swap over ( w bp x adr c adr )
547 I + c! ( w bp x adr )
549 \ now we need to fix the stack for next pass
550 \ need to get ( adr bp w x )
551 swap 2swap ( adr x w bp )
552 -rot ( adr bp x w )
553 swap ( adr bp w x )
554 loop
555 2drop 2drop
556 ;
558 \ block read that check for holes, gangs, compression, etc
559 : read-bp ( adr len bp -- )
560 \ sparse block?
561 dup x@ x0= ( addr len bp flag0 )
562 swap dup 8 + x@ x0= ( addr len flag0 bp flag1 )
563 rot ( addr len bp flag1 flag0 )
564 and if
565 drop erase exit ( )
566 then
568 \ no compression?
569 dup blk_comp no-comp# = if
570 read-dva exit ( )
571 then
573 \ read into blk-space. read is either from embedded area or disk
574 dup blk_embedded? if
575 dup blk-space over bp-dsize ( adr len bp bp blk-adr rd-len )
576 rot read-embedded ( adr len bp )
577 else
578 dup blk-space over bp-dsize ( adr len bp bp blk-adr rd-len )
579 rot read-dva ( adr len bp )
580 then
582 \ set up the stack for decompress
583 blk_comp >r ( adr len R: alg )
584 blk-space -rot r> ( blk-adr adr len alg )
586 case
587 lzjb-comp# of lzjb endof
588 lz4-comp# of lz4 endof
589 def-comp# of lz4 endof \ isn't this writer only?
590 dup .h
591 " : unknown compression algorithm, only lzjb and lz4 are supported"
592 die
593 endcase ( )
594 ;
596 \
597 \ ZFS vdev routines
598 \
600 h# 1.c000 constant /nvpairs
601 h# 4000 constant nvpairs-off
603 \
604 \ xdr packed nvlist
605 \
606 \ 12B header
607 \ array of xdr packed nvpairs
608 \ 4B encoded nvpair size
609 \ 4B decoded nvpair size
610 \ 4B name string size
611 \ name string
612 \ 4B data type
613 \ 4B # of data elements
614 \ data
615 \ 8B of 0
616 \
617 d# 12 constant /nvhead
619 : >nvsize ( nv -- size ) l@ ;
620 : >nvname ( nv -- name$ )
621 /l 2* + dup /l + swap l@
622 ;
623 : >nvdata ( nv -- data )
624 >nvname + /l roundup
625 ;
627 \ convert nvdata to 64b int or string
628 : nvdata>x ( nvdata -- x )
629 /l 2* + ( ptr )
630 dup /l + l@ swap l@ ( x.lo x.hi )
631 lxjoin ( x )
632 ;
633 alias nvdata>$ >nvname
635 : nv-lookup ( nv name$ -- nvdata false | true )
636 rot /nvhead + ( name$ nvpair )
637 begin dup >nvsize while
638 dup >r >nvname ( name$ nvname$ r: nvpair )
639 2over $= if ( name$ r: nvpair )
640 2drop r> >nvdata ( nvdata )
641 false exit ( nvdata found )
642 then ( name$ r: nvpair )
643 r> dup >nvsize + ( name$ nvpair' )
644 repeat
645 3drop true ( not-found )
646 ;
648 : scan-vdev ( -- )
649 temp-space /nvpairs nvpairs-off ( adr len off )
650 dev-ih read-disk ( )
651 temp-space " txg" nv-lookup if
652 " no txg nvpair" die
653 then nvdata>x ( txg )
654 x0= if
655 " detached mirror" die
656 then ( )
657 temp-space " name" nv-lookup if
658 " no name nvpair" die
659 then nvdata>$ ( pool$ )
660 bootprop-buf swap move ( )
661 ;
664 \
665 \ ZFS ueber-block routines
666 \
668 d# 1024 constant /uber-block
669 d# 128 constant #ub/label
670 #ub/label /uber-block * constant /ub-ring
671 h# 2.0000 constant ubring-off
673 : ub_magic ( ub -- n ) x@ ;
674 : ub_txg ( ub -- n ) h# 10 + x@ ;
675 : ub_timestamp ( ub -- n ) h# 20 + x@ ;
676 : ub_rootbp ( ub -- p ) h# 28 + ;
678 0 instance value uber-block
680 : ub-cmp ( ub1 ub2 -- best-ub )
682 \ ub1 wins if ub2 isn't valid
683 dup ub_magic h# 00bab10c x<> if
684 drop exit ( ub1 )
685 then
687 \ if ub1 is 0, ub2 wins by default
688 over 0= if nip exit then ( ub2 )
690 \ 2 valid ubs, compare transaction groups
691 over ub_txg over ub_txg ( ub1 ub2 txg1 txg2 )
692 2dup x< if
693 2drop nip exit ( ub2 )
694 then ( ub1 ub2 txg1 txg2 )
695 x> if drop exit then ( ub1 )
697 \ same txg, check timestamps
698 over ub_timestamp over ub_timestamp x> if
699 nip ( ub2 )
700 else
701 drop ( ub1 )
702 then
703 ;
705 \ find best uber-block in ring, and copy it to uber-block
706 : get-ub ( -- )
707 temp-space /ub-ring ubring-off ( adr len off )
708 dev-ih read-disk ( )
709 0 temp-space /ub-ring ( null-ub adr len )
710 bounds do ( ub )
711 i ub-cmp ( best-ub )
712 /uber-block +loop
714 \ make sure we found a valid ub
715 dup 0= if " no ub found" die then
717 uber-block /uber-block move ( )
718 ;
721 \
722 \ ZFS dnode (DMU) routines
723 \
725 d# 44 constant ot-sa#
727 d# 512 constant /dnode
729 : dn_indblkshift ( dn -- n ) h# 1 + c@ ;
730 : dn_nlevels ( dn -- n ) h# 2 + c@ ;
731 : dn_bonustype ( dn -- n ) h# 4 + c@ ;
732 : dn_datablkszsec ( dn -- n ) h# 8 + w@ ;
733 : dn_bonuslen ( dn -- n ) h# a + w@ ;
734 : dn_blkptr ( dn -- p ) h# 40 + ;
735 : dn_bonus ( dn -- p ) h# c0 + ;
736 : dn_spill ( dn -- p ) h# 180 + ;
738 0 instance value dnode
740 \ indirect cache
741 \
742 \ ind-cache is a 1 block indirect block cache from dnode ic-dn
743 \
744 \ ic-bp and ic-bplim point into the ic-dn's block ptr array,
745 \ either in dn_blkptr or in ind-cache ic-bp is the ic-blk#'th
746 \ block ptr, and ic-bplim is limit of the current bp array
747 \
748 \ the assumption is that reads will be sequential, so we can
749 \ just increment ic-bp
750 \
751 0 instance value ind-cache
752 0 instance value ic-dn
753 0 instance value ic-blk#
754 0 instance value ic-bp
755 0 instance value ic-bplim
757 : dn-bsize ( dn -- bsize ) dn_datablkszsec /disk-block * ;
758 : dn-indsize ( dn -- indsize ) dn_indblkshift pow2 ;
759 : dn-indmask ( dn -- mask ) dn-indsize 1- ;
761 \ recursively climb the block tree from the leaf to the root
762 : blk@lvl>bp ( dn blk# lvl -- bp ) tokenizer[ reveal ]tokenizer
763 >r /blkp * over dn_nlevels ( dn bp-off #lvls r: lvl )
765 \ at top, just add dn_blkptr
766 r@ = if ( dn bp-off r: lvl )
767 swap dn_blkptr + ( bp r: lvl )
768 r> drop exit ( bp )
769 then ( dn bp-off r: lvl )
771 \ shift bp-off down and find parent indir blk
772 2dup over dn_indblkshift rshift ( dn bp-off dn blk# r: lvl )
773 r> 1+ blk@lvl>bp ( dn bp-off bp )
775 \ read parent indir blk and index
776 rot tuck dn-indsize ( bp-off dn bp len )
777 ind-cache swap rot read-bp ( bp-off dn )
778 dn-indmask and ( bp-off' )
779 ind-cache + ( bp )
780 ;
782 \ return end of current bp array
783 : bplim ( dn bp -- bp-lim )
784 over dn_nlevels 1 = if
785 drop dn_blkptr ( bp0 )
786 3 /blkp * + ( bplim )
787 else
788 1+ swap dn-indsize ( bp+1 indsz )
789 roundup ( bplim )
790 then
791 ;
793 \ return the lblk#'th block ptr from dnode
794 : lblk#>bp ( dn blk# -- bp )
795 2dup ( dn blk# dn blk# )
796 ic-blk# <> swap ic-dn <> or ( dn blk# cache-miss? )
797 ic-bp ic-bplim = ( dn blk# cache-miss? cache-empty? )
798 or if ( dn blk# )
799 2dup 1 blk@lvl>bp ( dn blk# bp )
800 dup to ic-bp ( dn blk# bp )
801 swap to ic-blk# ( dn bp )
802 2dup bplim to ic-bplim ( dn bp )
803 over to ic-dn
804 then 2drop ( )
805 ic-blk# 1+ to ic-blk#
806 ic-bp dup /blkp + to ic-bp ( bp )
807 ;
810 \
811 \ ZFS attribute (ZAP) routines
812 \
814 1 constant fzap#
815 3 constant uzap#
817 d# 64 constant /uzap
819 d# 24 constant /lf-chunk
820 d# 21 constant /lf-arr
821 h# ffff constant chain-end#
823 h# 100 constant /lf-buf
824 /lf-buf instance buffer: leaf-value
825 /lf-buf instance buffer: leaf-name
827 : +le ( len off -- n ) + w@ ;
828 : le_next ( le -- n ) h# 2 +le ;
829 : le_name_chunk ( le -- n ) h# 4 +le ;
830 : le_name_length ( le -- n ) h# 6 +le ;
831 : le_value_chunk ( le -- n ) h# 8 +le ;
832 : le_value_length ( le -- n ) h# a +le ;
834 : la_array ( la -- adr ) 1+ ;
835 : la_next ( la -- n ) h# 16 + w@ ;
837 0 instance value zap-space
839 \ setup leaf hash bounds
840 : >leaf-hash ( dn lh -- hash-adr /hash )
841 /lf-chunk 2* + ( dn hash-adr )
842 \ size = (bsize / 32) * 2
843 swap dn-bsize 4 rshift ( hash-adr /hash )
844 ;
845 : >leaf-chunks ( lf -- ch0 ) >leaf-hash + ;
847 \ convert chunk # to leaf chunk
848 : ch#>lc ( dn ch# -- lc )
849 /lf-chunk * ( dn lc-off )
850 swap zap-space >leaf-chunks ( lc-off ch0 )
851 + ( lc )
852 ;
854 \ assemble chunk chain into single buffer
855 : get-chunk-data ( dn ch# adr -- )
856 dup >r /lf-buf erase ( dn ch# r: adr )
857 begin
858 2dup ch#>lc nip ( dn la r: adr )
859 dup la_array ( dn la la-arr r: adr )
860 r@ /lf-arr move ( dn la r: adr )
861 r> /lf-arr + >r ( dn la r: adr' )
862 la_next dup chain-end# = ( dn la-ch# end? r: adr )
863 until r> 3drop ( )
864 ;
866 \ get leaf entry's name
867 : entry-name$ ( dn le -- name$ )
868 2dup le_name_chunk ( dn le dn la-ch# )
869 leaf-name get-chunk-data ( dn le )
870 nip le_name_length 1- ( len )
871 leaf-name swap ( name$ )
872 ;
874 \ return entry value as int
875 : entry-int-val ( dn le -- n )
876 le_value_chunk ( dn la-ch# )
877 leaf-value get-chunk-data ( )
878 leaf-value x@ ( n )
879 ;
882 [ifdef] strlookup
883 \ get leaf entry's value as string
884 : entry-val$ ( dn le -- val$ )
885 2dup le_value_chunk ( dn le dn la-ch# )
886 leaf-value get-chunk-data ( dn le )
887 nip le_value_length ( len )
888 leaf-value swap ( name$ )
889 ;
890 [then]
892 \ apply xt to entry
893 : entry-apply ( xt dn le -- xt dn false | ??? true )
894 over >r ( xt dn le r: dn )
895 rot dup >r execute if ( ??? r: xt dn )
896 r> r> 2drop true ( ??? true )
897 else ( )
898 r> r> false ( xt dn false )
899 then
900 ;
902 \ apply xt to every entry in chain
903 : chain-apply ( xt dn ch# -- xt dn false | ??? true )
904 begin
905 2dup ch#>lc nip ( xt dn le )
906 dup >r entry-apply if ( ??? r: le )
907 r> drop true exit ( ??? found )
908 then ( xt dn r: le )
909 r> le_next ( xt dn ch# )
910 dup chain-end# = ( xt dn ch# end? )
911 until drop ( xt dn )
912 false ( xt dn false )
913 ;
915 \ apply xt to every entry in leaf
916 : leaf-apply ( xt dn blk# -- xt dn false | ??? true )
918 \ read zap leaf into zap-space
919 2dup lblk#>bp ( xt dn blk# bp )
920 nip over dn-bsize zap-space ( xt dn bp len adr )
921 swap rot read-bp ( xt dn )
923 \ call chunk-look for every valid chunk list
924 dup zap-space >leaf-hash ( xt dn hash-adr /hash )
925 bounds do ( xt dn )
926 i w@ dup chain-end# <> if ( xt dn ch# )
927 chain-apply if ( ??? )
928 unloop true exit ( ??? found )
929 then ( xt dn )
930 else drop then ( xt dn )
931 /w +loop
932 false ( xt dn not-found )
933 ;
935 \ apply xt to every entry in fzap
936 : fzap-apply ( xt dn fz -- ??? not-found? )
938 \ blk# 1 is always the 1st leaf
939 >r 1 leaf-apply if ( ??? r: fz )
940 r> drop true exit ( ??? found )
941 then r> ( xt dn fz )
943 \ call leaf-apply on every non-duplicate hash entry
944 \ embedded hash is in 2nd half of fzap block
945 over dn-bsize tuck + ( xt dn bsize hash-eadr )
946 swap 2dup 2/ - ( xt dn hash-eadr bsize hash-adr )
947 nip do ( xt dn )
948 i x@ dup 1 <> if ( xt dn blk# )
949 leaf-apply if ( ??? )
950 unloop true exit ( ??? found )
951 then ( xt dn )
952 else drop then ( xt dn )
953 /x +loop
954 2drop false ( not-found )
955 ;
957 : mze_value ( uz -- n ) x@ ;
958 : mze_name ( uz -- p ) h# e + ;
960 : uzap-name$ ( uz -- name$ ) mze_name cscount ;
962 \ apply xt to each entry in micro-zap
963 : uzap-apply ( xt uz len -- ??? not-found? )
964 bounds do ( xt )
965 i swap dup >r ( uz xt r: xt )
966 execute if ( ??? r: xt )
967 r> drop ( ??? )
968 unloop true exit ( ??? found )
969 then r> ( xt )
970 /uzap +loop
971 drop false ( not-found )
972 ;
974 \ match by name
975 : fz-nmlook ( prop$ dn le -- prop$ false | prop$ dn le true )
976 2dup entry-name$ ( prop$ dn le name$ )
977 2rot 2swap ( dn le prop$ name$ )
978 2over $= if ( dn le prop$ )
979 2swap true ( prop$ dn le true )
980 else ( dn le prop$ )
981 2swap 2drop false ( prop$ false )
982 then ( prop$ false | prop$ dn le true )
983 ;
985 \ match by name
986 : uz-nmlook ( prop$ uz -- prop$ false | prop$ uz true )
987 dup >r uzap-name$ ( prop$ name$ r: uz )
988 2over $= if ( prop$ r: uz )
989 r> true ( prop$ uz true )
990 else ( prop$ r: uz )
991 r> drop false ( prop$ false )
992 then ( prop$ false | prop$ uz true )
993 ;
995 : zap-type ( zp -- n ) h# 7 + c@ ;
996 : >uzap-ent ( adr -- ent ) h# 40 + ;
998 \ read zap block into temp-space
999 : get-zap ( dn -- zp )
1000 dup 0 lblk#>bp ( dn bp )
1001 swap dn-bsize ( bp len )
1002 temp-space swap ( bp adr len )
1003 rot read-bp ( )
1004 temp-space ( zp )
1005 ;
1007 \ find prop in zap dnode
1008 : zap-lookup ( dn prop$ -- [ n ] not-found? )
1009 rot dup get-zap ( prop$ dn zp )
1010 dup zap-type case
1011 uzap# of
1012 >uzap-ent swap dn-bsize ( prop$ uz len )
1013 ['] uz-nmlook -rot ( prop$ xt uz len )
1014 uzap-apply if ( prop$ uz )
1015 mze_value -rot 2drop ( n )
1016 false ( n found )
1017 else ( prop$ )
1018 2drop true ( !found )
1019 then ( [ n ] not-found? )
1020 endof
1021 fzap# of
1022 ['] fz-nmlook -rot ( prop$ xt dn fz )
1023 fzap-apply if ( prop$ dn le )
1024 entry-int-val ( prop$ n )
1025 -rot 2drop false ( n found )
1026 else ( prop$ )
1027 2drop true ( !found )
1028 then ( [ n ] not-found? )
1029 endof
1030 3drop 2drop true ( !found )
1031 endcase ( [ n ] not-found? )
1032 ;
1034 [ifdef] strlookup
1035 : zap-lookup-str ( dn prop$ -- [ val$ ] not-found? )
1036 rot dup get-zap ( prop$ dn zp )
1037 dup zap-type fzap# <> if ( prop$ dn zp )
1038 2drop 2drop true exit ( !found )
1039 then ( prop$ dn zp )
1040 ['] fz-nmlook -rot ( prop$ xt dn fz )
1041 fzap-apply if ( prop$ dn le )
1042 entry-val$ 2swap 2drop false ( val$ found )
1043 else ( prop$ )
1044 2drop true ( !found )
1045 then ( [ val$ ] not-found? )
1046 ;
1047 [then]
1049 : fz-print ( dn le -- false )
1050 entry-name$ type cr false
1051 ;
1053 : uz-print ( uz -- false )
1054 uzap-name$ type cr false
1055 ;
1057 : zap-print ( dn -- )
1058 dup get-zap ( dn zp )
1059 dup zap-type case
1060 uzap# of
1061 >uzap-ent swap dn-bsize ( uz len )
1062 ['] uz-print -rot ( xt uz len )
1063 uzap-apply ( false )
1064 endof
1065 fzap# of
1066 ['] fz-print -rot ( xt dn fz )
1067 fzap-apply ( false )
1068 endof
1069 3drop false ( false )
1070 endcase ( false )
1071 drop ( )
1072 ;
1075 \
1076 \ ZFS object set (DSL) routines
1077 \
1079 1 constant pool-dir#
1081 : dd_head_dataset_obj ( dd -- n ) h# 8 + x@ ;
1082 : dd_child_dir_zapobj ( dd -- n ) h# 20 + x@ ;
1084 : ds_snapnames_zapobj ( ds -- n ) h# 20 + x@ ;
1085 : ds_bp ( ds -- p ) h# 80 + ;
1087 0 instance value mos-dn
1088 0 instance value obj-dir
1089 0 instance value root-dsl
1090 0 instance value fs-dn
1092 \ dn-cache contains dc-dn's contents at dc-blk#
1093 \ dc-dn will be either mos-dn or fs-dn
1094 0 instance value dn-cache
1095 0 instance value dc-dn
1096 0 instance value dc-blk#
1098 alias >dsl-dir dn_bonus
1099 alias >dsl-ds dn_bonus
1101 : #dn/blk ( dn -- n ) dn-bsize /dnode / ;
1103 \ read block into dn-cache
1104 : get-dnblk ( dn blk# -- )
1105 lblk#>bp dn-cache swap ( adr bp )
1106 dup bp-lsize swap read-bp ( )
1107 ;
1109 \ read obj# from objset dir dn into dnode
1110 : get-dnode ( dn obj# -- )
1112 \ check dn-cache
1113 2dup swap #dn/blk /mod ( dn obj# off# blk# )
1114 swap >r nip ( dn blk# r: off# )
1115 2dup dc-blk# <> ( dn blk# dn !blk-hit? r: off# )
1116 swap dc-dn <> or if ( dn blk# r: off# )
1117 \ cache miss, fill from dir
1118 2dup get-dnblk
1119 over to dc-dn
1120 dup to dc-blk#
1121 then ( dn blk# r: off# )
1123 \ index and copy
1124 2drop r> /dnode * ( off )
1125 dn-cache + ( dn-adr )
1126 dnode /dnode move ( )
1127 ;
1129 \ read meta object set from uber-block
1130 : get-mos ( -- )
1131 mos-dn uber-block ub_rootbp ( adr bp )
1132 dup bp-lsize swap read-bp
1133 ;
1135 : get-mos-dnode ( obj# -- )
1136 mos-dn swap get-dnode
1137 ;
1139 \ get root dataset
1140 : get-root-dsl ( -- )
1142 \ read MOS
1143 get-mos
1145 \ read object dir
1146 pool-dir# get-mos-dnode
1147 dnode obj-dir /dnode move
1149 \ read root dataset
1150 obj-dir " root_dataset" zap-lookup if
1151 " no root_dataset" die
1152 then ( obj# )
1153 get-mos-dnode ( )
1154 dnode root-dsl /dnode move
1155 ;
1157 \ find snapshot of given dataset
1158 : snap-look ( snap$ ds-obj# -- [ss-obj# ] not-found? )
1159 get-mos-dnode dnode >dsl-ds ( snap$ ds )
1160 ds_snapnames_zapobj get-mos-dnode ( snap$ )
1161 dnode -rot zap-lookup ( [ss-obj# ] not-found? )
1162 ;
1164 \ dsl dir to dataset
1165 : dir>ds ( dn -- obj# ) >dsl-dir dd_head_dataset_obj ;
1167 \ look thru the dsl hierarchy for path
1168 \ this looks almost exactly like a FS directory lookup
1169 : dsl-lookup ( path$ -- [ ds-obj# ] not-found? )
1170 root-dsl >r ( path$ r: root-dn )
1171 begin
1172 ascii / left-parse-string ( path$ file$ r: dn )
1173 dup while
1175 \ get child dir zap dnode
1176 r> >dsl-dir dd_child_dir_zapobj ( path$ file$ obj# )
1177 get-mos-dnode ( path$ file$ )
1179 \ check for snapshot names
1180 ascii @ left-parse-string ( path$ snap$ file$ )
1182 \ search it
1183 dnode -rot zap-lookup if ( path$ snap$ )
1184 \ not found
1185 2drop 2drop true exit ( not-found )
1186 then ( path$ snap$ obj# )
1187 get-mos-dnode ( path$ snap$ )
1189 \ lookup any snapshot name
1190 dup if
1191 \ must be last path component
1192 2swap nip if ( snap$ )
1193 2drop true exit ( not-found )
1194 then
1195 dnode dir>ds snap-look if ( )
1196 true exit ( not-found )
1197 then ( obj# )
1198 false exit ( obj# found )
1199 else 2drop then ( path$ )
1201 dnode >r ( path$ r: dn )
1202 repeat ( path$ file$ r: dn)
1203 2drop 2drop r> drop ( )
1205 \ found it, return dataset obj#
1206 dnode dir>ds ( ds-obj# )
1207 false ( ds-obj# found )
1208 ;
1210 \ get objset from dataset
1211 : get-objset ( adr dn -- )
1212 >dsl-ds ds_bp dup bp-lsize swap read-bp
1213 ;
1216 \
1217 \ ZFS file-system (ZPL) routines
1218 \
1220 1 constant master-node#
1222 0 instance value bootfs-obj#
1223 0 instance value root-obj#
1224 0 instance value current-obj#
1225 0 instance value search-obj#
1227 instance defer fsize ( dn -- size )
1228 instance defer mode ( dn -- mode )
1229 instance defer parent ( dn -- obj# )
1230 instance defer readlink ( dst dn -- )
1232 \
1233 \ routines when bonus pool contains a znode
1234 \
1235 d# 264 constant /znode
1236 d# 56 constant /zn-slink
1238 : zp_mode ( zn -- n ) h# 48 + x@ ;
1239 : zp_size ( zn -- n ) h# 50 + x@ ;
1240 : zp_parent ( zn -- n ) h# 58 + x@ ;
1242 alias >znode dn_bonus
1244 : zn-fsize ( dn -- n ) >znode zp_size ;
1245 : zn-mode ( dn -- n ) >znode zp_mode ;
1246 : zn-parent ( dn -- n ) >znode zp_parent ;
1248 \ copy symlink target to dst
1249 : zn-readlink ( dst dn -- )
1250 dup zn-fsize tuck /zn-slink > if ( dst size dn )
1251 \ contents in 1st block
1252 temp-space over dn-bsize ( dst size dn t-adr bsize )
1253 rot 0 lblk#>bp read-bp ( dst size )
1254 temp-space ( dst size src )
1255 else ( dst size dn )
1256 \ contents in dnode
1257 >znode /znode + ( dst size src )
1258 then ( dst size src )
1259 -rot move ( )
1260 ;
1262 \
1263 \ routines when bonus pool contains sa's
1264 \
1266 \ SA header size when link is in dn_bonus
1267 d# 16 constant /sahdr-link
1269 : sa_props ( sa -- n ) h# 4 + w@ ;
1271 : sa-hdrsz ( sa -- sz ) sa_props h# 7 >> ;
1273 alias >sa dn_bonus
1275 : >sadata ( dn -- adr ) >sa dup sa-hdrsz + ;
1276 : sa-mode ( dn -- n ) >sadata x@ ;
1277 : sa-fsize ( dn -- n ) >sadata h# 8 + x@ ;
1278 : sa-parent ( dn -- n ) >sadata h# 28 + x@ ;
1280 \ copy symlink target to dst
1281 : sa-readlink ( dst dn -- )
1282 dup >sa sa-hdrsz /sahdr-link <> if
1283 \ contents in 1st attr of dn_spill
1284 temp-space over dn_spill ( dst dn t-adr bp )
1285 dup bp-lsize swap read-bp ( dst dn )
1286 sa-fsize ( dst size )
1287 temp-space dup sa-hdrsz + ( dst size src )
1288 else ( dst dn )
1289 \ content in bonus buf
1290 dup dn_bonus over dn_bonuslen + ( dst dn ebonus )
1291 swap sa-fsize tuck - ( dst size src )
1292 then ( dst size src )
1293 -rot move ( )
1294 ;
1297 \ setup attr routines for dn
1298 : set-attr ( dn -- )
1299 dn_bonustype ot-sa# = if
1300 ['] sa-fsize to fsize
1301 ['] sa-mode to mode
1302 ['] sa-parent to parent
1303 ['] sa-readlink to readlink
1304 else
1305 ['] zn-fsize to fsize
1306 ['] zn-mode to mode
1307 ['] zn-parent to parent
1308 ['] zn-readlink to readlink
1309 then
1310 ;
1312 : ftype ( dn -- type ) mode h# f000 and ;
1313 : dir? ( dn -- flag ) ftype h# 4000 = ;
1314 : symlink? ( dn -- flag ) ftype h# a000 = ;
1316 \ read obj# from fs objset
1317 : get-fs-dnode ( obj# -- )
1318 dup to current-obj#
1319 fs-dn swap get-dnode ( )
1320 ;
1322 \ get root-obj# from dataset
1323 : get-rootobj# ( ds-obj# -- fsroot-obj# )
1324 dup to bootfs-obj#
1325 get-mos-dnode ( )
1326 fs-dn dnode get-objset
1328 \ get root obj# from master node
1329 master-node# get-fs-dnode
1330 dnode " ROOT" zap-lookup if
1331 " no ROOT" die
1332 then ( fsroot-obj# )
1333 ;
1335 : prop>rootobj# ( -- )
1336 obj-dir " pool_props" zap-lookup if
1337 " no pool_props" die
1338 then ( prop-obj# )
1339 get-mos-dnode ( )
1340 dnode " bootfs" zap-lookup if
1341 " no bootfs" die
1342 then ( ds-obj# )
1343 get-rootobj# ( fsroot-obj# )
1344 ;
1346 : fs>rootobj# ( fs$ -- root-obj# not-found? )
1348 \ skip pool name
1349 ascii / left-parse-string 2drop
1351 \ lookup fs in dsl
1352 dsl-lookup if ( )
1353 true exit ( not-found )
1354 then ( ds-obj# )
1356 get-rootobj# ( fsroot-obj# )
1357 false ( fsroot-obj# found )
1358 ;
1360 \ lookup file is current directory
1361 : dirlook ( file$ dn -- not-found? )
1362 \ . and .. are magic
1363 -rot 2dup " ." $= if ( dn file$ )
1364 3drop false exit ( found )
1365 then
1367 2dup " .." $= if
1368 2drop parent ( obj# )
1369 else ( dn file$ )
1370 \ search dir
1371 current-obj# to search-obj#
1372 zap-lookup if ( )
1373 true exit ( not-found )
1374 then ( obj# )
1375 then ( obj# )
1376 get-fs-dnode
1377 dnode set-attr
1378 false ( found )
1379 ;
1381 /buf-len instance buffer: fpath-buf
1382 /buf-len instance buffer: tpath-buf
1384 : tpath-buf$ ( -- path$ ) tpath-buf cscount ;
1385 : fpath-buf$ ( -- path$ ) fpath-buf cscount ;
1387 \ modify tail to account for symlink
1388 : follow-symlink ( tail$ -- tail$' )
1389 \ read target
1390 tpath-buf /buf-len erase
1391 tpath-buf dnode readlink
1393 \ append current path
1394 ?dup if ( tail$ )
1395 " /" tpath-buf$ $append ( tail$ )
1396 tpath-buf$ $append ( )
1397 else drop then ( )
1399 \ copy to fpath
1400 fpath-buf /buf-len erase
1401 tpath-buf$ fpath-buf swap move
1402 fpath-buf$ ( path$ )
1404 \ get directory that starts changed path
1405 over c@ ascii / = if ( path$ )
1406 str++ root-obj# ( path$' obj# )
1407 else ( path$ )
1408 search-obj# ( path$ obj# )
1409 then ( path$ obj# )
1410 get-fs-dnode ( path$ )
1411 dnode set-attr
1412 ;
1414 \ open dnode at path
1415 : lookup ( path$ -- not-found? )
1417 \ get directory that starts path
1418 over c@ ascii / = if
1419 str++ root-obj# ( path$' obj# )
1420 else
1421 current-obj# ( path$ obj# )
1422 then ( path$ obj# )
1423 get-fs-dnode ( path$ )
1424 dnode set-attr
1426 \ lookup each path component
1427 begin ( path$ )
1428 ascii / left-parse-string ( path$ file$ )
1429 dup while
1430 dnode dir? 0= if
1431 2drop true exit ( not-found )
1432 then ( path$ file$ )
1433 dnode dirlook if ( path$ )
1434 2drop true exit ( not-found )
1435 then ( path$ )
1436 dnode symlink? if
1437 follow-symlink ( path$' )
1438 then ( path$ )
1439 repeat ( path$ file$ )
1440 2drop 2drop false ( found )
1441 ;
1443 \
1444 \ ZFS volume (ZVOL) routines
1445 \
1446 1 constant zvol-data#
1447 2 constant zvol-prop#
1449 0 instance value zv-dn
1451 : get-zvol ( zvol$ -- not-found? )
1452 dsl-lookup if
1453 drop true exit ( failed )
1454 then ( ds-obj# )
1456 \ get zvol objset
1457 get-mos-dnode ( )
1458 zv-dn dnode get-objset
1459 false ( succeeded )
1460 ;
1462 \ get zvol data dnode
1463 : zvol-data ( -- )
1464 zv-dn zvol-data# get-dnode
1465 ;
1467 : zvol-size ( -- size )
1468 zv-dn zvol-prop# get-dnode
1469 dnode " size" zap-lookup if
1470 " no zvol size" die
1471 then ( size )
1472 ;
1475 \
1476 \ ZFS installation routines
1477 \
1479 \ ZFS file interface
1480 struct
1481 /x field >busy
1482 /x field >offset
1483 /x field >fsize
1484 /dnode field >dnode
1485 constant /file-record
1487 d# 10 constant #opens
1488 #opens /file-record * constant /file-records
1490 /file-records instance buffer: file-records
1492 -1 instance value current-fd
1494 : fd>record ( fd -- rec ) /file-record * file-records + ;
1495 : file-offset@ ( -- off ) current-fd fd>record >offset x@ ;
1496 : file-offset! ( off -- ) current-fd fd>record >offset x! ;
1497 : file-dnode ( -- dn ) current-fd fd>record >dnode ;
1498 : file-size ( -- size ) current-fd fd>record >fsize x@ ;
1499 : file-bsize ( -- bsize ) file-dnode dn-bsize ;
1501 \ find free fd slot
1502 : get-slot ( -- fd false | true )
1503 #opens 0 do
1504 i fd>record >busy x@ 0= if
1505 i false unloop exit
1506 then
1507 loop true
1508 ;
1510 : free-slot ( fd -- )
1511 0 swap fd>record >busy x!
1512 ;
1514 \ init fd to offset 0 and copy dnode
1515 : init-fd ( fsize fd -- )
1516 fd>record ( fsize rec )
1517 dup >busy 1 swap x!
1518 dup >dnode dnode swap /dnode move
1519 dup >fsize rot swap x! ( rec )
1520 >offset 0 swap x! ( )
1521 ;
1523 \ make fd current
1524 : set-fd ( fd -- error? )
1525 dup fd>record >busy x@ 0= if ( fd )
1526 drop true exit ( failed )
1527 then ( fd )
1528 to current-fd false ( succeeded )
1529 ;
1531 \ read next fs block
1532 : file-bread ( adr -- )
1533 file-bsize ( adr len )
1534 file-offset@ over / ( adr len blk# )
1535 file-dnode swap lblk#>bp ( adr len bp )
1536 read-bp ( )
1537 ;
1539 \ advance file io stack by n
1540 : fio+ ( # adr len n -- #+n adr+n len-n )
1541 dup file-offset@ + file-offset!
1542 dup >r - -rot ( len' # adr r: n )
1543 r@ + -rot ( adr' len' # r: n )
1544 r> + -rot ( #' adr' len' )
1545 ;
1548 /max-bsize 5 *
1549 /uber-block +
1550 /dnode 6 * +
1551 /disk-block 6 * + ( size )
1552 \ ugh - sg proms can't free 512k allocations
1553 \ that aren't a multiple of 512k in size
1554 h# 8.0000 roundup ( size' )
1555 constant alloc-size
1558 : allocate-buffers ( -- )
1559 alloc-size h# a0.0000 vmem-alloc dup 0= if
1560 " no memory" die
1561 then ( adr )
1562 dup to temp-space /max-bsize + ( adr )
1563 dup to dn-cache /max-bsize + ( adr )
1564 dup to blk-space /max-bsize + ( adr )
1565 dup to ind-cache /max-bsize + ( adr )
1566 dup to zap-space /max-bsize + ( adr )
1567 dup to uber-block /uber-block + ( adr )
1568 dup to mos-dn /dnode + ( adr )
1569 dup to obj-dir /dnode + ( adr )
1570 dup to root-dsl /dnode + ( adr )
1571 dup to fs-dn /dnode + ( adr )
1572 dup to zv-dn /dnode + ( adr )
1573 dup to dnode /dnode + ( adr )
1574 to gang-space ( )
1576 \ zero instance buffers
1577 file-records /file-records erase
1578 bootprop-buf /buf-len erase
1579 ;
1581 : release-buffers ( -- )
1582 temp-space alloc-size mem-free
1583 ;
1585 external
1587 : open ( -- okay? )
1588 my-args dev-open dup 0= if
1589 exit ( failed )
1590 then to dev-ih
1592 allocate-buffers
1593 scan-vdev
1594 get-ub
1595 get-root-dsl
1596 true
1597 ;
1599 : open-fs ( fs$ -- okay? )
1600 fs>rootobj# if ( )
1601 false ( failed )
1602 else ( obj# )
1603 to root-obj# true ( succeeded )
1604 then ( okay? )
1605 ;
1607 : close ( -- )
1608 dev-ih dev-close
1609 0 to dev-ih
1610 release-buffers
1611 ;
1613 : open-file ( path$ -- fd true | false )
1615 \ open default fs if no open-fs
1616 root-obj# 0= if
1617 prop>rootobj# to root-obj#
1618 then
1620 get-slot if
1621 2drop false exit ( failed )
1622 then -rot ( fd path$ )
1624 lookup if ( fd )
1625 drop false exit ( failed )
1626 then ( fd )
1628 dnode fsize over init-fd
1629 true ( fd succeeded )
1630 ;
1632 : open-volume ( vol$ -- okay? )
1633 get-slot if
1634 2drop false exit ( failed )
1635 then -rot ( fd vol$ )
1637 get-zvol if ( fd )
1638 drop false exit ( failed )
1639 then
1641 zvol-size over ( fd size fd )
1642 zvol-data init-fd ( fd )
1643 true ( fd succeeded )
1644 ;
1646 : close-file ( fd -- )
1647 free-slot ( )
1648 ;
1650 : size-file ( fd -- size )
1651 set-fd if 0 else file-size then
1652 ;
1654 : seek-file ( off fd -- off true | false )
1655 set-fd if ( off )
1656 drop false exit ( failed )
1657 then ( off )
1659 dup file-size x> if ( off )
1660 drop false exit ( failed )
1661 then ( off )
1662 dup file-offset! true ( off succeeded )
1663 ;
1665 : read-file ( adr len fd -- #read )
1666 set-fd if ( adr len )
1667 2drop 0 exit ( 0 )
1668 then ( adr len )
1670 \ adjust len if reading past eof
1671 dup file-offset@ + file-size x> if
1672 dup file-offset@ + file-size - -
1673 then
1674 dup 0= if nip exit then
1676 0 -rot ( #read adr len )
1678 \ initial partial block
1679 file-offset@ file-bsize mod ?dup if ( #read adr len off )
1680 temp-space file-bread
1681 2dup file-bsize swap - min ( #read adr len off cpy-len )
1682 2over drop -rot ( #read adr len adr off cpy-len )
1683 >r temp-space + swap ( #read adr len cpy-src adr r: cpy-len )
1684 r@ move r> fio+ ( #read' adr' len' )
1685 then ( #read adr len )
1687 dup file-bsize / 0 ?do ( #read adr len )
1688 over file-bread
1689 file-bsize fio+ ( #read' adr' len' )
1690 loop ( #read adr len )
1692 \ final partial block
1693 dup if ( #read adr len )
1694 temp-space file-bread
1695 2dup temp-space -rot move ( #read adr len )
1696 dup fio+ ( #read' adr' 0 )
1697 then 2drop ( #read )
1698 ;
1700 : cinfo-file ( fd -- bsize fsize comp? )
1701 set-fd if
1702 0 0 0
1703 else
1704 file-bsize file-size ( bsize fsize )
1705 \ zfs does internal compression
1706 0 ( bsize fsize comp? )
1707 then
1708 ;
1710 \ read ramdisk fcode at rd-offset
1711 : get-rd ( adr len -- )
1712 rd-offset dev-ih read-disk
1713 ;
1715 : bootprop
1716 " /" bootprop$ $append
1717 bootfs-obj# (xu.) bootprop$ $append
1718 bootprop$ encode-string " zfs-bootfs" ( propval propname )
1719 true
1720 ;
1723 : chdir ( dir$ -- )
1724 current-obj# -rot ( obj# dir$ )
1725 lookup if ( obj# )
1726 to current-obj# ( )
1727 ." no such dir" cr exit
1728 then ( obj# )
1729 dnode dir? 0= if ( obj# )
1730 to current-obj# ( )
1731 ." not a dir" cr exit
1732 then drop ( )
1733 ;
1735 : dir ( -- )
1736 current-obj# get-fs-dnode
1737 dnode zap-print
1738 ;
1740 finish-device
1741 pop-package