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