diff options
Diffstat (limited to 'qemu/roms/openbios/forth/device/pathres.fs')
| -rw-r--r-- | qemu/roms/openbios/forth/device/pathres.fs | 522 |
1 files changed, 522 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/device/pathres.fs b/qemu/roms/openbios/forth/device/pathres.fs new file mode 100644 index 000000000..a185b95a1 --- /dev/null +++ b/qemu/roms/openbios/forth/device/pathres.fs @@ -0,0 +1,522 @@ +\ tag: Path resolution +\ +\ this code implements IEEE 1275-1994 path resolution +\ +\ Copyright (C) 2003 Samuel Rydh +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +0 value interpose-ph +0 0 create interpose-args , , + +: expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? ) + 2dup + " /aliases" find-dev 0= if 2drop false exit then + get-package-property if + false + else + 2swap 2drop + \ drop trailing 0 from string + dup if 1- then + true + then +; + +\ +\ 4.3.1 Resolve aliases +\ + +\ the returned string is allocated with alloc-mem +: pathres-resolve-aliases ( path-addr path-len -- path-addr path-len ) + over c@ 2f <> if + 200 here + >r \ abuse dictionary for temporary storage + + \ If the pathname does not begin with "/", and its first node name + \ component is an alias, replace the alias with its expansion. + ascii / split-before \ (PATH_NAME, "/") -> (TAIL HEAD) + ascii : split-before \ (HEAD, ":") -> (ALIAS_ARGS AL_NAME) + expand-alias ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? ) + if + 2 pick 0<> if \ If ALIAS_ARGS is not empty + ascii / split-after \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/) + 2swap ( TAIL AL_HEAD/ AL_TAIL ) + ascii : split-before \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL) + 2swap 2drop ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL ) + 2swap ( TAIL AL_ARGS AL_TAIL AL_HEAD ) + r> tmpstrcat tmpstrcat >r + else + 2swap 2drop \ drop ALIAS_ARGS + then + r> tmpstrcat drop + else + \ put thing back together again + r> tmpstrcat tmpstrcat drop + then + then + + strdup + ( path-addr path-len ) +; + +\ +\ search struct +\ + +struct ( search information ) + 2 cells field >si.path + 2 cells field >si.arguments + 2 cells field >si.unit_addr + 2 cells field >si.node_name + 2 cells field >si.free_me + 4 cells field >si.unit_phys + /n field >si.unit_phys_len + /n field >si.save-ihandle + /n field >si.save-phandle + /n field >si.top-ihandle + /n field >si.top-opened \ set after successful open + /n field >si.child \ node to match +constant sinfo.size + + +\ +\ 4.3.6 node name match criteria +\ + +: match-nodename ( childname len sinfo -- match? ) + >r + 2dup r@ >si.node_name 2@ + ( [childname] [childname] [nodename] ) + strcmp 0= if r> 3drop true exit then + + \ does NODE_NAME contain a comma? + r@ >si.node_name 2@ ascii , strchr + if r> 3drop false exit then + + ( [childname] ) + ascii , left-split 2drop r@ >si.node_name 2@ + r> drop + strcmp if false else true then +; + + +\ +\ 4.3.4 exact match child node +\ + +\ If NODE_NAME is not empty, make sure it matches the name property +: common-match ( sinfo -- ) + >r + \ a) NODE_NAME nonempty + r@ >si.node_name 2@ nip if + " name" r@ >si.child @ get-package-property if -1 throw then + \ name is supposed to be null-terminated + dup 0> if 1- then + \ exit if NODE_NAME does not match + r@ match-nodename 0= if -2 throw then + then + r> drop +; + +: (exact-match) ( sinfo -- ) + >r + \ a) If NODE_NAME is not empty, make sure it matches the name property + r@ common-match + + \ b) UNIT_PHYS nonempty? + r@ >si.unit_phys_len @ /l* ?dup if + \ check if unit_phys matches + " reg" r@ >si.child @ get-package-property if -3 throw then + ( unitbytes propaddr proplen ) + rot r@ >si.unit_phys -rot + ( propaddr unit_phys proplen unitbytes ) + swap over < if -4 throw then + comp if -5 throw then + else + \ c) both NODE_NAME and UNIT_PHYS empty? + r@ >si.node_name 2@ nip 0= if -6 throw then + then + + r> drop +; + +: exact-match ( sinfo -- match? ) + ['] (exact-match) catch if drop false exit then + true +; + +\ +\ 4.3.5 wildcard match child node +\ + +: (wildcard-match) ( sinfo -- match? ) + >r + \ a) If NODE_NAME is not empty, make sure it matches the name property + r@ common-match + + \ b) Fail if "reg" property exist + " reg" r@ >si.child @ get-package-property 0= if -7 throw then + + \ c) Fail if both NODE_NAME and UNIT_ADDR are both empty + r@ >si.unit_phys_len @ + r@ >si.node_name 2@ nip + or 0= if -1 throw then + + \ SUCCESS + r> drop +; + +: wildcard-match ( sinfo -- match? ) + ['] (wildcard-match) catch if drop false exit then + true +; + + +\ +\ 4.3.3 match child node +\ + +\ used if package lacks a decode-unit method +: def-decode-unit ( str len -- unitaddr ... ) + parse-hex +; + +: get-decode-unit-xt ( phandle -- xt ) + " decode-unit" rot find-method + 0= if ['] def-decode-unit then +; + +: find-child ( sinfo -- phandle ) + >r + \ decode unit address string + r@ >si.unit_addr 2@ dup if + ( str len ) + active-package get-decode-unit-xt + depth 3 - >r execute depth r@ - r> swap + ( ... a_lo ... a_hi olddepth n ) + 4 min 0 max + dup r@ >si.unit_phys_len ! + ( ... a_lo ... a_hi olddepth n ) + r@ >si.unit_phys >r + begin 1- dup 0>= while + rot r> dup la1+ >r l!-be + repeat + r> 2drop + depth! + else + 2drop + \ clear unit_phys + 0 r@ >si.unit_phys_len ! + \ r@ >si.unit_phys 4 cells 0 fill + then + + ( R: sinfo ) + ['] exact-match + begin dup while + active-package >dn.child @ + begin ?dup while + dup r@ >si.child ! + ( xt phandle R: sinfo ) + r@ 2 pick execute if 2drop r> >si.child @ exit then + >dn.peer @ + repeat + ['] exact-match = if ['] wildcard-match else 0 then + repeat + + -99 throw +; + + +\ +\ 4.3.2 Create new linked instance procedure +\ + +: link-one ( sinfo -- ) + >r + active-package create-instance + dup 0= if -99 throw then + + \ change instance parent + r@ >si.top-ihandle @ over >in.my-parent ! + dup r@ >si.top-ihandle ! + to my-self + + \ b) set my-args field + r@ >si.arguments 2@ strdup my-self >in.arguments 2! + + \ e) set my-unit field + r@ >si.unit_addr 2@ nip if + \ copy UNIT_PHYS to the my-unit field + r@ >si.unit_phys my-self >in.my-unit 4 cells move + else + \ set unit-addr from reg property + " reg" active-package get-package-property 0= if + \ ( ihandle prop proplen ) + \ copy address to my-unit + 4 cells min my-self >in.my-unit swap move + else + \ clear my-unit + my-self >in.my-unit 4 cells 0 fill + then + then + + \ top instance has not been opened (yet) + false r> >si.top-opened ! +; + +: invoke-open ( sinfo -- ) + " open" my-self ['] $call-method + catch if 3drop false then + 0= if -99 throw then + + true swap >si.top-opened ! +; + +\ +\ 4.3.7 Handle interposers procedure (supplement) +\ + +: handle-interposers ( sinfo -- ) + >r + begin + interpose-ph ?dup + while + 0 to interpose-ph + active-package swap active-package! + + \ clear unit address and set arguments + 0 0 r@ >si.unit_addr 2! + interpose-args 2@ r@ >si.arguments 2! + r@ link-one + true my-self >in.interposed ! + interpose-args 2@ free-mem + r@ invoke-open + + active-package! + repeat + + r> drop +; + +\ +\ 4.3.1 Path resolution procedure +\ + +\ close-dev ( ihandle -- ) +\ +: close-dev + begin + dup + while + dup >in.my-parent @ + swap close-package + repeat + drop +; + +: path-res-cleanup ( sinfo close? ) + + \ tear down all instances if close? is set + if + dup >si.top-opened @ if + dup >si.top-ihandle @ + ?dup if close-dev then + else + dup >si.top-ihandle @ dup + ( sinfo ihandle ihandle ) + dup if >in.my-parent @ swap then + ( sinfo parent ihandle ) + ?dup if destroy-instance then + ?dup if close-dev then + then + then + + \ restore active-package and my-self + dup >si.save-ihandle @ to my-self + dup >si.save-phandle @ active-package! + + \ free any allocated memory + dup >si.free_me 2@ free-mem + sinfo.size free-mem +; + +: (path-resolution) ( context sinfo -- ) + >r r@ >si.path 2@ + ( context pathstr pathlen ) + + \ this allocates a copy of the string + pathres-resolve-aliases + 2dup r@ >si.free_me 2! + + \ If the pathname, after possible alias expansion, begins with "/", + \ begin the search at the root node. Otherwise, begin at the active + \ package. + + dup if \ make sure string is not empty + over c@ 2f = if + swap char+ swap /c - \ Remove the "/" from PATH_NAME. + \ Set the active package to the root node. + device-tree @ active-package! + then + then + + r@ >si.path 2! + 0 0 r@ >si.unit_addr 2! + 0 0 r@ >si.arguments 2! + 0 r@ >si.top-ihandle ! + + \ If there is no active package, exit this procedure, returning false. + ( context ) + active-package 0= if -99 throw then + + \ Begin the creation of an instance chain. + \ NOTE--If, at this step, the active package is not the root node and + \ we are in open-dev or execute-device-method contexts, the instance + \ chain that results from the path resolution process may be incomplete. + + active-package swap + ( virt-active-node context ) + begin + r@ >si.path 2@ nip \ nonzero path? + while + \ ( active-node context ) + \ is this open-dev or execute-device-method context? + dup if + r@ link-one + over active-package <> my-self >in.interposed ! + r@ invoke-open + r@ handle-interposers + then + over active-package! + + r@ >si.path 2@ ( PATH ) + + ascii / left-split ( PATH COMPONENT ) + ascii : left-split ( PATH ARGS NODE_ADDR ) + ascii @ left-split ( PATH ARGS UNIT_ADDR NODE_NAME ) + + r@ >si.node_name 2! + r@ >si.unit_addr 2! + r@ >si.arguments 2! + r@ >si.path 2! + + ( virt-active-node context ) + + \ 4.3.1 i) pathname has a leading %? + r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if + 1- swap 1+ swap r@ >si.node_name 2! + " /packages" find-dev drop active-package! + r@ find-child + else + 2drop + nip r@ find-child swap over + ( new-node context new-node ) + then + + \ (optional: open any nodes between parent and child ) + + active-package! + repeat + + ( virt-active-node type ) + dup if r@ link-one then + 1 = if + dup active-package <> my-self >in.interposed ! + r@ invoke-open + r@ handle-interposers + then + active-package! + + r> drop +; + +: path-resolution ( context path-addr path-len -- sinfo true | false ) + \ allocate and clear the search block + sinfo.size alloc-mem >r + r@ sinfo.size 0 fill + + \ store path + r@ >si.path 2! + + \ save ihandle and phandle + my-self r@ >si.save-ihandle ! + active-package r@ >si.save-phandle ! + + \ save context (if we take an exception) + dup + + r@ ['] (path-resolution) + catch ?dup if + ( context xxx xxx error ) + r> true path-res-cleanup + + \ rethrow everything except our "cleanup throw" + dup -99 <> if throw then + 3drop + + \ ( context ) throw an exception if this is find-device context + if false else -22 throw then + exit + then + + \ ( context ) + drop r> true + ( sinfo true ) +; + + +: open-dev ( dev-str dev-len -- ihandle | 0 ) + 1 -rot path-resolution 0= if false exit then + + ( sinfo ) + my-self swap + false path-res-cleanup + + ( ihandle ) +; + +: execute-device-method +( ... dev-str dev-len met-str met-len -- ... false | ?? true ) + 2swap + 2 -rot path-resolution 0= if 2drop false exit then + ( method-str method-len sinfo ) + >r + my-self ['] $call-method catch + if 3drop false else true then + r> true path-res-cleanup +; + +: find-device ( dev-str dev-len -- ) + 2dup " .." strcmp 0= if + 2drop + active-package dup if >dn.parent @ then + \ ".." in root note? + dup 0= if -22 throw then + active-package! + exit + then + 0 -rot path-resolution 0= if false exit then + ( sinfo ) + active-package swap + true path-res-cleanup + active-package! +; + +\ find-device, but without side effects +: (find-dev) ( dev-str dev-len -- phandle true | false ) + active-package -rot + ['] find-device catch if 3drop false exit then + active-package swap active-package! true +; + +\ Tuck on a node at the end of the chain being created. +\ This implementation follows the interpose recommended practice +\ (v0.2 draft). + +: interpose ( arg-str arg-len phandle -- ) + to interpose-ph + strdup interpose-args 2! +; + +['] (find-dev) to find-dev |