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>
26
27
28purpose: ZFS file system support package
29copyright: Copyright 2010 Sun Microsystems, Inc. All Rights Reserved
30
31" /packages" get-package  push-package
32
33new-device
34   fs-pkg$  device-name  diag-cr?
35
36   0 instance value temp-space
37
38
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  ;
62
63   /buf-len  instance buffer:  numbuf
64
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   ;
75
76   \ pool name
77   /buf-len  instance buffer:  bootprop-buf
78   : bootprop$  ( -- prop$ )  bootprop-buf cscount  ;
79
80   \ decompression
81   \
82   \ uts/common/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   \
103
104   : pow2  ( n -- 2**n )  1 swap lshift  ;
105
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
111
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   ;
117
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   ;
132
133
134   : lzjb ( src dst len -- )
135      over +  swap                  ( src dend dst )
136      rot >r                        ( dend dst  r: src )
137
138      \ setup mask so 1st while iteration fills map
139      0  7 pow2  2swap              ( map mask dend dst  r: src )
140
141      begin  2dup >  while
142         2swap  1 lshift            ( dend dst map mask'  r: src )
143
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' )
149
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   ;
162
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++ )
169
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    ;
178
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
186
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    ;
193
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    ;
203
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 )
214
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
238
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 )
244
245         2dup > if ( dest > cpy )
246            " lz4 overflow" die
247         then
248
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 )
259
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 )
263
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 )
268
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
273
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 )
278
279           r> + r> r> drop < if
280             " lz4 format violation" die		\ LZ4 format violation
281           then
282
283           r> drop		\ drop original dest
284           drop
285           exit			\ parsing done
286         then
287
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 )
290
291         lz4_copy		( dest_end length cpy dest s_buf)
292
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 )
297
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 )
306
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 )
313
314         2swap			( dest_end op ref length s_buf )
315         swap		( dest_end op ref s_buf length R: dest s_end token )
316
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 )
334
335         2swap			( dest_end s_buf length op ref )
336
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 )
369
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 )
374
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 )
378
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
392
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
408
409       -rot r>			( op dest_end s_buf s_end R: dest )
410     repeat
411
412     r> drop
413     2drop
414     2drop
415   ;
416
417   \
418   \	ZFS block (SPA) routines
419   \
420
421   1           constant  def-comp#
422   2           constant  no-comp#
423   3           constant  lzjb-comp#
424   d# 15       constant  lz4-comp#
425
426   h# 2.0000   constant  /max-bsize
427   d# 512      constant  /disk-block
428   d# 128      constant  /blkp
429
430   alias  /gang-block  /disk-block
431
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
436
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@  ;
445
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+ ;
448
449   0 instance value dev-ih
450   0 instance value blk-space
451   0 instance value gang-space
452
453   : foff>doff  ( fs-off -- disk-off )    /disk-block *  h# 40.0000 +  ;
454   : fsz>dsz    ( fs-size -- disk-size )  1+  /disk-block *  ;
455
456   : bp-dsize  ( bp -- dsize )
457      dup blk_embedded? if
458         blke_psize
459      else
460         blk_psize fsz>dsz
461      then
462   ;
463
464   : bp-lsize  ( bp -- lsize )
465      dup blk_embedded? if
466         blke_lsize
467      else
468         blk_lsize fsz>dsz
469      then
470   ;
471
472   : (read-dva)  ( adr len dva -- )
473      blk_offset foff>doff  dev-ih  read-disk
474   ;
475
476   : gang-read  ( adr len bp gb-adr -- )    tokenizer[ reveal ]tokenizer
477
478      \ read gang block
479      tuck  /gang-block rot  (read-dva)   ( adr len gb-adr )
480
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
485
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 )
489
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 )
500
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   ;
509
510   : read-dva  ( adr len dva -- )
511      dup  blk_gang  if
512         gang-space  gang-read
513      else
514         (read-dva)
515      then
516   ;
517
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 )
548
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   ;
557
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
567
568      \ no compression?
569      dup blk_comp  no-comp#  =  if
570         read-dva  exit                  (  )
571      then
572
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
581
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 )
585
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   ;
595
596   \
597   \    ZFS vdev routines
598   \
599
600   h# 1.c000  constant /nvpairs
601   h# 4000    constant nvpairs-off
602
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
618
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   ;
626
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
634
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   ;
647
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   ;
662
663
664   \
665   \	ZFS ueber-block routines
666   \
667
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
672
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 +     ;
677
678   0 instance value uber-block
679
680   : ub-cmp  ( ub1 ub2 -- best-ub )
681
682      \ ub1 wins if ub2 isn't valid
683      dup  ub_magic h# 00bab10c  x<>  if
684         drop  exit                  ( ub1 )
685      then
686
687      \ if ub1 is 0, ub2 wins by default
688      over 0=  if  nip  exit  then   ( ub2 )
689
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 )
696
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   ;
704
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
713
714      \ make sure we found a valid ub
715      dup 0=  if  " no ub found" die  then
716
717      uber-block /uber-block  move          (  )
718   ;
719
720
721   \
722   \	ZFS dnode (DMU) routines
723   \
724
725   d# 44  constant ot-sa#
726
727   d# 512 constant /dnode
728
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 +      ;
737
738   0 instance value dnode
739
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
756
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-  ;
760
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 )
764
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 )
770
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 )
774
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   ;
781
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   ;
792
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   ;
808
809
810   \
811   \	ZFS attribute (ZAP) routines
812   \
813
814   1        constant  fzap#
815   3        constant  uzap#
816
817   d# 64    constant  /uzap
818
819   d# 24    constant  /lf-chunk
820   d# 21    constant  /lf-arr
821   h# ffff  constant  chain-end#
822
823   h# 100   constant /lf-buf
824   /lf-buf  instance buffer: leaf-value
825   /lf-buf  instance buffer: leaf-name
826
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  ;
833
834   : la_array  ( la -- adr )  1+  ;
835   : la_next   ( la -- n )    h# 16 +  w@  ;
836
837   0 instance value zap-space
838
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 +  ;
846
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   ;
853
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   ;
865
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   ;
873
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   ;
880
881
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]
891
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   ;
901
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   ;
914
915   \ apply xt to every entry in leaf
916   : leaf-apply  ( xt dn blk# -- xt dn false  |  ??? true )
917
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 )
922
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   ;
934
935   \ apply xt to every entry in fzap
936   : fzap-apply  ( xt dn fz -- ??? not-found? )
937
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 )
942
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   ;
956
957   : mze_value  ( uz -- n )  x@  ;
958   : mze_name   ( uz -- p )  h# e +  ;
959
960   : uzap-name$  ( uz -- name$ )  mze_name  cscount  ;
961
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   ;
973
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   ;
984
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   ;
994
995   : zap-type   ( zp -- n )     h#  7 + c@  ;
996   : >uzap-ent  ( adr -- ent )  h# 40 +  ;
997
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   ;
1006
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   ;
1033
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]
1048
1049   : fz-print  ( dn le -- false )
1050      entry-name$  type cr  false
1051   ;
1052
1053   : uz-print  ( uz -- false )
1054      uzap-name$  type cr  false
1055   ;
1056
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   ;
1073
1074
1075   \
1076   \	ZFS object set (DSL) routines
1077   \
1078
1079   1 constant pool-dir#
1080
1081   : dd_head_dataset_obj  ( dd -- n )  h#  8 +  x@  ;
1082   : dd_child_dir_zapobj  ( dd -- n )  h# 20 +  x@  ;
1083
1084   : ds_snapnames_zapobj  ( ds -- n )  h# 20 +  x@  ;
1085   : ds_bp                ( ds -- p )  h# 80 +      ;
1086
1087   0 instance value mos-dn
1088   0 instance value obj-dir
1089   0 instance value root-dsl
1090   0 instance value fs-dn
1091
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#
1097
1098   alias  >dsl-dir  dn_bonus
1099   alias  >dsl-ds   dn_bonus
1100
1101   : #dn/blk  ( dn -- n )     dn-bsize /dnode  /  ;
1102
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   ;
1108
1109   \ read obj# from objset dir dn into dnode
1110   : get-dnode  ( dn obj# -- )
1111
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# )
1122
1123      \ index and copy
1124      2drop r>  /dnode *             ( off )
1125      dn-cache +                     ( dn-adr )
1126      dnode  /dnode  move            (  )
1127   ;
1128
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   ;
1134
1135   : get-mos-dnode  ( obj# -- )
1136      mos-dn swap  get-dnode
1137   ;
1138
1139   \ get root dataset
1140   : get-root-dsl  ( -- )
1141
1142      \ read MOS
1143      get-mos
1144
1145      \ read object dir
1146      pool-dir#  get-mos-dnode
1147      dnode obj-dir  /dnode  move
1148
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   ;
1156
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   ;
1163
1164   \ dsl dir to dataset
1165   : dir>ds   ( dn -- obj# )  >dsl-dir dd_head_dataset_obj  ;
1166
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
1174
1175         \ get child dir zap dnode
1176         r>  >dsl-dir dd_child_dir_zapobj         ( path$ file$ obj# )
1177         get-mos-dnode                            ( path$ file$ )
1178
1179         \ check for snapshot names
1180         ascii @  left-parse-string               ( path$ snap$ file$ )
1181
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$ )
1188
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$ )
1200
1201         dnode >r                                 ( path$  r: dn )
1202      repeat                                      ( path$ file$  r: dn)
1203      2drop 2drop  r> drop                        (  )
1204
1205      \ found it, return dataset obj#
1206      dnode  dir>ds                               ( ds-obj# )
1207      false                                       ( ds-obj# found )
1208   ;
1209
1210   \ get objset from dataset
1211   : get-objset  ( adr dn -- )
1212      >dsl-ds ds_bp  dup bp-lsize swap  read-bp
1213   ;
1214
1215
1216   \
1217   \	ZFS file-system (ZPL) routines
1218   \
1219
1220   1       constant master-node#
1221
1222   0 instance value bootfs-obj#
1223   0 instance value root-obj#
1224   0 instance value current-obj#
1225   0 instance value search-obj#
1226
1227   instance defer fsize         ( dn -- size )
1228   instance defer mode          ( dn -- mode )
1229   instance defer parent        ( dn -- obj# )
1230   instance defer readlink      ( dst dn -- )
1231
1232   \
1233   \ routines when bonus pool contains a znode
1234   \
1235   d# 264  constant /znode
1236   d#  56  constant /zn-slink
1237
1238   : zp_mode    ( zn -- n )  h# 48 +  x@  ;
1239   : zp_size    ( zn -- n )  h# 50 +  x@  ;
1240   : zp_parent  ( zn -- n )  h# 58 +  x@  ;
1241
1242   alias  >znode  dn_bonus
1243
1244   : zn-fsize     ( dn -- n )  >znode zp_size    ;
1245   : zn-mode      ( dn -- n )  >znode zp_mode    ;
1246   : zn-parent    ( dn -- n )  >znode zp_parent  ;
1247
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   ;
1261
1262   \
1263   \ routines when bonus pool contains sa's
1264   \
1265
1266   \ SA header size when link is in dn_bonus
1267   d# 16  constant  /sahdr-link
1268
1269   : sa_props  ( sa -- n )   h# 4 +  w@  ;
1270
1271   : sa-hdrsz  ( sa -- sz )  sa_props h# 7  >>  ;
1272
1273   alias  >sa  dn_bonus
1274
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@  ;
1279
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   ;
1295
1296
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   ;
1311
1312   : ftype     ( dn -- type )  mode   h# f000  and  ;
1313   : dir?      ( dn -- flag )  ftype  h# 4000  =  ;
1314   : symlink?  ( dn -- flag )  ftype  h# a000  =  ;
1315
1316   \ read obj# from fs objset
1317   : get-fs-dnode  ( obj# -- )
1318      dup to current-obj#
1319      fs-dn swap  get-dnode    (  )
1320   ;
1321
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
1327
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   ;
1334
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   ;
1345
1346   : fs>rootobj#  ( fs$ -- root-obj# not-found? )
1347
1348      \ skip pool name
1349      ascii /  left-parse-string  2drop
1350
1351      \ lookup fs in dsl
1352      dsl-lookup  if                   (  )
1353         true  exit                    ( not-found )
1354      then                             ( ds-obj# )
1355
1356      get-rootobj#                     ( fsroot-obj# )
1357      false                            ( fsroot-obj# found )
1358   ;
1359
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
1366
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   ;
1380
1381   /buf-len  instance buffer: fpath-buf
1382   /buf-len  instance buffer: tpath-buf
1383
1384   : tpath-buf$  ( -- path$ )  tpath-buf cscount  ;
1385   : fpath-buf$  ( -- path$ )  fpath-buf cscount  ;
1386
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
1392
1393      \ append current path
1394      ?dup  if                                  ( tail$ )
1395	 " /" tpath-buf$  $append               ( tail$ )
1396	 tpath-buf$  $append                    (  )
1397      else  drop  then                          (  )
1398
1399      \ copy to fpath
1400      fpath-buf  /buf-len  erase
1401      tpath-buf$  fpath-buf  swap move
1402      fpath-buf$                                ( path$ )
1403
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   ;
1413
1414   \ open dnode at path
1415   : lookup  ( path$ -- not-found? )
1416
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
1425
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   ;
1442
1443   \
1444   \   ZFS volume (ZVOL) routines
1445   \
1446   1 constant  zvol-data#
1447   2 constant  zvol-prop#
1448
1449   0 instance value zv-dn
1450
1451   : get-zvol  ( zvol$ -- not-found? )
1452      dsl-lookup  if
1453         drop true  exit           ( failed )
1454      then                         ( ds-obj# )
1455
1456      \ get zvol objset
1457      get-mos-dnode                (  )
1458      zv-dn dnode  get-objset
1459      false                        ( succeeded )
1460   ;
1461
1462   \ get zvol data dnode
1463   : zvol-data  ( -- )
1464      zv-dn zvol-data#  get-dnode
1465   ;
1466
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   ;
1473
1474
1475   \
1476   \	ZFS installation routines
1477   \
1478
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
1486
1487   d# 10                  constant #opens
1488   #opens /file-record *  constant /file-records
1489
1490   /file-records  instance buffer: file-records
1491
1492   -1 instance value current-fd
1493
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  ;
1500
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   ;
1509
1510   : free-slot  ( fd -- )
1511      0 swap  fd>record >busy  x!
1512   ;
1513
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   ;
1522
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   ;
1530
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   ;
1538
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   ;
1546
1547
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
1556
1557
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                   (  )
1575
1576      \ zero instance buffers
1577      file-records /file-records  erase
1578      bootprop-buf /buf-len  erase
1579   ;
1580
1581   : release-buffers  ( -- )
1582      temp-space  alloc-size  mem-free
1583   ;
1584
1585   external
1586
1587   : open ( -- okay? )
1588      my-args dev-open  dup 0=  if
1589         exit                       ( failed )
1590      then  to dev-ih
1591
1592      allocate-buffers
1593      scan-vdev
1594      get-ub
1595      get-root-dsl
1596      true
1597   ;
1598
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   ;
1606
1607   : close  ( -- )
1608      dev-ih dev-close
1609      0 to dev-ih
1610      release-buffers
1611   ;
1612
1613   : open-file  ( path$ -- fd true | false )
1614
1615      \ open default fs if no open-fs
1616      root-obj# 0=  if
1617         prop>rootobj#  to root-obj#
1618      then
1619
1620      get-slot  if
1621         2drop false  exit         ( failed )
1622      then  -rot                   ( fd path$ )
1623
1624      lookup  if                   ( fd )
1625         drop false  exit          ( failed )
1626      then                         ( fd )
1627
1628      dnode fsize  over init-fd
1629      true                         ( fd succeeded )
1630   ;
1631
1632   : open-volume ( vol$ -- okay? )
1633      get-slot  if
1634         2drop false  exit         ( failed )
1635      then  -rot                   ( fd vol$ )
1636
1637      get-zvol  if                 ( fd )
1638         drop false  exit          ( failed )
1639      then
1640
1641      zvol-size over               ( fd size fd )
1642      zvol-data init-fd            ( fd )
1643      true                         ( fd succeeded )
1644   ;
1645
1646   : close-file  ( fd -- )
1647      free-slot   (  )
1648   ;
1649
1650   : size-file  ( fd -- size )
1651      set-fd  if  0  else  file-size  then
1652   ;
1653
1654   : seek-file  ( off fd -- off true | false )
1655      set-fd  if                ( off )
1656         drop false  exit       ( failed )
1657      then                      ( off )
1658
1659      dup file-size x>  if      ( off )
1660         drop false  exit       ( failed )
1661      then                      ( off )
1662      dup  file-offset!  true   ( off succeeded )
1663   ;
1664
1665   : read-file  ( adr len fd -- #read )
1666      set-fd  if                   ( adr len )
1667         2drop 0  exit             ( 0 )
1668      then                         ( adr len )
1669
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
1675
1676      0 -rot                              ( #read adr len )
1677
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 )
1686
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 )
1691
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   ;
1699
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   ;
1709
1710   \ read ramdisk fcode at rd-offset
1711   : get-rd   ( adr len -- )
1712      rd-offset dev-ih  read-disk
1713   ;
1714
1715   : bootprop
1716      " /"  bootprop$  $append
1717      bootfs-obj# (xu.)  bootprop$  $append
1718      bootprop$  encode-string  " zfs-bootfs"   ( propval propname )
1719      true
1720   ;
1721
1722
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   ;
1734
1735   : dir  ( -- )
1736      current-obj# get-fs-dnode
1737      dnode zap-print
1738   ;
1739
1740finish-device
1741pop-package
1742