forth/admin/devices.fs

   1 \ tag: device tree administration
   2 \
   3 \ this code implements IEEE 1275-1994
   4 \
   5 \ Copyright (C) 2003 Samuel Rydh
   6 \ Copyright (C) 2003-2006 Stefan Reinauer
   7 \
   8 \ See the file "COPYING" for further information about
   9 \ the copyright and warranty status of this work.
  10 \
  11
  12
  13 \ 7.4.11.1 Device alias
  14
  15 : devalias    ( "{alias-name}< >{device-specifier}<cr>" -- )
  16   ;
  17
  18 : nvalias    ( "alias-name< >device-specifier<cr>" -- )
  19   ;
  20
  21 : $nvalias    ( name-str name-len dev-str dev-len -- )
  22   ;
  23
  24 : nvunalias    ( "alias-name< >" -- )
  25   ;
  26
  27 : $nvunalias    ( name-str name-len -- )
  28   ;
  29
  30
  31 \ 7.4.11.2 Device tree browsing
  32
  33 : dev    ( "<spaces>device-specifier" -- )
  34   bl parse
  35   find-device
  36 ;
  37
  38 : cd
  39   dev
  40 ;
  41
  42 \ find-device    ( dev-str dev-len -- )
  43 \ implemented in pathres.fs
  44
  45 : device-end    ( -- )
  46   0 active-package!
  47   ;
  48
  49 : unselect-dev ( -- )
  50   device-end
  51 ;
  52
  53 : ?active-package ( -- phandle )
  54   active-package dup 0= abort" no active device"
  55 ;
  56
  57 \ -------------------------------------------------------
  58 \  path handling
  59 \ -------------------------------------------------------
  60
  61 \ used if parent lacks an encode-unit method
  62 : def-encode-unit ( unitaddr ... )
  63     pocket tohexstr
  64 ;
  65
  66 : get-encode-unit-xt ( phandle.parent -- xt )
  67   >dn.parent @
  68   " encode-unit" rot find-method
  69   0= if ['] def-encode-unit then
  70 ;
  71
  72 : get-nodename ( phandle -- str len )
  73   " name" rot get-package-property if " <noname>" else 1- then
  74 ;
  75
  76 \ helper, return the node name in the format 'cpus@addr'
  77 : pnodename ( phandle -- str len )
  78   dup get-nodename rot
  79   dup " reg" rot get-package-property if drop exit then rot
  80
  81   \ set active-package and clear my-self (decode-phys needs this)
  82   my-self >r 0 to my-self
  83   active-package >r
  84   dup active-package!
  85
  86   ( name len prop len phandle )
  87   get-encode-unit-xt
  88
  89   ( name len prop len xt )
  90   depth >r >r
  91   decode-phys r> execute
  92   r> -rot >r >r depth! 3drop
  93
  94   ( name len R: len str )
  95   r> r> " @"
  96   here 20 +              \ abuse dictionary for temporary storage
  97   tmpstrcat >r
  98   2swap r> tmpstrcat drop
  99   pocket tmpstrcpy drop
 100
 101   r> active-package!
 102   r> to my-self
 103 ;
 104
 105 : inodename ( ihandle -- str len )
 106   my-self over to my-self >r
 107   ihandle>phandle get-nodename
 108
 109   \ nonzero unit number?
 110   false >r
 111   depth >r my-unit r> 1+
 112   begin depth over > while
 113     swap 0<> if r> drop true >r then
 114   repeat
 115   drop
 116
 117   \ if not... check for presence of "reg" property
 118   r> ?dup 0= if
 119     " reg" my-self ihandle>phandle get-package-property
 120     if false else 2drop true then
 121   then
 122
 123   ( name len print-unit-flag )
 124   if
 125     my-self ihandle>phandle get-encode-unit-xt
 126
 127     ( name len xt )
 128     depth >r >r
 129     my-unit r> execute
 130     r> -rot >r >r depth! drop
 131     r> r>
 132     ( name len str len )
 133     here 20 + tmpstrcpy
 134     " @" rot tmpstrcat drop
 135     2swap pocket tmpstrcat drop
 136   then
 137
 138   \ add :arguments
 139   my-args dup if
 140     " :" pocket tmpstrcat drop
 141     2swap pocket tmpstrcat drop
 142   else
 143     2drop
 144   then
 145
 146   r> to my-self
 147 ;
 148
 149 \ helper, also used by client interface (package-to-path)
 150 : get-package-path ( phandle -- str len )
 151   ?dup 0= if 0 0 then
 152
 153   dup >dn.parent @ 0= if drop " /" exit then
 154   \ dictionary abused for temporary storage
 155   >r 0 0 here 40 +
 156   begin r> dup >dn.parent @ dup >r while
 157     ( path len tempbuf phandle R: phandle.parent )
 158     pnodename rot tmpstrcat
 159     " /" rot tmpstrcat
 160   repeat
 161   r> 3drop
 162   pocket tmpstrcpy drop
 163 ;
 164
 165 \ used by client interface (instance-to-path)
 166 : get-instance-path ( ihandle -- str len )
 167   ?dup 0= if 0 0 then
 168
 169   dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
 170
 171   \ dictionary abused for temporary storage
 172   >r 0 0 here 40 +
 173   begin r> dup >in.my-parent @ dup >r while
 174     ( path len tempbuf ihandle R: ihandle.parent )
 175     dup >in.interposed @ 0= if
 176       inodename rot tmpstrcat
 177       " /" rot tmpstrcat
 178     else
 179       drop
 180     then
 181   repeat
 182   r> 3drop
 183   pocket tmpstrcpy drop
 184 ;
 185
 186 \ used by client interface (instance-to-interposed-path)
 187 : get-instance-interposed-path ( ihandle -- str len )
 188   ?dup 0= if 0 0 then
 189
 190   dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
 191
 192   \ dictionary abused for temporary storage
 193   >r 0 0 here 40 +
 194   begin r> dup >in.my-parent @ dup >r while
 195     ( path len tempbuf ihandle R: ihandle.parent )
 196     dup >r inodename rot tmpstrcat
 197     r> >in.interposed @ if " /%" else " /" then
 198     rot tmpstrcat
 199   repeat
 200   r> 3drop
 201   pocket tmpstrcpy drop
 202 ;
 203
 204 : pwd    ( -- )
 205   ?active-package get-package-path type
 206 ;
 207
 208 : ls    ( -- )
 209   cr
 210   ?active-package >dn.child @
 211   begin dup while
 212     dup u. dup pnodename type cr
 213     >dn.peer @
 214   repeat
 215   drop
 216 ;
 217
 218
 219 \ -------------------------------------------
 220 \  property printing
 221 \ -------------------------------------------
 222
 223 : .p-string? ( data len -- true | data len false )
 224   \ no trailing zero?
 225   2dup + 1- c@ if 0 exit then
 226
 227   swap >r 0
 228   \ count zeros and detect unprintable characters?
 229   over 1- begin 1- dup 0>= while
 230     dup r@ + c@
 231     ( len zerocnt n ch )
 232
 233     ?dup 0= if
 234       swap 1+ swap
 235     else
 236       dup 1b <= swap 80 >= or
 237       if 2drop r> swap 0 exit then
 238     then
 239   repeat drop r> -rot
 240   ( data len zerocnt )
 241
 242   \ simple string
 243   0= if
 244     ascii " emit 1- type ascii " emit true exit
 245   then
 246
 247   \ make sure there are no double zeros (except possibly at the end)
 248   2dup over + swap
 249   ( data len end ptr )
 250   begin 2dup <> while
 251     dup c@ 0= if
 252       2dup 1+ <> if 2drop false exit then
 253     then
 254     dup cstrlen 1+ +
 255   repeat
 256   2drop
 257
 258   ." {"
 259   0 -rot over + swap
 260   \ multistring ( cnt end ptr )
 261   begin 2dup <> while
 262     rot dup if ." , " then 1+ -rot
 263     dup cstrlen 2dup
 264     ascii " emit type ascii " emit
 265     1+ +
 266   repeat
 267   ." }"
 268   3drop true
 269 ;
 270
 271 : .p-int? ( data len -- 1 | data len 0 )
 272   dup 4 <> if false exit then
 273   decode-int -rot 2drop true swap
 274   dup 0>= if . exit then
 275   dup -ff < if u. exit then
 276   .
 277 ;
 278
 279 \ Print a number zero-padded
 280 : 0.r ( u minlen -- )
 281   0 swap <# 1 ?do # loop #s #> type
 282 ;
 283
 284 : .p-bytes? ( data len -- 1 | data len 0 )
 285   ." -- " dup . ." : "
 286   swap >r 0
 287   begin 2dup > while
 288     dup r@ + c@
 289     ( len n ch )
 290
 291     2 0.r space
 292     1+
 293   repeat
 294   2drop r> drop 1
 295 ;
 296
 297 \ this function tries to heuristically determine the data format
 298 : (.property) ( data len -- )
 299   dup 0= if 2drop ." <empty>" exit then
 300
 301   .p-string? if exit then
 302   .p-int? if exit then
 303   .p-bytes? if exit then
 304   2drop ." <unimplemented type>"
 305 ;
 306
 307 \ Print the value of a property in "reg" format
 308 : .p-reg ( #acells #scells data len -- )
 309   2dup + -rot ( #acells #scells data+len data len )
 310   >r >r -rot ( data+len #acells #scells  R: len data )
 311   4 * swap 4 * dup r> r> ( data+len #sbytes #abytes #abytes data len )
 312   bounds ( data+len #sbytes #abytes #abytes data+len data ) ?do
 313     dup 0= if 2 spaces then                     \ start of "size" part
 314     2dup <> if                                          \ non-first byte in row
 315       dup 3 and 0= if space then        \ make numbers more readable
 316     then
 317     i c@ 2 0.r                                          \ print byte
 318     1- 3dup nip + 0= if                         \ end of row
 319       3 pick i 1+ > if                          \ non-last byte
 320         cr                                                      \ start new line
 321         d# 26 spaces                            \ indentation
 322       then
 323       drop dup                                          \ update counter
 324     then
 325   loop
 326   3drop drop
 327 ;
 328
 329 \ Return the number of cells per physical address
 330 : .p-translations-#pacells ( -- #cells )
 331   " /" find-package if
 332     " #address-cells" rot get-package-property if
 333       1
 334     else
 335       decode-int nip nip 1 max
 336     then
 337   else
 338     1
 339   then
 340 ;
 341
 342 \ Return the number of cells per translation entry
 343 : .p-translations-#cells ( -- #cells )
 344   [IFDEF] CONFIG_PPC
 345     my-#acells 3 *
 346     .p-translations-#pacells +
 347   [ELSE]
 348     my-#acells 3 *
 349   [THEN]
 350 ;
 351
 352 \ Set up column offsets
 353 : .p-translations-cols ( -- col1 ... coln #cols )
 354   .p-translations-#cells 4 *
 355   [IFDEF] CONFIG_PPC
 356     4 -
 357     dup 4 -
 358     dup .p-translations-#pacells 4 * -
 359     3
 360   [ELSE]
 361     my-#acells 4 * -
 362     dup my-#scells 4 * -
 363     2
 364   [THEN]
 365 ;
 366
 367 \ Print the value of the MMU translations property
 368 : .p-translations ( data len -- )
 369   >r >r .p-translations-cols r> r> ( col1 ... coln #cols data len )
 370   2dup + -rot ( col1 ... coln #cols data+len data len )
 371   >r >r .p-translations-#cells 4 * dup r> r>
 372   ( col1 ... coln #cols data+len #bytes #bytes len data )
 373   bounds ( col1 ... coln #cols data+len #bytes #bytes data+len data ) ?do
 374     3 pick 4 + 4 ?do                            \ check all defined columns
 375       i pick over = if
 376         2 spaces                                        \ start new column
 377       then
 378     loop
 379     2dup <> if                                          \ non-first byte in row
 380       dup 3 and 0= if space then        \ make numbers more readable
 381     then
 382     i c@ 2 0.r                                          \ print byte
 383     1- dup 0= if                                        \ end of row
 384       2 pick i 1+ > if                          \ non-last byte
 385         cr                                                      \ start new line
 386         d# 26 spaces                            \ indentation
 387       then
 388       drop dup                                          \ update counter
 389     then
 390   loop
 391   2drop drop 0 ?do drop loop
 392 ;
 393
 394 \ This function hardwires data formats to particular node properties
 395 : (.property-by-name) ( name-str name-len data len -- )
 396   2over " reg" strcmp 0= if
 397     my-#acells my-#scells 2swap .p-reg
 398     2drop exit
 399   then
 400
 401   active-package get-nodename " memory" strcmp 0= if
 402     2over " available" strcmp 0= if
 403       my-#acells my-#scells 2swap .p-reg
 404       2drop exit
 405     then
 406   then
 407   " /chosen" find-dev if
 408     " mmu" rot get-package-property 0= if
 409       decode-int nip nip ihandle>phandle active-package = if
 410         2over " available" strcmp 0= if
 411           my-#acells my-#scells 1 max 2swap .p-reg
 412           2drop exit
 413         then
 414         2over " translations" strcmp 0= if
 415           .p-translations
 416           2drop exit
 417         then
 418       then
 419     then
 420   then
 421
 422   2swap 2drop ( data len )
 423   (.property)
 424 ;
 425
 426 : .properties    ( -- )
 427   ?active-package dup >r if
 428     0 0
 429     begin
 430       r@ next-property
 431     while
 432       cr 2dup dup -rot type
 433       begin ."  " 1+ dup d# 26 >= until drop
 434       2dup
 435       2dup active-package get-package-property drop
 436       ( name-str name-len data len )
 437       (.property-by-name)
 438     repeat
 439   then
 440   r> drop
 441   cr
 442 ;
 443
 444
 445 \ 7.4.11    Device tree
 446
 447 : print-dev ( phandle -- phandle )
 448   dup u.
 449   dup get-package-path type
 450   dup " device_type" rot get-package-property if
 451     cr
 452   else
 453     ."  (" decode-string type ." )" cr 2drop
 454   then
 455   ;
 456
 457 : show-sub-devs ( subtree-phandle -- )
 458   print-dev
 459   >dn.child @
 460     begin dup while
 461       dup recurse
 462       >dn.peer @
 463     repeat
 464     drop
 465   ;
 466
 467 : show-all-devs    ( -- )
 468   active-package
 469   cr " /" find-device
 470   ?active-package show-sub-devs
 471   active-package!
 472   ;
 473
 474
 475 : show-devs    ( "{device-specifier}<cr>" -- )
 476   active-package
 477   cr " /" find-device
 478   linefeed parse find-device
 479   ?active-package show-sub-devs
 480   active-package!
 481   ;
 482
 483
 484
 485 \ 7.4.11.3 Device probing
 486
 487 : probe-all    ( -- )
 488   ;