forth/admin/devices.fs

\ tag: device tree administration
\ 
\ this code implements IEEE 1275-1994 
\ 
\ Copyright (C) 2003 Samuel Rydh
\ Copyright (C) 2003-2006 Stefan Reinauer
\ 
\ See the file "COPYING" for further information about
\ the copyright and warranty status of this work.
\ 


\ 7.4.11.1 Device alias

: devalias    ( "{alias-name}< >{device-specifier}<cr>" -- )
  ;
  
: nvalias    ( "alias-name< >device-specifier<cr>" -- )
  ;
  
: $nvalias    ( name-str name-len dev-str dev-len -- )
  ;

: nvunalias    ( "alias-name< >" -- )
  ;
  
: $nvunalias    ( name-str name-len -- )
  ;


\ 7.4.11.2 Device tree browsing

: dev    ( "<spaces>device-specifier" -- )
  bl parse
  find-device
;

: cd
  dev
;
  
\ find-device    ( dev-str dev-len -- )
\ implemented in pathres.fs

: device-end    ( -- )
  0 active-package!
  ;

\ Open selected device node and make it the current instance
\   section H.8 errata: pre OpenFirmware, but Sun OBP compatible
: select-dev    ( -- )
  open-dev dup 0= abort" failed opening parent."
  dup to my-self
  ihandle>phandle active-package!
;

\ Close current node, deselect active package and current instance,
\ leaving no instance selected
\   section H.8 errata: pre OpenFirmware, but Sun OBP compatible
: unselect-dev ( -- )
  my-self close-dev
  device-end
  0 to my-self
;

: begin-package ( arg-str arg-len reg-str reg-len dev-str dev-len -- )
  select-dev
  new-device
  set-args
;

: end-package   ( -- )
  finish-device
  unselect-dev
;
 
: ?active-package ( -- phandle )
  active-package dup 0= abort" no active device"
;

\ -------------------------------------------------------
\  path handling
\ -------------------------------------------------------

\ used if parent lacks an encode-unit method
: def-encode-unit ( unitaddr ... )
    pocket tohexstr
;

