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 26 27purpose: ZFS file system support package 28copyright: Copyright 2010 Sun Microsystems, Inc. All Rights Reserved 29 30" /packages" get-package push-package 31 32new-device 33 fs-pkg$ device-name diag-cr? 34 35 0 instance value temp-space 36 37 38 \ 64b ops 39 \ fcode is still 32b on 64b sparc-v9, so 40 \ we need to override some arithmetic ops 41 \ stack ops and logical ops (dup, and, etc) are 64b 42 : xcmp ( x1 x2 -- -1|0|1 ) 43 xlsplit rot xlsplit ( x2.lo x2.hi x1.lo x1.hi ) 44 rot 2dup u< if ( x2.lo x1.lo x1.hi x2.hi ) 45 2drop 2drop -1 ( lt ) 46 else u> if ( x2.lo x1.lo ) 47 2drop 1 ( gt ) 48 else swap 2dup u< if ( x1.lo x2.lo ) 49 2drop -1 ( lt ) 50 else u> if ( ) 51 1 ( gt ) 52 else ( ) 53 0 ( eq ) 54 then then then then ( -1|0|1 ) 55 ; 56 : x< ( x1 x2 -- <? ) xcmp -1 = ; 57 : x> ( x1 x2 -- >? ) xcmp 1 = ; 58\ : x= ( x1 x2 -- =? ) xcmp 0= ; 59 : x<> ( x1 x2 -- <>? ) xcmp 0<> ; 60 : x0= ( x -- 0=? ) xlsplit 0= swap 0= and ; 61 62 /buf-len instance buffer: numbuf 63 64 : (xu.) ( u -- u$ ) 65 numbuf /buf-len + swap ( adr u ) 66 begin 67 d# 10 /mod swap ( adr u' rem ) 68 ascii 0 + ( adr u' c ) 69 rot 1- tuck c! ( u adr' ) 70 swap dup 0= ( adr u done? ) 71 until drop ( adr ) 72 dup numbuf - /buf-len swap - ( adr len ) 73 ; 74 75 \ pool name 76 /buf-len instance buffer: bootprop-buf 77 : bootprop$ ( -- prop$ ) bootprop-buf cscount ; 78 79 \ decompression 80 \ 81 \ uts/common/os/compress.c has a definitive theory of operation comment 82 \ on lzjb, but here's the reader's digest version: 83 \ 84 \ repeated phrases are replaced by referenced to the original 85 \ e.g., 86 \ 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 87 \ becomes 88 \ y a d d a _ 6 11 , _ b l a h 5 10 89 \ where 6 11 means memmove(ptr, ptr - 6, 11) 90 \ 91 \ data is separated from metadata with embedded copymap entries 92 \ every 8 items e.g., 93 \ 0x40 y a d d a _ 6 11 , 0x20 _ b l a h 5 10 94 \ the copymap has a set bit for copy refercences 95 \ and a clear bit for bytes to be copied directly 96 \ 97 \ the reference marks are encoded with match-bits and match-min 98 \ e.g., 99 \ byte[0] = ((mlen - MATCH_MIN) << (NBBY - MATCH_BITS) | (off >> NBBY) 100 \ byte[1] = (uint8_t)off 101 \ 102 103 : pow2 ( n -- 2**n ) 1 swap lshift ; 104 105 \ assume MATCH_BITS=6 and MATCH_MIN=3 106 6 constant mbits 107 3 constant mmin 108 8 mbits - constant mshift 109 d# 16 mbits - pow2 1- constant mmask 110 111 : decode-src ( src -- mlen off ) 112 dup c@ swap 1+ c@ ( c[0] c[1] ) 113 over mshift rshift mmin + ( c[0] c[1] mlen ) 114 -rot swap bwjoin mmask and ( mlen off ) 115 ; 116 117 \ equivalent of memmove(dst, dst - off, len) 118 \ src points to a copy reference to be decoded 119 : mcopy ( dend dst src -- dend dst' ) 120 decode-src ( dend dst mlen off ) 121 2 pick swap - >r ( dent dst mlen r: cpy ) 122 begin 123 1- dup 0>= ( dend dst mlen' any? r: cpy ) 124 2over > and ( dend dst mlen !done? r : cpy ) 125 while ( dend dst mlen r: cpy ) 126 swap r> dup 1+ >r c@ ( dend mlen dst c r: cpy' ) 127 over c! 1+ swap ( dend dst' mlen r: cpy ) 128 repeat ( dend dst' mlen r: cpy ) 129 r> 2drop ( dend dst ) 130 ; 131 132 133 : lzjb ( src dst len -- ) 134 over + swap ( src dend dst ) 135 rot >r ( dend dst r: src ) 136 137 \ setup mask so 1st while iteration fills map 138 0 7 pow2 2swap ( map mask dend dst r: src ) 139 140 begin 2dup > while 141 2swap 1 lshift ( dend dst map mask' r: src ) 142 143 dup 8 pow2 = if 144 \ fetch next copymap 145 2drop ( dend dst r: src ) 146 r> dup 1+ >r c@ 1 ( dend dst map' mask' r: src' ) 147 then ( dend dst map mask r: src' ) 148 149 \ if (map & mask) we hit a copy reference 150 \ else just copy 1 byte 151 2swap 2over and if ( map mask dend dst r: src ) 152 r> dup 2+ >r ( map mask dend dst src r: src' ) 153 mcopy ( map mask dend dst' r: src ) 154 else 155 r> dup 1+ >r c@ ( map mask dend dst c r: src' ) 156 over c! 1+ ( map mask dend dst' r: src ) 157 then 158 repeat ( map mask dend dst r: src ) 159 2drop 2drop r> drop ( ) 160 ; 161 162 163 \ 164 \ ZFS block (SPA) routines 165 \ 166 167 1 constant def-comp# 168 2 constant no-comp# 169 3 constant lzjb-comp# 170 171 h# 2.0000 constant /max-bsize 172 d# 512 constant /disk-block 173 d# 128 constant /blkp 174 175 alias /gang-block /disk-block 176 177 \ the ending checksum is larger than 1 byte, but that 178 \ doesn't affect the math here 179 /gang-block 1- 180 /blkp / constant #blks/gang 181 182 : blk_offset ( bp -- n ) h# 8 + x@ -1 h# 7fff.ffff lxjoin and ; 183 : blk_gang ( bp -- n ) h# 8 + x@ xlsplit nip d# 31 rshift ; 184 : blk_comp ( bp -- n ) h# 33 + c@ ; 185 : blk_psize ( bp -- n ) h# 34 + w@ ; 186 : blk_lsize ( bp -- n ) h# 36 + w@ ; 187 : blk_birth ( bp -- n ) h# 50 + x@ ; 188 189 0 instance value dev-ih 190 0 instance value blk-space 191 0 instance value gang-space 192 193 : foff>doff ( fs-off -- disk-off ) /disk-block * h# 40.0000 + ; 194 : fsz>dsz ( fs-size -- disk-size ) 1+ /disk-block * ; 195 196 : bp-dsize ( bp -- dsize ) blk_psize fsz>dsz ; 197 : bp-lsize ( bp -- lsize ) blk_lsize fsz>dsz ; 198 199 : (read-dva) ( adr len dva -- ) 200 blk_offset foff>doff dev-ih read-disk 201 ; 202 203 : gang-read ( adr len bp gb-adr -- ) tokenizer[ reveal ]tokenizer 204 205 \ read gang block 206 tuck /gang-block rot (read-dva) ( adr len gb-adr ) 207 208 \ loop through indirected bp's 209 dup /blkp #blks/gang * ( adr len gb-adr bp-list bp-list-len ) 210 bounds do ( adr len gb-adr ) 211 i blk_offset x0= ?leave 212 213 \ calc subordinate read len 214 over i bp-dsize min ( adr len gb-adr sub-len ) 215 2swap swap ( gb-adr sub-len len adr ) 216 217 \ nested gang block - recurse with new gang block area 218 i blk_gang if 219 2swap ( len adr gb-adr sub-len ) 220 3dup swap /gang-block + ( len adr gb-adr sub-len adr sub-len gb-adr' ) 221 i swap gang-read ( len adr gb-adr sub-len ) 222 2swap ( gb-adr sub-len len adr ) 223 else 224 3dup nip swap ( gb-adr sub-len len adr adr sub-len ) 225 i (read-dva) ( gb-adr sub-len len adr ) 226 then ( gb-adr sub-len len adr ) 227 228 \ adjust adr,len and check if done 229 -rot over - ( gb-adr adr sub-len len' ) 230 -rot + swap ( gb-adr adr' len' ) 231 dup 0= ?leave 232 rot ( adr' len' gb-adr ) 233 /blkp +loop 234 3drop ( ) 235 ; 236 237 : read-dva ( adr len dva -- ) 238 dup blk_gang if 239 gang-space gang-read 240 else 241 (read-dva) 242 then 243 ; 244 245 \ block read that check for holes, gangs, compression, etc 246 : read-bp ( adr len bp -- ) 247 \ sparse block? 248 dup blk_birth x0= if 249 drop erase exit ( ) 250 then 251 252 \ no compression? 253 dup blk_comp no-comp# = if 254 read-dva exit ( ) 255 then 256 257 \ only do lzjb 258 dup blk_comp dup lzjb-comp# <> ( adr len bp comp lzjb? ) 259 swap def-comp# <> and if ( adr len bp ) 260 " only lzjb supported" die 261 then 262 263 \ read into blk-space and de-compress 264 blk-space over bp-dsize ( adr len bp blk-adr rd-len ) 265 rot read-dva ( adr len ) 266 blk-space -rot lzjb ( ) 267 ; 268 269 \ 270 \ ZFS vdev routines 271 \ 272 273 h# 1.c000 constant /nvpairs 274 h# 4000 constant nvpairs-off 275 276 \ 277 \ xdr packed nvlist 278 \ 279 \ 12B header 280 \ array of xdr packed nvpairs 281 \ 4B encoded nvpair size 282 \ 4B decoded nvpair size 283 \ 4B name string size 284 \ name string 285 \ 4B data type 286 \ 4B # of data elements 287 \ data 288 \ 8B of 0 289 \ 290 d# 12 constant /nvhead 291 292 : >nvsize ( nv -- size ) l@ ; 293 : >nvname ( nv -- name$ ) 294 /l 2* + dup /l + swap l@ 295 ; 296 : >nvdata ( nv -- data ) 297 >nvname + /l roundup 298 ; 299 300 \ convert nvdata to 64b int or string 301 : nvdata>x ( nvdata -- x ) 302 /l 2* + ( ptr ) 303 dup /l + l@ swap l@ ( x.lo x.hi ) 304 lxjoin ( x ) 305 ; 306 alias nvdata>$ >nvname 307 308 : nv-lookup ( nv name$ -- nvdata false | true ) 309 rot /nvhead + ( name$ nvpair ) 310 begin dup >nvsize while 311 dup >r >nvname ( name$ nvname$ r: nvpair ) 312 2over $= if ( name$ r: nvpair ) 313 2drop r> >nvdata ( nvdata ) 314 false exit ( nvdata found ) 315 then ( name$ r: nvpair ) 316 r> dup >nvsize + ( name$ nvpair' ) 317 repeat 318 3drop true ( not-found ) 319 ; 320 321 : scan-vdev ( -- ) 322 temp-space /nvpairs nvpairs-off ( adr len off ) 323 dev-ih read-disk ( ) 324 temp-space " txg" nv-lookup if 325 " no txg nvpair" die 326 then nvdata>x ( txg ) 327 x0= if 328 " detached mirror" die 329 then ( ) 330 temp-space " name" nv-lookup if 331 " no name nvpair" die 332 then nvdata>$ ( pool$ ) 333 bootprop-buf swap move ( ) 334 ; 335 336 337 \ 338 \ ZFS ueber-block routines 339 \ 340 341 d# 1024 constant /uber-block 342 d# 128 constant #ub/label 343 #ub/label /uber-block * constant /ub-ring 344 h# 2.0000 constant ubring-off 345 346 : ub_magic ( ub -- n ) x@ ; 347 : ub_txg ( ub -- n ) h# 10 + x@ ; 348 : ub_timestamp ( ub -- n ) h# 20 + x@ ; 349 : ub_rootbp ( ub -- p ) h# 28 + ; 350 351 0 instance value uber-block 352 353 : ub-cmp ( ub1 ub2 -- best-ub ) 354 355 \ ub1 wins if ub2 isn't valid 356 dup ub_magic h# 00bab10c x<> if 357 drop exit ( ub1 ) 358 then 359 360 \ if ub1 is 0, ub2 wins by default 361 over 0= if nip exit then ( ub2 ) 362 363 \ 2 valid ubs, compare transaction groups 364 over ub_txg over ub_txg ( ub1 ub2 txg1 txg2 ) 365 2dup x< if 366 2drop nip exit ( ub2 ) 367 then ( ub1 ub2 txg1 txg2 ) 368 x> if drop exit then ( ub1 ) 369 370 \ same txg, check timestamps 371 over ub_timestamp over ub_timestamp x> if 372 nip ( ub2 ) 373 else 374 drop ( ub1 ) 375 then 376 ; 377 378 \ find best uber-block in ring, and copy it to uber-block 379 : get-ub ( -- ) 380 temp-space /ub-ring ubring-off ( adr len off ) 381 dev-ih read-disk ( ) 382 0 temp-space /ub-ring ( null-ub adr len ) 383 bounds do ( ub ) 384 i ub-cmp ( best-ub ) 385 /uber-block +loop 386 387 \ make sure we found a valid ub 388 dup 0= if " no ub found" die then 389 390 uber-block /uber-block move ( ) 391 ; 392 393 394 \ 395 \ ZFS dnode (DMU) routines 396 \ 397 398 d# 44 constant ot-sa# 399 400 d# 512 constant /dnode 401 402 : dn_indblkshift ( dn -- n ) h# 1 + c@ ; 403 : dn_nlevels ( dn -- n ) h# 2 + c@ ; 404 : dn_bonustype ( dn -- n ) h# 4 + c@ ; 405 : dn_datablkszsec ( dn -- n ) h# 8 + w@ ; 406 : dn_bonuslen ( dn -- n ) h# a + w@ ; 407 : dn_blkptr ( dn -- p ) h# 40 + ; 408 : dn_bonus ( dn -- p ) h# c0 + ; 409 : dn_spill ( dn -- p ) h# 180 + ; 410 411 0 instance value dnode 412 413 \ indirect cache 414 \ 415 \ ind-cache is a 1 block indirect block cache from dnode ic-dn 416 \ 417 \ ic-bp and ic-bplim point into the ic-dn's block ptr array, 418 \ either in dn_blkptr or in ind-cache ic-bp is the ic-blk#'th 419 \ block ptr, and ic-bplim is limit of the current bp array 420 \ 421 \ the assumption is that reads will be sequential, so we can 422 \ just increment ic-bp 423 \ 424 0 instance value ind-cache 425 0 instance value ic-dn 426 0 instance value ic-blk# 427 0 instance value ic-bp 428 0 instance value ic-bplim 429 430 : dn-bsize ( dn -- bsize ) dn_datablkszsec /disk-block * ; 431 : dn-indsize ( dn -- indsize ) dn_indblkshift pow2 ; 432 : dn-indmask ( dn -- mask ) dn-indsize 1- ; 433 434 \ recursively climb the block tree from the leaf to the root 435 : blk@lvl>bp ( dn blk# lvl -- bp ) tokenizer[ reveal ]tokenizer 436 >r /blkp * over dn_nlevels ( dn bp-off #lvls r: lvl ) 437 438 \ at top, just add dn_blkptr 439 r@ = if ( dn bp-off r: lvl ) 440 swap dn_blkptr + ( bp r: lvl ) 441 r> drop exit ( bp ) 442 then ( dn bp-off r: lvl ) 443 444 \ shift bp-off down and find parent indir blk 445 2dup over dn_indblkshift rshift ( dn bp-off dn blk# r: lvl ) 446 r> 1+ blk@lvl>bp ( dn bp-off bp ) 447 448 \ read parent indir blk and index 449 rot tuck dn-indsize ( bp-off dn bp len ) 450 ind-cache swap rot read-bp ( bp-off dn ) 451 dn-indmask and ( bp-off' ) 452 ind-cache + ( bp ) 453 ; 454 455 \ return end of current bp array 456 : bplim ( dn bp -- bp-lim ) 457 over dn_nlevels 1 = if 458 drop dn_blkptr ( bp0 ) 459 3 /blkp * + ( bplim ) 460 else 461 1+ swap dn-indsize ( bp+1 indsz ) 462 roundup ( bplim ) 463 then 464 ; 465 466 \ return the lblk#'th block ptr from dnode 467 : lblk#>bp ( dn blk# -- bp ) 468 2dup ( dn blk# dn blk# ) 469 ic-blk# <> swap ic-dn <> or ( dn blk# cache-miss? ) 470 ic-bp ic-bplim = ( dn blk# cache-miss? cache-empty? ) 471 or if ( dn blk# ) 472 2dup 1 blk@lvl>bp ( dn blk# bp ) 473 dup to ic-bp ( dn blk# bp ) 474 swap to ic-blk# ( dn bp ) 475 2dup bplim to ic-bplim ( dn bp ) 476 over to ic-dn 477 then 2drop ( ) 478 ic-blk# 1+ to ic-blk# 479 ic-bp dup /blkp + to ic-bp ( bp ) 480 ; 481 482 483 \ 484 \ ZFS attribute (ZAP) routines 485 \ 486 487 1 constant fzap# 488 3 constant uzap# 489 490 d# 64 constant /uzap 491 492 d# 24 constant /lf-chunk 493 d# 21 constant /lf-arr 494 h# ffff constant chain-end# 495 496 h# 100 constant /lf-buf 497 /lf-buf instance buffer: leaf-value 498 /lf-buf instance buffer: leaf-name 499 500 : +le ( len off -- n ) + w@ ; 501 : le_next ( le -- n ) h# 2 +le ; 502 : le_name_chunk ( le -- n ) h# 4 +le ; 503 : le_name_length ( le -- n ) h# 6 +le ; 504 : le_value_chunk ( le -- n ) h# 8 +le ; 505 : le_value_length ( le -- n ) h# a +le ; 506 507 : la_array ( la -- adr ) 1+ ; 508 : la_next ( la -- n ) h# 16 + w@ ; 509 510 0 instance value zap-space 511 512 \ setup leaf hash bounds 513 : >leaf-hash ( dn lh -- hash-adr /hash ) 514 /lf-chunk 2* + ( dn hash-adr ) 515 \ size = (bsize / 32) * 2 516 swap dn-bsize 4 rshift ( hash-adr /hash ) 517 ; 518 : >leaf-chunks ( lf -- ch0 ) >leaf-hash + ; 519 520 \ convert chunk # to leaf chunk 521 : ch#>lc ( dn ch# -- lc ) 522 /lf-chunk * ( dn lc-off ) 523 swap zap-space >leaf-chunks ( lc-off ch0 ) 524 + ( lc ) 525 ; 526 527 \ assemble chunk chain into single buffer 528 : get-chunk-data ( dn ch# adr -- ) 529 dup >r /lf-buf erase ( dn ch# r: adr ) 530 begin 531 2dup ch#>lc nip ( dn la r: adr ) 532 dup la_array ( dn la la-arr r: adr ) 533 r@ /lf-arr move ( dn la r: adr ) 534 r> /lf-arr + >r ( dn la r: adr' ) 535 la_next dup chain-end# = ( dn la-ch# end? r: adr ) 536 until r> 3drop ( ) 537 ; 538 539 \ get leaf entry's name 540 : entry-name$ ( dn le -- name$ ) 541 2dup le_name_chunk ( dn le dn la-ch# ) 542 leaf-name get-chunk-data ( dn le ) 543 nip le_name_length 1- ( len ) 544 leaf-name swap ( name$ ) 545 ; 546 547 \ return entry value as int 548 : entry-int-val ( dn le -- n ) 549 le_value_chunk ( dn la-ch# ) 550 leaf-value get-chunk-data ( ) 551 leaf-value x@ ( n ) 552 ; 553 554 555[ifdef] strlookup 556 \ get leaf entry's value as string 557 : entry-val$ ( dn le -- val$ ) 558 2dup le_value_chunk ( dn le dn la-ch# ) 559 leaf-value get-chunk-data ( dn le ) 560 nip le_value_length ( len ) 561 leaf-value swap ( name$ ) 562 ; 563[then] 564 565 \ apply xt to entry 566 : entry-apply ( xt dn le -- xt dn false | ??? true ) 567 over >r ( xt dn le r: dn ) 568 rot dup >r execute if ( ??? r: xt dn ) 569 r> r> 2drop true ( ??? true ) 570 else ( ) 571 r> r> false ( xt dn false ) 572 then 573 ; 574 575 \ apply xt to every entry in chain 576 : chain-apply ( xt dn ch# -- xt dn false | ??? true ) 577 begin 578 2dup ch#>lc nip ( xt dn le ) 579 dup >r entry-apply if ( ??? r: le ) 580 r> drop true exit ( ??? found ) 581 then ( xt dn r: le ) 582 r> le_next ( xt dn ch# ) 583 dup chain-end# = ( xt dn ch# end? ) 584 until drop ( xt dn ) 585 false ( xt dn false ) 586 ; 587 588 \ apply xt to every entry in leaf 589 : leaf-apply ( xt dn blk# -- xt dn false | ??? true ) 590 591 \ read zap leaf into zap-space 592 2dup lblk#>bp ( xt dn blk# bp ) 593 nip over dn-bsize zap-space ( xt dn bp len adr ) 594 swap rot read-bp ( xt dn ) 595 596 \ call chunk-look for every valid chunk list 597 dup zap-space >leaf-hash ( xt dn hash-adr /hash ) 598 bounds do ( xt dn ) 599 i w@ dup chain-end# <> if ( xt dn ch# ) 600 chain-apply if ( ??? ) 601 unloop true exit ( ??? found ) 602 then ( xt dn ) 603 else drop then ( xt dn ) 604 /w +loop 605 false ( xt dn not-found ) 606 ; 607 608 \ apply xt to every entry in fzap 609 : fzap-apply ( xt dn fz -- ??? not-found? ) 610 611 \ blk# 1 is always the 1st leaf 612 >r 1 leaf-apply if ( ??? r: fz ) 613 r> drop true exit ( ??? found ) 614 then r> ( xt dn fz ) 615 616 \ call leaf-apply on every non-duplicate hash entry 617 \ embedded hash is in 2nd half of fzap block 618 over dn-bsize tuck + ( xt dn bsize hash-eadr ) 619 swap 2dup 2/ - ( xt dn hash-eadr bsize hash-adr ) 620 nip do ( xt dn ) 621 i x@ dup 1 <> if ( xt dn blk# ) 622 leaf-apply if ( ??? ) 623 unloop true exit ( ??? found ) 624 then ( xt dn ) 625 else drop then ( xt dn ) 626 /x +loop 627 2drop false ( not-found ) 628 ; 629 630 : mze_value ( uz -- n ) x@ ; 631 : mze_name ( uz -- p ) h# e + ; 632 633 : uzap-name$ ( uz -- name$ ) mze_name cscount ; 634 635 \ apply xt to each entry in micro-zap 636 : uzap-apply ( xt uz len -- ??? not-found? ) 637 bounds do ( xt ) 638 i swap dup >r ( uz xt r: xt ) 639 execute if ( ??? r: xt ) 640 r> drop ( ??? ) 641 unloop true exit ( ??? found ) 642 then r> ( xt ) 643 /uzap +loop 644 drop false ( not-found ) 645 ; 646 647 \ match by name 648 : fz-nmlook ( prop$ dn le -- prop$ false | prop$ dn le true ) 649 2dup entry-name$ ( prop$ dn le name$ ) 650 2rot 2swap ( dn le prop$ name$ ) 651 2over $= if ( dn le prop$ ) 652 2swap true ( prop$ dn le true ) 653 else ( dn le prop$ ) 654 2swap 2drop false ( prop$ false ) 655 then ( prop$ false | prop$ dn le true ) 656 ; 657 658 \ match by name 659 : uz-nmlook ( prop$ uz -- prop$ false | prop$ uz true ) 660 dup >r uzap-name$ ( prop$ name$ r: uz ) 661 2over $= if ( prop$ r: uz ) 662 r> true ( prop$ uz true ) 663 else ( prop$ r: uz ) 664 r> drop false ( prop$ false ) 665 then ( prop$ false | prop$ uz true ) 666 ; 667 668 : zap-type ( zp -- n ) h# 7 + c@ ; 669 : >uzap-ent ( adr -- ent ) h# 40 + ; 670 671 \ read zap block into temp-space 672 : get-zap ( dn -- zp ) 673 dup 0 lblk#>bp ( dn bp ) 674 swap dn-bsize ( bp len ) 675 temp-space swap ( bp adr len ) 676 rot read-bp ( ) 677 temp-space ( zp ) 678 ; 679 680 \ find prop in zap dnode 681 : zap-lookup ( dn prop$ -- [ n ] not-found? ) 682 rot dup get-zap ( prop$ dn zp ) 683 dup zap-type case 684 uzap# of 685 >uzap-ent swap dn-bsize ( prop$ uz len ) 686 ['] uz-nmlook -rot ( prop$ xt uz len ) 687 uzap-apply if ( prop$ uz ) 688 mze_value -rot 2drop ( n ) 689 false ( n found ) 690 else ( prop$ ) 691 2drop true ( !found ) 692 then ( [ n ] not-found? ) 693 endof 694 fzap# of 695 ['] fz-nmlook -rot ( prop$ xt dn fz ) 696 fzap-apply if ( prop$ dn le ) 697 entry-int-val ( prop$ n ) 698 -rot 2drop false ( n found ) 699 else ( prop$ ) 700 2drop true ( !found ) 701 then ( [ n ] not-found? ) 702 endof 703 3drop 2drop true ( !found ) 704 endcase ( [ n ] not-found? ) 705 ; 706 707[ifdef] strlookup 708 : zap-lookup-str ( dn prop$ -- [ val$ ] not-found? ) 709 rot dup get-zap ( prop$ dn zp ) 710 dup zap-type fzap# <> if ( prop$ dn zp ) 711 2drop 2drop true exit ( !found ) 712 then ( prop$ dn zp ) 713 ['] fz-nmlook -rot ( prop$ xt dn fz ) 714 fzap-apply if ( prop$ dn le ) 715 entry-val$ 2swap 2drop false ( val$ found ) 716 else ( prop$ ) 717 2drop true ( !found ) 718 then ( [ val$ ] not-found? ) 719 ; 720[then] 721 722 : fz-print ( dn le -- false ) 723 entry-name$ type cr false 724 ; 725 726 : uz-print ( uz -- false ) 727 uzap-name$ type cr false 728 ; 729 730 : zap-print ( dn -- ) 731 dup get-zap ( dn zp ) 732 dup zap-type case 733 uzap# of 734 >uzap-ent swap dn-bsize ( uz len ) 735 ['] uz-print -rot ( xt uz len ) 736 uzap-apply ( false ) 737 endof 738 fzap# of 739 ['] fz-print -rot ( xt dn fz ) 740 fzap-apply ( false ) 741 endof 742 3drop false ( false ) 743 endcase ( false ) 744 drop ( ) 745 ; 746 747 748 \ 749 \ ZFS object set (DSL) routines 750 \ 751 752 1 constant pool-dir# 753 754 : dd_head_dataset_obj ( dd -- n ) h# 8 + x@ ; 755 : dd_child_dir_zapobj ( dd -- n ) h# 20 + x@ ; 756 757 : ds_snapnames_zapobj ( ds -- n ) h# 20 + x@ ; 758 : ds_bp ( ds -- p ) h# 80 + ; 759 760 0 instance value mos-dn 761 0 instance value obj-dir 762 0 instance value root-dsl 763 0 instance value fs-dn 764 765 \ dn-cache contains dc-dn's contents at dc-blk# 766 \ dc-dn will be either mos-dn or fs-dn 767 0 instance value dn-cache 768 0 instance value dc-dn 769 0 instance value dc-blk# 770 771 alias >dsl-dir dn_bonus 772 alias >dsl-ds dn_bonus 773 774 : #dn/blk ( dn -- n ) dn-bsize /dnode / ; 775 776 \ read block into dn-cache 777 : get-dnblk ( dn blk# -- ) 778 lblk#>bp dn-cache swap ( adr bp ) 779 dup bp-lsize swap read-bp ( ) 780 ; 781 782 \ read obj# from objset dir dn into dnode 783 : get-dnode ( dn obj# -- ) 784 785 \ check dn-cache 786 2dup swap #dn/blk /mod ( dn obj# off# blk# ) 787 swap >r nip ( dn blk# r: off# ) 788 2dup dc-blk# <> ( dn blk# dn !blk-hit? r: off# ) 789 swap dc-dn <> or if ( dn blk# r: off# ) 790 \ cache miss, fill from dir 791 2dup get-dnblk 792 over to dc-dn 793 dup to dc-blk# 794 then ( dn blk# r: off# ) 795 796 \ index and copy 797 2drop r> /dnode * ( off ) 798 dn-cache + ( dn-adr ) 799 dnode /dnode move ( ) 800 ; 801 802 \ read meta object set from uber-block 803 : get-mos ( -- ) 804 mos-dn /dnode ( adr len ) 805 uber-block ub_rootbp read-bp 806 ; 807 808 : get-mos-dnode ( obj# -- ) 809 mos-dn swap get-dnode 810 ; 811 812 \ get root dataset 813 : get-root-dsl ( -- ) 814 815 \ read MOS 816 get-mos 817 818 \ read object dir 819 pool-dir# get-mos-dnode 820 dnode obj-dir /dnode move 821 822 \ read root dataset 823 obj-dir " root_dataset" zap-lookup if 824 " no root_dataset" die 825 then ( obj# ) 826 get-mos-dnode ( ) 827 dnode root-dsl /dnode move 828 ; 829 830 \ find snapshot of given dataset 831 : snap-look ( snap$ ds-obj# -- [ss-obj# ] not-found? ) 832 get-mos-dnode dnode >dsl-ds ( snap$ ds ) 833 ds_snapnames_zapobj get-mos-dnode ( snap$ ) 834 dnode -rot zap-lookup ( [ss-obj# ] not-found? ) 835 ; 836 837 \ dsl dir to dataset 838 : dir>ds ( dn -- obj# ) >dsl-dir dd_head_dataset_obj ; 839 840 \ look thru the dsl hierarchy for path 841 \ this looks almost exactly like a FS directory lookup 842 : dsl-lookup ( path$ -- [ ds-obj# ] not-found? ) 843 root-dsl >r ( path$ r: root-dn ) 844 begin 845 ascii / left-parse-string ( path$ file$ r: dn ) 846 dup while 847 848 \ get child dir zap dnode 849 r> >dsl-dir dd_child_dir_zapobj ( path$ file$ obj# ) 850 get-mos-dnode ( path$ file$ ) 851 852 \ check for snapshot names 853 ascii @ left-parse-string ( path$ snap$ file$ ) 854 855 \ search it 856 dnode -rot zap-lookup if ( path$ snap$ ) 857 \ not found 858 2drop 2drop true exit ( not-found ) 859 then ( path$ snap$ obj# ) 860 get-mos-dnode ( path$ snap$ ) 861 862 \ lookup any snapshot name 863 dup if 864 \ must be last path component 865 2swap nip if ( snap$ ) 866 2drop true exit ( not-found ) 867 then 868 dnode dir>ds snap-look if ( ) 869 true exit ( not-found ) 870 then ( obj# ) 871 false exit ( obj# found ) 872 else 2drop then ( path$ ) 873 874 dnode >r ( path$ r: dn ) 875 repeat ( path$ file$ r: dn) 876 2drop 2drop r> drop ( ) 877 878 \ found it, return dataset obj# 879 dnode dir>ds ( ds-obj# ) 880 false ( ds-obj# found ) 881 ; 882 883 \ get objset from dataset 884 : get-objset ( adr dn -- ) 885 >dsl-ds ds_bp /dnode swap read-bp 886 ; 887 888 889 \ 890 \ ZFS file-system (ZPL) routines 891 \ 892 893 1 constant master-node# 894 895 0 instance value bootfs-obj# 896 0 instance value root-obj# 897 0 instance value current-obj# 898 0 instance value search-obj# 899 900 instance defer fsize ( dn -- size ) 901 instance defer mode ( dn -- mode ) 902 instance defer parent ( dn -- obj# ) 903 instance defer readlink ( dst dn -- ) 904 905 \ 906 \ routines when bonus pool contains a znode 907 \ 908 d# 264 constant /znode 909 d# 56 constant /zn-slink 910 911 : zp_mode ( zn -- n ) h# 48 + x@ ; 912 : zp_size ( zn -- n ) h# 50 + x@ ; 913 : zp_parent ( zn -- n ) h# 58 + x@ ; 914 915 alias >znode dn_bonus 916 917 : zn-fsize ( dn -- n ) >znode zp_size ; 918 : zn-mode ( dn -- n ) >znode zp_mode ; 919 : zn-parent ( dn -- n ) >znode zp_parent ; 920 921 \ copy symlink target to dst 922 : zn-readlink ( dst dn -- ) 923 dup zn-fsize tuck /zn-slink > if ( dst size dn ) 924 \ contents in 1st block 925 temp-space over dn-bsize ( dst size dn t-adr bsize ) 926 rot 0 lblk#>bp read-bp ( dst size ) 927 temp-space ( dst size src ) 928 else ( dst size dn ) 929 \ contents in dnode 930 >znode /znode + ( dst size src ) 931 then ( dst size src ) 932 -rot move ( ) 933 ; 934 935 \ 936 \ routines when bonus pool contains sa's 937 \ 938 939 \ SA header size when link is in dn_bonus 940 d# 16 constant /sahdr-link 941 942 : sa_props ( sa -- n ) h# 4 + w@ ; 943 944 : sa-hdrsz ( sa -- sz ) sa_props h# 7 >> ; 945 946 alias >sa dn_bonus 947 948 : >sadata ( dn -- adr ) >sa dup sa-hdrsz + ; 949 : sa-mode ( dn -- n ) >sadata x@ ; 950 : sa-fsize ( dn -- n ) >sadata h# 8 + x@ ; 951 : sa-parent ( dn -- n ) >sadata h# 28 + x@ ; 952 953 \ copy symlink target to dst 954 : sa-readlink ( dst dn -- ) 955 dup >sa sa-hdrsz /sahdr-link <> if 956 \ contents in 1st attr of dn_spill 957 temp-space over dn_spill ( dst dn t-adr bp ) 958 dup bp-lsize swap read-bp ( dst dn ) 959 sa-fsize ( dst size ) 960 temp-space dup sa-hdrsz + ( dst size src ) 961 else ( dst dn ) 962 \ content in bonus buf 963 dup dn_bonus over dn_bonuslen + ( dst dn ebonus ) 964 swap sa-fsize tuck - ( dst size src ) 965 then ( dst size src ) 966 -rot move ( ) 967 ; 968 969 970 \ setup attr routines for dn 971 : set-attr ( dn -- ) 972 dn_bonustype ot-sa# = if 973 ['] sa-fsize to fsize 974 ['] sa-mode to mode 975 ['] sa-parent to parent 976 ['] sa-readlink to readlink 977 else 978 ['] zn-fsize to fsize 979 ['] zn-mode to mode 980 ['] zn-parent to parent 981 ['] zn-readlink to readlink 982 then 983 ; 984 985 : ftype ( dn -- type ) mode h# f000 and ; 986 : dir? ( dn -- flag ) ftype h# 4000 = ; 987 : symlink? ( dn -- flag ) ftype h# a000 = ; 988 989 \ read obj# from fs objset 990 : get-fs-dnode ( obj# -- ) 991 dup to current-obj# 992 fs-dn swap get-dnode ( ) 993 ; 994 995 \ get root-obj# from dataset 996 : get-rootobj# ( ds-obj# -- fsroot-obj# ) 997 dup to bootfs-obj# 998 get-mos-dnode ( ) 999 fs-dn dnode get-objset 1000 1001 \ get root obj# from master node 1002 master-node# get-fs-dnode 1003 dnode " ROOT" zap-lookup if 1004 " no ROOT" die 1005 then ( fsroot-obj# ) 1006 ; 1007 1008 : prop>rootobj# ( -- ) 1009 obj-dir " pool_props" zap-lookup if 1010 " no pool_props" die 1011 then ( prop-obj# ) 1012 get-mos-dnode ( ) 1013 dnode " bootfs" zap-lookup if 1014 " no bootfs" die 1015 then ( ds-obj# ) 1016 get-rootobj# ( fsroot-obj# ) 1017 ; 1018 1019 : fs>rootobj# ( fs$ -- root-obj# not-found? ) 1020 1021 \ skip pool name 1022 ascii / left-parse-string 2drop 1023 1024 \ lookup fs in dsl 1025 dsl-lookup if ( ) 1026 true exit ( not-found ) 1027 then ( ds-obj# ) 1028 1029 get-rootobj# ( fsroot-obj# ) 1030 false ( fsroot-obj# found ) 1031 ; 1032 1033 \ lookup file is current directory 1034 : dirlook ( file$ dn -- not-found? ) 1035 \ . and .. are magic 1036 -rot 2dup " ." $= if ( dn file$ ) 1037 3drop false exit ( found ) 1038 then 1039 1040 2dup " .." $= if 1041 2drop parent ( obj# ) 1042 else ( dn file$ ) 1043 \ search dir 1044 current-obj# to search-obj# 1045 zap-lookup if ( ) 1046 true exit ( not-found ) 1047 then ( obj# ) 1048 then ( obj# ) 1049 get-fs-dnode 1050 dnode set-attr 1051 false ( found ) 1052 ; 1053 1054 /buf-len instance buffer: fpath-buf 1055 /buf-len instance buffer: tpath-buf 1056 1057 : tpath-buf$ ( -- path$ ) tpath-buf cscount ; 1058 : fpath-buf$ ( -- path$ ) fpath-buf cscount ; 1059 1060 \ modify tail to account for symlink 1061 : follow-symlink ( tail$ -- tail$' ) 1062 \ read target 1063 tpath-buf /buf-len erase 1064 tpath-buf dnode readlink 1065 1066 \ append current path 1067 ?dup if ( tail$ ) 1068 " /" tpath-buf$ $append ( tail$ ) 1069 tpath-buf$ $append ( ) 1070 else drop then ( ) 1071 1072 \ copy to fpath 1073 fpath-buf /buf-len erase 1074 tpath-buf$ fpath-buf swap move 1075 fpath-buf$ ( path$ ) 1076 1077 \ get directory that starts changed path 1078 over c@ ascii / = if ( path$ ) 1079 str++ root-obj# ( path$' obj# ) 1080 else ( path$ ) 1081 search-obj# ( path$ obj# ) 1082 then ( path$ obj# ) 1083 get-fs-dnode ( path$ ) 1084 dnode set-attr 1085 ; 1086 1087 \ open dnode at path 1088 : lookup ( path$ -- not-found? ) 1089 1090 \ get directory that starts path 1091 over c@ ascii / = if 1092 str++ root-obj# ( path$' obj# ) 1093 else 1094 current-obj# ( path$ obj# ) 1095 then ( path$ obj# ) 1096 get-fs-dnode ( path$ ) 1097 dnode set-attr 1098 1099 \ lookup each path component 1100 begin ( path$ ) 1101 ascii / left-parse-string ( path$ file$ ) 1102 dup while 1103 dnode dir? 0= if 1104 2drop true exit ( not-found ) 1105 then ( path$ file$ ) 1106 dnode dirlook if ( path$ ) 1107 2drop true exit ( not-found ) 1108 then ( path$ ) 1109 dnode symlink? if 1110 follow-symlink ( path$' ) 1111 then ( path$ ) 1112 repeat ( path$ file$ ) 1113 2drop 2drop false ( found ) 1114 ; 1115 1116 \ 1117 \ ZFS volume (ZVOL) routines 1118 \ 1119 1 constant zvol-data# 1120 2 constant zvol-prop# 1121 1122 0 instance value zv-dn 1123 1124 : get-zvol ( zvol$ -- not-found? ) 1125 dsl-lookup if 1126 drop true exit ( failed ) 1127 then ( ds-obj# ) 1128 1129 \ get zvol objset 1130 get-mos-dnode ( ) 1131 zv-dn dnode get-objset 1132 false ( succeeded ) 1133 ; 1134 1135 \ get zvol data dnode 1136 : zvol-data ( -- ) 1137 zv-dn zvol-data# get-dnode 1138 ; 1139 1140 : zvol-size ( -- size ) 1141 zv-dn zvol-prop# get-dnode 1142 dnode " size" zap-lookup if 1143 " no zvol size" die 1144 then ( size ) 1145 ; 1146 1147 1148 \ 1149 \ ZFS installation routines 1150 \ 1151 1152 \ ZFS file interface 1153 struct 1154 /x field >busy 1155 /x field >offset 1156 /x field >fsize 1157 /dnode field >dnode 1158 constant /file-record 1159 1160 d# 10 constant #opens 1161 #opens /file-record * constant /file-records 1162 1163 /file-records instance buffer: file-records 1164 1165 -1 instance value current-fd 1166 1167 : fd>record ( fd -- rec ) /file-record * file-records + ; 1168 : file-offset@ ( -- off ) current-fd fd>record >offset x@ ; 1169 : file-offset! ( off -- ) current-fd fd>record >offset x! ; 1170 : file-dnode ( -- dn ) current-fd fd>record >dnode ; 1171 : file-size ( -- size ) current-fd fd>record >fsize x@ ; 1172 : file-bsize ( -- bsize ) file-dnode dn-bsize ; 1173 1174 \ find free fd slot 1175 : get-slot ( -- fd false | true ) 1176 #opens 0 do 1177 i fd>record >busy x@ 0= if 1178 i false unloop exit 1179 then 1180 loop true 1181 ; 1182 1183 : free-slot ( fd -- ) 1184 0 swap fd>record >busy x! 1185 ; 1186 1187 \ init fd to offset 0 and copy dnode 1188 : init-fd ( fsize fd -- ) 1189 fd>record ( fsize rec ) 1190 dup >busy 1 swap x! 1191 dup >dnode dnode swap /dnode move 1192 dup >fsize rot swap x! ( rec ) 1193 >offset 0 swap x! ( ) 1194 ; 1195 1196 \ make fd current 1197 : set-fd ( fd -- error? ) 1198 dup fd>record >busy x@ 0= if ( fd ) 1199 drop true exit ( failed ) 1200 then ( fd ) 1201 to current-fd false ( succeeded ) 1202 ; 1203 1204 \ read next fs block 1205 : file-bread ( adr -- ) 1206 file-bsize ( adr len ) 1207 file-offset@ over / ( adr len blk# ) 1208 file-dnode swap lblk#>bp ( adr len bp ) 1209 read-bp ( ) 1210 ; 1211 1212 \ advance file io stack by n 1213 : fio+ ( # adr len n -- #+n adr+n len-n ) 1214 dup file-offset@ + file-offset! 1215 dup >r - -rot ( len' # adr r: n ) 1216 r@ + -rot ( adr' len' # r: n ) 1217 r> + -rot ( #' adr' len' ) 1218 ; 1219 1220 1221 /max-bsize 5 * 1222 /uber-block + 1223 /dnode 6 * + 1224 /disk-block 6 * + ( size ) 1225 \ ugh - sg proms can't free 512k allocations 1226 \ that aren't a multiple of 512k in size 1227 h# 8.0000 roundup ( size' ) 1228 constant alloc-size 1229 1230 1231 : allocate-buffers ( -- ) 1232 alloc-size h# a0.0000 vmem-alloc dup 0= if 1233 " no memory" die 1234 then ( adr ) 1235 dup to temp-space /max-bsize + ( adr ) 1236 dup to dn-cache /max-bsize + ( adr ) 1237 dup to blk-space /max-bsize + ( adr ) 1238 dup to ind-cache /max-bsize + ( adr ) 1239 dup to zap-space /max-bsize + ( adr ) 1240 dup to uber-block /uber-block + ( adr ) 1241 dup to mos-dn /dnode + ( adr ) 1242 dup to obj-dir /dnode + ( adr ) 1243 dup to root-dsl /dnode + ( adr ) 1244 dup to fs-dn /dnode + ( adr ) 1245 dup to zv-dn /dnode + ( adr ) 1246 dup to dnode /dnode + ( adr ) 1247 to gang-space ( ) 1248 1249 \ zero instance buffers 1250 file-records /file-records erase 1251 bootprop-buf /buf-len erase 1252 ; 1253 1254 : release-buffers ( -- ) 1255 temp-space alloc-size mem-free 1256 ; 1257 1258 external 1259 1260 : open ( -- okay? ) 1261 my-args dev-open dup 0= if 1262 exit ( failed ) 1263 then to dev-ih 1264 1265 allocate-buffers 1266 scan-vdev 1267 get-ub 1268 get-root-dsl 1269 true 1270 ; 1271 1272 : open-fs ( fs$ -- okay? ) 1273 fs>rootobj# if ( ) 1274 false ( failed ) 1275 else ( obj# ) 1276 to root-obj# true ( succeeded ) 1277 then ( okay? ) 1278 ; 1279 1280 : close ( -- ) 1281 dev-ih dev-close 1282 0 to dev-ih 1283 release-buffers 1284 ; 1285 1286 : open-file ( path$ -- fd true | false ) 1287 1288 \ open default fs if no open-fs 1289 root-obj# 0= if 1290 prop>rootobj# to root-obj# 1291 then 1292 1293 get-slot if 1294 2drop false exit ( failed ) 1295 then -rot ( fd path$ ) 1296 1297 lookup if ( fd ) 1298 drop false exit ( failed ) 1299 then ( fd ) 1300 1301 dnode fsize over init-fd 1302 true ( fd succeeded ) 1303 ; 1304 1305 : open-volume ( vol$ -- okay? ) 1306 get-slot if 1307 2drop false exit ( failed ) 1308 then -rot ( fd vol$ ) 1309 1310 get-zvol if ( fd ) 1311 drop false exit ( failed ) 1312 then 1313 1314 zvol-size over ( fd size fd ) 1315 zvol-data init-fd ( fd ) 1316 true ( fd succeeded ) 1317 ; 1318 1319 : close-file ( fd -- ) 1320 free-slot ( ) 1321 ; 1322 1323 : size-file ( fd -- size ) 1324 set-fd if 0 else file-size then 1325 ; 1326 1327 : seek-file ( off fd -- off true | false ) 1328 set-fd if ( off ) 1329 drop false exit ( failed ) 1330 then ( off ) 1331 1332 dup file-size x> if ( off ) 1333 drop false exit ( failed ) 1334 then ( off ) 1335 dup file-offset! true ( off succeeded ) 1336 ; 1337 1338 : read-file ( adr len fd -- #read ) 1339 set-fd if ( adr len ) 1340 2drop 0 exit ( 0 ) 1341 then ( adr len ) 1342 1343 \ adjust len if reading past eof 1344 dup file-offset@ + file-size x> if 1345 dup file-offset@ + file-size - - 1346 then 1347 dup 0= if nip exit then 1348 1349 0 -rot ( #read adr len ) 1350 1351 \ initial partial block 1352 file-offset@ file-bsize mod ?dup if ( #read adr len off ) 1353 temp-space file-bread 1354 2dup file-bsize swap - min ( #read adr len off cpy-len ) 1355 2over drop -rot ( #read adr len adr off cpy-len ) 1356 >r temp-space + swap ( #read adr len cpy-src adr r: cpy-len ) 1357 r@ move r> fio+ ( #read' adr' len' ) 1358 then ( #read adr len ) 1359 1360 dup file-bsize / 0 ?do ( #read adr len ) 1361 over file-bread 1362 file-bsize fio+ ( #read' adr' len' ) 1363 loop ( #read adr len ) 1364 1365 \ final partial block 1366 dup if ( #read adr len ) 1367 temp-space file-bread 1368 2dup temp-space -rot move ( #read adr len ) 1369 dup fio+ ( #read' adr' 0 ) 1370 then 2drop ( #read ) 1371 ; 1372 1373 : cinfo-file ( fd -- bsize fsize comp? ) 1374 set-fd if 1375 0 0 0 1376 else 1377 file-bsize file-size ( bsize fsize ) 1378 \ zfs does internal compression 1379 0 ( bsize fsize comp? ) 1380 then 1381 ; 1382 1383 \ read ramdisk fcode at rd-offset 1384 : get-rd ( adr len -- ) 1385 rd-offset dev-ih read-disk 1386 ; 1387 1388 : bootprop 1389 " /" bootprop$ $append 1390 bootfs-obj# (xu.) bootprop$ $append 1391 bootprop$ encode-string " zfs-bootfs" ( propval propname ) 1392 true 1393 ; 1394 1395 1396 : chdir ( dir$ -- ) 1397 current-obj# -rot ( obj# dir$ ) 1398 lookup if ( obj# ) 1399 to current-obj# ( ) 1400 ." no such dir" cr exit 1401 then ( obj# ) 1402 dnode dir? 0= if ( obj# ) 1403 to current-obj# ( ) 1404 ." not a dir" cr exit 1405 then drop ( ) 1406 ; 1407 1408 : dir ( -- ) 1409 current-obj# get-fs-dnode 1410 dnode zap-print 1411 ; 1412 1413finish-device 1414pop-package 1415