of816/ofw/of/node.fs

781 lines
23 KiB
Forth

\ Derived from IBM SLOF, modified by Michael Guidero
\ *****************************************************************************
\ * Copyright (c) 2004, 2008 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ * IBM Corporation - initial implementation
\ ****************************************************************************/
db" OF device node support (c) IBM"
false VALUE debug-find-component?
VARIABLE device-tree
VARIABLE current-node
: get-node current-node @ dup 0= ABORT" No active device tree node" ;
STRUCT
/n FIELD node>peer
/n FIELD node>parent
/n FIELD node>child
/n FIELD node>properties \ points to wid (grep wid>names)
/n FIELD node>words
/n FIELD node>instance-template
/n FIELD node>instance-size
/n FIELD node>space?
/n FIELD node>space
/n FIELD node>addr1
/n FIELD node>addr2
/n FIELD node>addr3
constant (node-size)
\ Original:
\ : find-method ( str len phandle -- false | xt true )
\ node>words @ voc-find dup IF link> true THEN ;
\ : find-method ( str len phandle -- false | xt true )
\ node>words @ search-wordlist IF true THEN ;
: find-method ( str len phandle -- false | xt true )
node>words @ voc-find dup IF true THEN ;
\ Instances.
#include <of/instance.fs>
db" OF - back to device tree"
: create-node ( parent -- new )
max-instance-size alloc-mem ( parent instance-mem )
dup max-instance-size erase >r ( parent R: instance-mem )
align wordlist >r $empty-wl >r ( parent R: instance-mem wl wl )
here ( parent new R: instance-mem wl wl )
0 , swap , 0 , \ Set node>peer, node>parent & node>child
r> , r> , \ Set node>properties & node>words to wl
r> , /instance-header , \ Set instance-template & instance-size
FALSE , 0 , \ Set node>space? and node>space
0 , 0 , 0 , \ Set node>addr*
;
: peer node>peer @ ;
: parent node>parent @ ;
: child node>child @ ;
: peer dup IF peer ELSE drop device-tree @ THEN ;
: link ( new head -- ) \ link a new node at the end of a linked list
BEGIN dup @ WHILE @ REPEAT ! ;
: link-node ( parent child -- )
swap dup IF node>child link ELSE drop device-tree ! THEN ;
\ Set a node as active node.
: set-node ( phandle -- )
current-node @ IF previous THEN
dup current-node !
?dup IF node>words @ also context ! THEN
definitions ;
: get-parent get-node parent ;
: new-node ( -- phandle ) \ active node becomes new node's parent;
\ new node becomes active node
\ XXX: change to get-node, handle root node creation specially
current-node @ dup create-node
tuck link-node dup set-node ;
: finish-node ( -- )
\ TODO: maybe resize the instance template buffer here (or in finish-device)?
get-node parent set-node
;
: device-end ( -- ) 0 set-node ;
\ Properties.
CREATE $indent 100 allot VARIABLE indent 0 indent !
#include <of/property.fs>
db" OF - back to device tree"
\ Unit address.
: #address-cells s" #address-cells" rot parent get-property
ABORT" parent doesn't have a #address-cells property!"
decode-int nip nip
;
\ my-#address-cells returns the #address-cells property of the parent node.
\ child-#address-cells returns the #address-cells property of the current node.
\ This is confusing in several ways: Remember that a node's address is always
\ described in the parent's address space, thus the parent's property is taken
\ into regard, rather than the own.
\ Also, an address-cell here is always a 32bit cell, no matter whether the
\ "real" cell size is 32bit or 64bit.
: my-#address-cells ( -- #address-cells )
get-node #address-cells
;
: child-#address-cells ( -- #address-cells )
s" #address-cells" get-node get-property
ABORT" node doesn't have a #address-cells property!"
decode-int nip nip
;
: child-#size-cells ( -- #address-cells )
s" #size-cells" get-node get-property
ABORT" node doesn't have a #size-cells property!"
decode-int nip nip
;
: encode-phys ( phys.hi ... phys.low -- prop len )
encode-first? IF encode-start ELSE here 0 THEN
my-#address-cells 0 ?DO rot encode-int+ LOOP
;
: encode-child-phys ( phys.hi ... phys.low -- prop len )
encode-first? IF encode-start ELSE here 0 THEN
child-#address-cells 0 ?DO rot encode-int+ LOOP
;
: encode-child-size ( size.hi ... size.low -- prop len )
encode-first? IF encode-start ELSE here 0 THEN
child-#size-cells 0 ?DO rot encode-int+ LOOP
;
: decode-phys
my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT drop
my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
: decode-phys-and-drop
my-#address-cells BEGIN dup WHILE 1- >r decode-int r> swap >r REPEAT 3drop
my-#address-cells BEGIN dup WHILE 1- r> swap REPEAT drop ;
: reg >r encode-phys r> encode-int+ s" reg" property ;
: >space node>space @ ;
: >space? node>space? @ ;
: >address dup >r #address-cells dup 3 > IF r@ node>addr3 @ swap THEN
dup 2 > IF r@ node>addr2 @ swap THEN
1 > IF r@ node>addr1 @ THEN r> drop ;
: >unit dup >r >address r> >space ;
: (my-phandle) ( -- phandle )
my-self ?dup IF
ihandle>phandle
ELSE
get-node dup 0= ABORT" no active node"
THEN
;
: my-space ( -- phys.hi )
(my-phandle) >space
;
: my-address (my-phandle) >address ;
\ my-unit returns the unit address of the current _instance_ - that means
\ it returns the same values as my-space and my-address together _or_ it
\ returns a unit address that has been set manually while opening the node.
: my-unit
my-self instance>#units @ IF
0 my-self instance>#units @ 1- DO
my-self instance>unit1 i cells + @
-1 +LOOP
ELSE
my-self ihandle>phandle >unit
THEN
;
\ Return lower 64 bit of address
: my-unit-64 ( -- phys.lo+1|phys.lo )
my-unit ( phys.lo ... phys.hi )
(my-phandle) #address-cells ( phys.lo ... phys.hi #ad-cells )
CASE
1 OF EXIT ENDOF
\ 2 OF lxjoin EXIT ENDOF
\ 3 OF drop lxjoin EXIT ENDOF
\ dup OF 2drop lxjoin EXIT ENDOF
ENDCASE
;
: set-space get-node dup >r node>space ! true r> node>space? ! ;
: set-address my-#address-cells 1 ?DO
get-node node>space i cells + ! LOOP ;
: set-unit set-space set-address ;
\ : set-unit-64 ( phys.lo|phys.hi -- )
\ my-#address-cells 2 <> IF
\ ." set-unit-64: #address-cells <> 2 " abort
\ THEN
\ xlsplit set-unit
\ ;
\ Never ever use this in actual code, only when debugging interactively.
\ Thank you.
: set-args ( arg-str len unit-str len -- )
s" decode-unit" get-parent $call-static set-unit set-my-args
;
: $cat-unit
dup parent 0= IF drop EXIT THEN
dup >space? not IF drop EXIT THEN
dup >r >unit s" encode-unit" r> parent $call-static
dup IF
dup >r here swap move s" @" $cat here r> $cat
ELSE
2drop
THEN
;
: $cat-instance-unit
dup parent 0= IF drop EXIT THEN
\ No instance unit, use node unit
dup instance>#units @ 0= IF
ihandle>phandle $cat-unit
EXIT
THEN
dup >r push-my-self
['] my-unit CATCH IF pop-my-self r> drop EXIT THEN
pop-my-self
s" encode-unit"
r> ihandle>phandle parent
$call-static
dup IF
dup >r here swap move s" @" $cat here r> $cat
ELSE
2drop
THEN
;
\ Getting basic info about a node.
: node>name dup >r s" name" rot get-property IF r> (u.) ELSE 1- r> drop THEN ;
: node>qname dup node>name rot ['] $cat-unit CATCH IF drop THEN ;
: node>path
here 0 rot
BEGIN dup WHILE dup parent REPEAT
2drop
dup 0= IF [char] / c, THEN
BEGIN
dup
WHILE
[char] / c, node>qname here over allot swap move
REPEAT
drop here 2dup - allot over -
;
: interposed? ( ihandle -- flag )
\ We cannot actually detect if an instance is interposed; instead, we look
\ if an instance is part of the "normal" chain that would be opened by
\ open-dev and friends, if there were no interposition.
dup instance>parent @ dup 0= IF 2drop false EXIT THEN
ihandle>phandle swap ihandle>phandle parent <> ;
: instance>qname
dup >r interposed? IF s" %" ELSE 0 0 THEN
r@ dup ihandle>phandle node>name
rot ['] $cat-instance-unit CATCH IF drop THEN
$cat r> instance>args 2@ swap
dup IF 2>r s" :" $cat 2r> $cat ELSE 2drop THEN
;
: instance>qpath \ With interposed nodes.
here 0 rot BEGIN dup WHILE dup instance>parent @ REPEAT 2drop
dup 0= IF [char] / c, THEN
BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
REPEAT drop here 2dup - allot over - ;
: instance>path \ Without interposed nodes.
here 0 rot BEGIN dup WHILE
dup interposed? 0= IF dup THEN instance>parent @ REPEAT 2drop
dup 0= IF [char] / c, THEN
BEGIN dup WHILE [char] / c, instance>qname here over allot swap move
REPEAT drop here 2dup - allot over - ;
: .node node>path type ;
: pwd get-node .node ;
: .instance instance>qpath type ;
: .chain dup instance>parent @ ?dup IF recurse THEN
cr dup . instance>qname type ;
\ Alias helper
defer find-node
: set-alias ( alias-name len device-name len -- )
encode-string
2swap s" /aliases" find-node ?dup IF
set-property
ELSE
4drop
THEN
;
: find-alias ( alias-name len -- false | dev-path len )
s" /aliases" find-node dup IF
get-property 0= IF 1- dup 0= IF nip THEN ELSE false THEN
THEN
;
: .alias ( alias-name len -- )
find-alias dup IF type ELSE ." no alias available" THEN ;
\ fixed for OF816
: (.print-alias) ( lfa -- )
\ Don't print smudged alias
dup lfa>xt c@ (f_smudg) and IF
drop EXIT
THEN
dup lfa>name
\ Don't print name property
2dup s" name" string=ci IF 2drop drop
ELSE cr type space ." : " lfa>xt execute type
THEN ;
\ fixed for OF816
: (.list-alias) ( phandle -- )
node>properties @ @ BEGIN dup WHILE dup (.print-alias) @ REPEAT drop ;
: list-alias ( -- )
s" /aliases" find-node dup IF (.list-alias) THEN ;
\ return next available name for aliasing or
\ false if more than MAX-ALIAS aliases found
d# 10 CONSTANT MAX-ALIAS
1 VALUE alias-ind
: get-next-alias ( $alias-name -- $next-alias-name|FALSE )
2dup find-alias IF
drop
1 TO alias-ind
BEGIN
2dup alias-ind $cathex 2dup find-alias
WHILE
drop 2drop
alias-ind 1 + TO alias-ind
alias-ind MAX-ALIAS = IF
2drop FALSE EXIT
THEN
REPEAT
strdup 2swap 2drop
THEN
;
: devalias ( "{alias-name}<>{device-specifier}<cr>" -- )
parse-word parse-word dup IF set-alias
ELSE 2drop dup IF .alias
ELSE 2drop list-alias THEN THEN ;
\ sub-alias does a single iteration of an alias at the beginning od dev path
\ expression. de-alias will repeat this until all indirect alising is resolved
: sub-alias ( arg-str arg-len -- arg' len' | false )
2dup
2dup [char] / findchar ?dup IF ELSE 2dup [char] : findchar THEN
( a l a l [p] -1|0 ) IF nip dup ELSE 2drop 0 THEN >r
( a l l p -- R:p | a l -- R:0 )
find-alias ?dup IF ( a l a' p' -- R:p | a' l' -- R:0 )
r@ IF
2swap r@ - swap r> + swap $cat strdup ( a" l-p+p' -- )
ELSE
( a' l' -- R:0 ) r> drop ( a' l' -- )
THEN
ELSE
( a l -- R:p | -- R:0 ) r> IF 2drop THEN
false ( 0 -- )
THEN
;
: de-alias ( arg-str arg-len -- arg' len' )
BEGIN
over c@ [char] / <> dup IF drop 2dup sub-alias ?dup THEN
WHILE
2swap 2drop
REPEAT
;
\ Display the device tree.
: +indent ( not-last? -- )
IF s" | " ELSE s" " THEN $indent indent @ + swap move 4 indent +! ;
: -indent ( -- ) -4 indent +! ;
: ls-phandle ( node -- ) . ." : " ;
: ls-node ( node -- )
cr dup ls-phandle
$indent indent @ type
dup peer IF ." |-- " ELSE ." +-- " THEN
node>qname type
;
: (ls) ( node -- )
child BEGIN dup WHILE dup ls-node dup child IF
dup peer +indent dup recurse -indent THEN peer REPEAT drop ;
: ls ( -- )
get-node cr
dup ls-phandle
dup node>path type
(ls)
0 indent !
;
: show-devs ( {device-specifier}<eol> -- )
parse-word dup IF de-alias ELSE 2drop s" /" THEN ( str len )
find-node dup 0= ABORT" No such device path" (ls)
;
VARIABLE interpose-node
2VARIABLE interpose-args
: interpose ( arg len phandle -- ) interpose-node ! interpose-args 2! ;
0 VALUE user-instance-#units
CREATE user-instance-units 4 cells allot
\ Copy the unit information (specified by the user) that we've found during
\ "find-component" into the current instance data structure
: copy-instance-unit ( -- )
user-instance-#units IF
user-instance-#units my-self instance>#units !
user-instance-units my-self instance>unit1 user-instance-#units cells move
0 to user-instance-#units
THEN
;
: open-node ( arg len phandle -- ihandle|0 )
current-node @ >r my-self >r \ Save current node and instance
set-node create-instance set-my-args
copy-instance-unit
\ Execute "open" method if available, and assume default of
\ success (=TRUE) for nodes without open method:
s" open" get-node find-method IF execute ELSE TRUE THEN
0= IF
my-self destroy-instance 0 to my-self
THEN
my-self ( ihandle|0 )
r> to my-self r> set-node \ Restore current node and instance
\ Handle interposition:
interpose-node @ IF
my-self >r to my-self
interpose-args 2@ interpose-node @
interpose-node off recurse
r> to my-self
THEN
;
: close-node ( ihandle -- )
my-self >r to my-self
s" close" ['] $call-my-method CATCH IF 2drop THEN
my-self destroy-instance r> to my-self ;
: close-dev ( ihandle -- )
my-self >r to my-self
BEGIN my-self WHILE my-parent my-self close-node to my-self REPEAT
r> to my-self ;
: new-device ( -- )
[: ." New device: " ;] dbexec \ OF816 debug
my-self new-node ( parent-ihandle phandle )
node>instance-template @ ( parent-ihandle ihandle )
dup to my-self ( parent-ihanlde ihandle )
instance>parent !
get-node my-self instance>node !
max-instance-size my-self instance>size !
;
: finish-device ( -- )
\ Set unit address to first entry of reg property if it has not been set yet
get-node >space? 0= IF
s" reg" get-node get-property 0= IF
decode-int set-space 2drop
THEN
THEN
finish-node my-parent to my-self
;
\ Set the instance template as current instance for extending it
\ (i.e. to be able to declare new INSTANCE VARIABLEs etc. there)
: extend-device ( phandle -- )
my-self >r
dup set-node
node>instance-template @
dup to my-self
r> swap instance>parent !
;
: split ( str len char -- left len right len )
>r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
: generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
$number IF 0 THEN r> swap >r >r REPEAT r> 3drop
BEGIN dup WHILE 1- r> swap REPEAT drop ;
: generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
: hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
base @ >r hex generic-decode-unit r> base ! ;
: hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
base @ >r hex generic-encode-unit r> base ! ;
\ : hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi )
\ dup 2 <> IF
\ hex-decode-unit
\ ELSE
\ drop
\ base @ >r hex
\ $number IF 0 0 ELSE xlsplit THEN
\ r> base !
\ THEN
\ ;
\ : hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len )
\ dup 2 <> IF
\ hex-encode-unit
\ ELSE
\ drop
\ base @ >r hex
\ lxjoin (u.)
\ r> base !
\ THEN
\ ;
: handle-leading-/ ( path len -- path' len' )
dup IF over c@ [char] / = IF 1 /string device-tree @ set-node THEN THEN ;
: match-name ( name len node -- match? )
over 0= IF 3drop true EXIT THEN
s" name" rot get-property IF 2drop false EXIT THEN
1- string=ci ; \ XXX should use decode-string
0 VALUE #search-unit
CREATE search-unit 4 cells allot
: match-unit ( node -- match? )
\ A node with no space is a wildcard and will always match
dup >space? IF
node>space search-unit #search-unit 0 ?DO 2dup @ swap @ <> IF
2drop false UNLOOP EXIT THEN cell+ swap cell+ swap LOOP 2drop true
ELSE drop true THEN
;
: match-node ( name len node -- match? )
dup >r match-name r> match-unit and ; \ XXX e3d
: find-kid ( name len -- node|0 )
dup -1 = IF \ are we supposed to stay in the same node? -> resolve-relatives
2drop get-node
ELSE
get-node child >r BEGIN r@ WHILE 2dup r@ match-node
IF 2drop r> EXIT THEN r> peer >r REPEAT
r> 3drop false
THEN ;
: set-search-unit ( unit len -- )
0 to #search-unit
0 to user-instance-#units
dup 0= IF 2drop EXIT THEN
s" #address-cells" get-node get-property THROW
decode-int to #search-unit 2drop
s" decode-unit" get-node $call-static
( ) #search-unit 0 ?DO search-unit i cells + ! LOOP
;
: resolve-relatives ( path len -- path' len' )
\ handle ..
2dup 2 = swap s" .." comp 0= and IF
get-node parent ?dup IF
set-node drop -1
ELSE
s" Already in root node." type
THEN
THEN
\ handle .
2dup 1 = swap c@ [CHAR] . = and IF
drop -1
THEN
;
\ XXX This is an old hack that allows wildcard nodes to work
\ by not having a #address-cells in the parent and no
\ decode unit. This should be removed.
\ (It appears to be still used on js2x)
: set-instance-unit ( unitaddr len -- )
dup 0= IF 2drop 0 to user-instance-#units EXIT THEN
2dup 0 -rot bounds ?DO
i c@ [char] , = IF 1+ THEN \ Count the commas
LOOP
1+ dup to user-instance-#units
hex-decode-unit
user-instance-#units 0 ?DO
user-instance-units i cells + !
LOOP
;
: split-component ( path. -- path'. args. name. unit. )
[char] / split 2swap ( path'. component. )
[char] : split 2swap ( path'. args. name@unit. )
[char] @ split ( path'. args. name. unit. )
;
: find-component ( path len -- path' len' args len node|0 )
debug-find-component? IF
." find-component for " 2dup type cr
THEN
split-component ( path'. args. name. unit. )
debug-find-component? IF
." -> unit =" 2dup type cr
." -> stack =" .s cr
THEN
['] set-search-unit CATCH IF
\ XXX: See comment in set-instance-unit
." WARNING: Obsolete old wildcard hack " .s cr
set-instance-unit
THEN
resolve-relatives find-kid ( path' len' args len node|0 )
\ If resolve returned a wildcard node, and we haven't hit
\ the above gross hack then copy the unit
dup IF dup >space? not #search-unit 0 > AND user-instance-#units 0= AND IF
( ) #search-unit dup to user-instance-#units 0 ?DO
search-unit i cells + @ user-instance-units i cells + !
LOOP
THEN THEN
\ XXX This can go away with the old wildcard hack
dup IF dup >space? user-instance-#units 0 > AND IF
\ User supplied a unit value, but node also has different physical unit
cr ." find-component with unit mismatch!" .s cr
drop 0
THEN THEN
;
: .find-node ( path len -- phandle|0 )
current-node @ >r
handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
BEGIN dup WHILE \ handle one component:
find-component ( path len args len node ) dup 0= IF
3drop 2drop r> set-node 0 EXIT THEN
set-node 2drop REPEAT 2drop
get-node r> set-node ;
' .find-node to find-node
: find-node ( path len -- phandle|0 ) de-alias find-node ;
: delete-node ( phandle -- )
dup node>instance-template @ max-instance-size free-mem
dup node>parent @ node>child @ ( phandle 1st peer )
2dup = IF
node>peer @ swap node>parent @ node>child !
EXIT
THEN
dup node>peer @
BEGIN
2 pick 2dup <>
WHILE
drop
nip dup node>peer @
dup 0= IF 2drop drop unloop EXIT THEN
REPEAT
drop
node>peer @ swap node>peer !
drop
;
: open-dev ( path len -- ihandle|0 )
0 to user-instance-#units
de-alias current-node @ >r
handle-leading-/ current-node @ 0= IF 2drop r> set-node 0 EXIT THEN
my-self >r
0 to my-self
0 0 >r >r
BEGIN
dup
WHILE \ handle one component:
( arg len ) r> r> get-node open-node to my-self
find-component ( path len args len node ) dup 0= IF
3drop 2drop my-self close-dev
r> to my-self
r> set-node
0 EXIT
THEN
set-node
>r >r
REPEAT
2drop
\ open final node
r> r> get-node open-node to my-self
my-self r> to my-self r> set-node
;
: select-dev open-dev dup to my-self ihandle>phandle set-node ;
: unselect-dev my-self close-dev 0 to my-self device-end ;
: find-device ( str len -- ) \ set as active node
find-node dup 0= ABORT" No such device path" set-node ;
: dev parse-word find-device ;
: (lsprop) ( node --)
dup cr $indent indent @ type ." node: " node>qname type
false +indent (.properties) cr -indent
;
: (show-children) ( node -- )
child BEGIN
dup
WHILE
dup (lsprop) dup child IF false +indent dup recurse -indent THEN peer
REPEAT
drop
;
: lsprop ( {device-specifier}<eol> -- )
parse-word dup IF de-alias ELSE 2drop s" /" THEN
find-device get-node dup dup
cr ." node: " node>path type (.properties) cr (show-children)
0 indent !
;
\ node>path does not allot the memory, since it is internally only used
\ for typing.
\ The external variant needs to allot memory !
: (node>path) node>path ;
: node>path ( phandle -- str len )
node>path dup allot
;
\ Support for support packages.
\ The /packages node.
0 VALUE packages
\ Find a support package (or arbitrary nodes when name is absolute)
: find-package ( name len -- false | phandle true )
dup 0 <= IF
2drop FALSE EXIT
THEN
\ According to IEEE 1275 Proposal 215 (Extensible Client Services Package),
\ the find-package method can be used to get the phandle of arbitrary nodes
\ (i.e. not only support packages) when the name starts with a slash.
\ Some FCODE programs depend on this behavior so let's support this, too!
over c@ [char] / = IF
find-node dup IF TRUE THEN EXIT
THEN
\ Ok, let's look for support packages instead. We can't use the standard
\ find-node stuff, as we are required to find the newest (i.e., last in our
\ tree) matching package, not just any.
0 >r packages child
BEGIN
dup
WHILE
dup >r node>name 2over string=ci r> swap IF
r> drop dup >r
THEN
peer
REPEAT
3drop
r> dup IF true THEN
;
: open-package ( arg len phandle -- ihandle | 0 ) open-node ;
: close-package ( ihandle -- ) close-node ;
: $open-package ( arg len name len -- ihandle | 0 )
find-package IF open-package ELSE 2drop false THEN ;
\ device tree translate-address
\ #include <translate.fs>