: get-encode-unit-xt ( phandle.parent -- xt )
  >dn.parent @
  " encode-unit" rot find-method
  0= if ['] def-encode-unit then
;

: get-nodename ( phandle -- str len )
  " name" rot get-package-property if " <noname>" else 1- then  
;

\ helper, return the node name in the format 'cpus@addr'
: pnodename ( phandle -- str len )
  dup get-nodename rot
  dup " reg" rot get-package-property if drop exit then rot

  \ set active-package and clear my-self (decode-phys needs this)
  my-self >r 0 to my-self
  active-package >r
  dup active-package!

  ( name len prop len phandle )
  get-encode-unit-xt

  ( name len prop len xt )
  depth >r >r
  decode-phys r> execute
  r> -rot >r >r depth! 3drop

  ( name len R: len str )
  r> r> " @"
  here 20 +              \ abuse dictionary for temporary storage
  tmpstrcat >r
  2swap r> tmpstrcat drop
  pocket tmpstrcpy drop
  
  r> active-package!
  r> to my-self
;

: inodename ( ihandle -- str len )
  my-self over to my-self >r
  ihandle>phandle get-nodename
  
  \ nonzero unit number?
  false >r
  depth >r my-unit r> 1+
  begin depth over > while
    swap 0<> if r> drop true >r then
  repeat
  drop

  \ if not... check for presence of "reg" property
  r> ?dup 0= if
    " reg" my-self ihandle>phandle get-package-property
    if false else 2drop true then
  then
  
  ( name len print-unit-flag )
  if
    my-self ihandle>phandle get-encode-unit-xt

    ( name len xt )
    depth >r >r
    my-unit r> execute
    r> -rot >r >r depth! drop
    r> r>
    ( name len str len )
    here 20 + tmpstrcpy 
    " @" rot tmpstrcat drop
    2swap pocket tmpstrcat drop
  then

  \ add :arguments
  my-args dup if
    " :" pocket tmpstrcat drop
    2swap pocket tmpstrcat drop
  else
    2drop
  then
  
  r> to my-self
;

\ helper, also used by client interface (package-to-path)
: get-package-path ( phandle -- str len )
  ?dup 0= if 0 0 then

  dup >dn.parent @ 0= if drop " /" exit then
  \ dictionary abused for temporary storage
  >r 0 0 here 40 + 
  begin r> dup >dn.parent @ dup >r while
    ( path len tempbuf phandle R: phandle.parent )
    pnodename rot tmpstrcat
    " /" rot tmpstrcat
  repeat
  r> 3drop
  pocket tmpstrcpy drop
;

\ used by client interface (instance-to-path)
: get-instance-path ( ihandle -- str len )
  ?dup 0= if 0 0 then

  dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
    
  \ dictionary abused for temporary storage
  >r 0 0 here 40 + 
  begin r> dup >in.my-parent @ dup >r while
    ( path len tempbuf ihandle R: ihandle.parent )
    dup >in.interposed @ 0= if
      inodename rot tmpstrcat
      " /" rot tmpstrcat
    else
      drop
    then
  repeat
  r> 3drop
  pocket tmpstrcpy drop
;

\ used by client interface (instance-to-interposed-path)
: get-instance-interposed-path ( ihandle -- str len )
  ?dup 0= if 0 0 then

  dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
    
  \ dictionary abused for temporary storage
  >r 0 0 here 40 + 
  begin r> dup >in.my-parent @ dup >r while
    ( path len tempbuf ihandle R: ihandle.parent )
    dup >r inodename rot tmpstrcat
    r> >in.interposed @ if " /%" else " /" then
    rot tmpstrcat
  repeat
  r> 3drop
  pocket tmpstrcpy drop
;

: pwd    ( -- )
  ?active-package get-package-path type
;
  
: ls    ( -- )
  cr
  ?active-package >dn.child @
  begin dup while
    dup u. dup pnodename type cr
    >dn.peer @
  repeat
  drop
;
  

\ -------------------------------------------
\  property printing
\ -------------------------------------------

: .p-string? ( data len -- true | data len false )
  \ no trailing zero?
  2dup + 1- c@ if 0 exit then

  swap >r 0 
  \ count zeros and detect unprintable characters?
  over 1- begin 1- dup 0>= while
    dup r@ + c@
    ( len zerocnt n ch )

    ?dup 0= if
      swap 1+ swap
    else
      dup 1b <= swap 80 >= or
      if 2drop r> swap 0 exit then
    then
  repeat drop r> -rot
  ( data len zerocnt )
  
  \ simple string
  0= if
    ascii " emit 1- type ascii " emit true exit
  then

  \ make sure there are no double zeros (except possibly at the end)
  2dup over + swap
  ( data len end ptr )
  begin 2dup <> while
    dup c@ 0= if
      2dup 1+ <> if 2drop false exit then
    then
    dup cstrlen 1+ +
  repeat
  2drop
  
  ." {"
  0 -rot over + swap
  \ multistring ( cnt end ptr )
  begin 2dup <> while
    rot dup if ." , " then 1+ -rot
    dup cstrlen 2dup
    ascii " emit type ascii " emit
    1+ +
  repeat
  ." }"
  3drop true
;

: .p-int? ( data len -- 1 | data len 0 )
  dup 4 <> if false exit then
  decode-int -rot 2drop true swap
  dup 0>= if . exit then
  dup -ff < if u. exit then
  .
;

\ Print a number zero-padded
: 0.r ( u minlen -- )
  0 swap <# 1 ?do # loop #s #> type
;

: .p-bytes? ( data len -- 1 | data len 0 )
  ." -- " dup . ." : "
  swap >r 0
  begin 2dup > while
    dup r@ + c@
    ( len n ch )

    2 0.r space
    1+
  repeat 
  2drop r> drop 1
;

\ this function tries to heuristically determine the data format
: (.property) ( data len -- )
  dup 0= if 2drop ." <empty>" exit then

  .p-string? if exit then
  .p-int? if exit then
  .p-bytes? if exit then
  2drop ." <unimplemented type>"
;

\ Print the value of a property in "reg" format
: .p-reg ( #acells #scells data len -- )
  2dup + -rot ( #acells #scells data+len data len )
  >r >r -rot ( data+len #acells #scells  R: len data )
  4 * swap 4 * dup r> r> ( data+len #sbytes #abytes #abytes data len )
  bounds ( data+len #sbytes #abytes #abytes data+len data ) ?do
    dup 0= if 2 spaces then			\ start of "size" part
    2dup <> if						\ non-first byte in row
      dup 3 and 0= if space then	\ make numbers more readable
    then
    i c@ 2 0.r						\ print byte
    1- 3dup nip + 0= if				\ end of row
      3 pick i 1+ > if				\ non-last byte
        cr							\ start new line
        d# 26 spaces				\ indentation
      then
      drop dup						\ update counter
    then
  loop
  3drop drop
;

\ Return the number of cells per physical address
: .p-translations-#pacells ( -- #cells )
  " /" find-package if
    " #address-cells" rot get-package-property if
      1
    else
      decode-int nip nip 1 max
    then
  else
    1
  then
;

\ Return the number of cells per translation entry
: .p-translations-#cells ( -- #cells )
  [IFDEF] CONFIG_PPC
    my-#acells 3 *
    .p-translations-#pacells +
  [ELSE]
    my-#acells 3 *
  [THEN]
;

\ Set up column offsets
: .p-translations-cols ( -- col1 ... coln #cols )
  .p-translations-#cells 4 *
  [IFDEF] CONFIG_PPC
    4 -
    dup 4 -
    dup .p-translations-#pacells 4 * -
    3
  [ELSE]
    my-#acells 4 * -
    dup my-#scells 4 * -
    2
  [THEN]
;

\ Print the value of the MMU translations property
: .p-translations ( data len -- )
  >r >r .p-translations-cols r> r> ( col1 ... coln #cols data len )
  2dup + -rot ( col1 ... coln #cols data+len data len )
  >r >r .p-translations-#cells 4 * dup r> r>
  ( col1 ... coln #cols data+len #bytes #bytes len data )
  bounds ( col1 ... coln #cols data+len #bytes #bytes data+len data ) ?do
    3 pick 4 + 4 ?do				\ check all defined columns
      i pick over = if
        2 spaces					\ start new column
      then
    loop
    2dup <> if						\ non-first byte in row
      dup 3 and 0= if space then	\ make numbers more readable
    then
    i c@ 2 0.r						\ print byte
    1- dup 0= if					\ end of row
      2 pick i 1+ > if				\ non-last byte
        cr							\ start new line
        d# 26 spaces				\ indentation
      then
      drop dup						\ update counter
    then
  loop
  2drop drop 0 ?do drop loop
;

\ This function hardwires data formats to particular node properties
: (.property-by-name) ( name-str name-len data len -- )
  2over 2dup " reg" strcmp 0= -rot " assigned-addresses" strcmp 0= or if
    my-#acells my-#scells 2swap .p-reg
    2drop exit
  then

  active-package get-nodename " memory" strcmp 0= if
    2over " available" strcmp 0= if
      my-#acells my-#scells 2swap .p-reg
      2drop exit
    then
  then
  " /chosen" find-dev if
    " mmu" rot get-package-property 0= if
      decode-int nip nip ihandle>phandle active-package = if
        2over " available" strcmp 0= if
          my-#acells my-#scells 1 max 2swap .p-reg
          2drop exit
        then
        2over " translations" strcmp 0= if
          .p-translations
          2drop exit
        then
      then
    then
  then

  2swap 2drop ( data len )
  (.property)
;

: .properties    ( -- )
  ?active-package dup >r if
    0 0
    begin
      r@ next-property
    while
      cr 2dup dup -rot type
      begin ."  " 1+ dup d# 26 >= until drop
      2dup
      2dup active-package get-package-property drop
      ( name-str name-len data len )
      (.property-by-name)
    repeat
  then
  r> drop
  cr
;


\ 7.4.11    Device tree

: print-dev ( phandle -- phandle )
  dup u. 
  dup get-package-path type
  dup " device_type" rot get-package-property if
    cr 
  else
    ."  (" decode-string type ." )" cr 2drop
  then
  ;

: show-sub-devs ( subtree-phandle -- )
  print-dev
  >dn.child @
    begin dup while
      dup recurse
      >dn.peer @
    repeat
    drop
  ;

: show-all-devs    ( -- )
  active-package
  cr " /" find-device
  ?active-package show-sub-devs
  active-package!
  ;


: show-devs    ( "{device-specifier}<cr>" -- )
  active-package
  cr " /" find-device
  linefeed parse find-device
  ?active-package show-sub-devs
  active-package!
  ;



\ 7.4.11.3 Device probing

\ Set to true if the last probe-self was successful
0 value probe-fcode?

: probe-all    ( -- )
  ;