qemu/roms/openbios/forth/device/pathres.fs

   1 \ tag: Path resolution
   2 \
   3 \ this code implements IEEE 1275-1994 path resolution
   4 \
   5 \ Copyright (C) 2003 Samuel Rydh
   6 \
   7 \ See the file "COPYING" for further information about
   8 \ the copyright and warranty status of this work.
   9 \
  10
  11 0 value interpose-ph
  12 0 0 create interpose-args , ,
  13
  14 : expand-alias ( alias-addr alias-len -- exp-addr exp-len expanded? )
  15   2dup
  16   " /aliases" find-dev 0= if 2drop false exit then
  17   get-package-property if
  18     false
  19   else
  20     2swap 2drop
  21     \ drop trailing 0 from string
  22     dup if 1- then
  23     true
  24   then
  25 ;
  26
  27 \
  28 \ 4.3.1 Resolve aliases
  29 \
  30
  31 \ the returned string is allocated with alloc-mem
  32 : pathres-resolve-aliases ( path-addr path-len -- path-addr path-len )
  33   over c@ 2f <> if
  34     200 here + >r                \ abuse dictionary for temporary storage
  35
  36     \ If the pathname does not begin with "/", and its first node name
  37     \ component is an alias, replace the alias with its expansion.
  38     ascii / split-before         \ (PATH_NAME, "/")  -> (TAIL HEAD)
  39     ascii : split-before         \ (HEAD, ":")  ->  (ALIAS_ARGS AL_NAME)
  40     expand-alias                 ( TAIL ALIAS_ARGS EXP_ALIAS_NAME expanded? )
  41     if
  42       2 pick 0<> if              \ If ALIAS_ARGS is not empty
  43         ascii / split-after      \ (ALIAS_NAME, "/") -> (AL_TAIL AL_HEAD/)
  44         2swap                    ( TAIL AL_HEAD/ AL_TAIL )
  45         ascii : split-before     \ (AL_TAIL, ":") -> (DEAD_ARGS AL_TAIL)
  46         2swap 2drop              ( TAIL AL_ARGS AL_HEAD ALIAS_TAIL )
  47         2swap                    ( TAIL AL_ARGS AL_TAIL AL_HEAD )
  48         r> tmpstrcat tmpstrcat >r
  49       else
  50         2swap 2drop              \ drop ALIAS_ARGS
  51       then
  52       r> tmpstrcat drop
  53     else
  54       \ put thing back together again
  55       r> tmpstrcat tmpstrcat drop
  56     then
  57   then
  58
  59   strdup
  60   ( path-addr path-len )
  61 ;
  62
  63 \
  64 \ search struct
  65 \
  66
  67 struct ( search information )
  68   2 cells field >si.path
  69   2 cells field >si.arguments
  70   2 cells field >si.unit_addr
  71   2 cells field >si.node_name
  72   2 cells field >si.free_me
  73   4 cells field >si.unit_phys
  74   /n field >si.unit_phys_len
  75   /n field >si.save-ihandle
  76   /n field >si.save-phandle
  77   /n field >si.top-ihandle
  78   /n field >si.top-opened        \ set after successful open
  79   /n field >si.child            \ node to match
  80 constant sinfo.size
  81
  82
  83 \
  84 \ 4.3.6 node name match criteria
  85 \
  86
  87 : match-nodename ( childname len sinfo -- match? )
  88   >r
  89   2dup r@ >si.node_name 2@
  90   ( [childname] [childname] [nodename] )
  91   strcmp 0= if r> 3drop true exit then
  92
  93   \ does NODE_NAME contain a comma?
  94   r@ >si.node_name 2@ ascii , strchr
  95   if r> 3drop false exit then
  96
  97   ( [childname] )
  98   ascii , left-split 2drop r@ >si.node_name 2@
  99   r> drop
 100   strcmp if false else true then
 101 ;
 102
 103
 104 \
 105 \ 4.3.4 exact match child node
 106 \
 107
 108 \ If NODE_NAME is not empty, make sure it matches the name property
 109 : common-match ( sinfo -- )
 110   >r
 111   \ a) NODE_NAME nonempty
 112   r@ >si.node_name 2@ nip if
 113     " name" r@ >si.child @ get-package-property if -1 throw then
 114     \ name is supposed to be null-terminated
 115     dup 0> if 1- then
 116     \ exit if NODE_NAME does not match
 117     r@ match-nodename 0= if -2 throw then
 118   then
 119   r> drop
 120 ;
 121
 122 : (exact-match) ( sinfo -- )
 123   >r
 124   \ a) If NODE_NAME is not empty, make sure it matches the name property
 125   r@ common-match
 126
 127   \ b) UNIT_PHYS nonempty?
 128   r@ >si.unit_phys_len @ /l* ?dup if
 129     \ check if unit_phys matches
 130     " reg" r@ >si.child @ get-package-property if -3 throw then
 131     ( unitbytes propaddr proplen )
 132     rot r@ >si.unit_phys -rot
 133     ( propaddr unit_phys proplen unitbytes )
 134     swap over < if -4 throw then
 135     comp if -5 throw then
 136   else
 137     \ c) both NODE_NAME and UNIT_PHYS empty?
 138     r@ >si.node_name 2@ nip 0= if -6 throw then
 139   then
 140
 141   r> drop
 142 ;
 143
 144 : exact-match ( sinfo -- match? )
 145   ['] (exact-match) catch if drop false exit then
 146   true
 147 ;
 148
 149 \
 150 \ 4.3.5 wildcard match child node
 151 \
 152
 153 : (wildcard-match) ( sinfo -- match? )
 154   >r
 155   \ a) If NODE_NAME is not empty, make sure it matches the name property
 156   r@ common-match
 157
 158   \ b) Fail if "reg" property exist
 159   " reg" r@ >si.child @ get-package-property 0= if -7 throw then
 160
 161   \ c) Fail if both NODE_NAME and UNIT_ADDR are both empty
 162   r@ >si.unit_phys_len @
 163   r@ >si.node_name 2@ nip
 164   or 0= if -1 throw then
 165
 166   \ SUCCESS
 167   r> drop
 168 ;
 169
 170 : wildcard-match ( sinfo -- match? )
 171   ['] (wildcard-match) catch if drop false exit then
 172   true
 173 ;
 174
 175
 176 \
 177 \ 4.3.3 match child node
 178 \
 179
 180 \ used if package lacks a decode-unit method
 181 : def-decode-unit ( str len -- unitaddr ... )
 182   parse-hex
 183 ;
 184
 185 : get-decode-unit-xt ( phandle -- xt )
 186   " decode-unit" rot find-method
 187   0= if ['] def-decode-unit then
 188 ;
 189
 190 : find-child ( sinfo -- phandle )
 191   >r
 192   \ decode unit address string
 193   r@ >si.unit_addr 2@ dup if
 194     ( str len )
 195     active-package get-decode-unit-xt
 196     depth 3 - >r execute depth r@ - r> swap
 197     ( ... a_lo ... a_hi olddepth n )
 198     4 min 0 max
 199     dup r@ >si.unit_phys_len !
 200     ( ... a_lo ... a_hi olddepth n )
 201     r@ >si.unit_phys >r
 202     begin 1- dup 0>= while
 203       rot r> dup la1+ >r l!-be
 204     repeat
 205     r> 2drop
 206     depth!
 207   else
 208     2drop
 209     \ clear unit_phys
 210     0 r@ >si.unit_phys_len !
 211     \ r@ >si.unit_phys 4 cells 0 fill
 212   then
 213
 214   ( R: sinfo )
 215   ['] exact-match
 216   begin dup while
 217     active-package >dn.child @
 218     begin ?dup while
 219       dup r@ >si.child !
 220       ( xt phandle R: sinfo )
 221       r@ 2 pick execute if 2drop r> >si.child @ exit then
 222       >dn.peer @
 223     repeat
 224     ['] exact-match = if ['] wildcard-match else 0 then
 225   repeat
 226
 227   -99 throw
 228 ;
 229
 230
 231 \
 232 \ 4.3.2 Create new linked instance procedure
 233 \
 234
 235 : link-one ( sinfo -- )
 236   >r
 237   active-package create-instance
 238   dup 0= if -99 throw then
 239
 240   \ change instance parent
 241   r@ >si.top-ihandle @ over >in.my-parent !
 242   dup r@ >si.top-ihandle !
 243   to my-self
 244
 245   \ b) set my-args field
 246   r@ >si.arguments 2@ strdup my-self >in.arguments 2!
 247
 248   \ e) set my-unit field
 249   r@ >si.unit_addr 2@ nip if
 250     \ copy UNIT_PHYS to the my-unit field
 251     r@ >si.unit_phys my-self >in.my-unit 4 cells move
 252   else
 253     \ set unit-addr from reg property
 254     " reg" active-package get-package-property 0= if
 255       \ ( ihandle prop proplen )
 256       \ copy address to my-unit
 257       4 cells min my-self >in.my-unit swap move
 258     else
 259       \ clear my-unit
 260       my-self >in.my-unit 4 cells 0 fill
 261     then
 262   then
 263
 264   \ top instance has not been opened (yet)
 265   false r> >si.top-opened !
 266 ;
 267
 268 : invoke-open ( sinfo -- )
 269   " open" my-self ['] $call-method
 270   catch if 3drop false then
 271   0= if -99 throw then
 272
 273   true swap >si.top-opened !
 274 ;
 275
 276 \
 277 \ 4.3.7 Handle interposers procedure (supplement)
 278 \
 279
 280 : handle-interposers ( sinfo -- )
 281   >r
 282   begin
 283     interpose-ph ?dup
 284   while
 285     0 to interpose-ph
 286     active-package swap active-package!
 287
 288     \ clear unit address and set arguments
 289     0 0 r@ >si.unit_addr 2!
 290     interpose-args 2@ r@ >si.arguments 2!
 291     r@ link-one
 292     true my-self >in.interposed !
 293     interpose-args 2@ free-mem
 294     r@ invoke-open
 295
 296     active-package!
 297   repeat
 298
 299   r> drop
 300 ;
 301
 302 \
 303 \ 4.3.1 Path resolution procedure
 304 \
 305
 306 \ close-dev ( ihandle -- )
 307 \
 308 : close-dev
 309   begin
 310     dup
 311   while
 312     dup >in.my-parent @
 313     swap close-package
 314   repeat
 315   drop
 316 ;
 317
 318 : path-res-cleanup ( sinfo close? )
 319
 320   \ tear down all instances if close? is set
 321   if
 322     dup >si.top-opened @ if
 323       dup >si.top-ihandle @
 324       ?dup if close-dev then
 325     else
 326       dup >si.top-ihandle @ dup
 327       ( sinfo ihandle ihandle )
 328       dup if >in.my-parent @ swap then
 329       ( sinfo parent ihandle )
 330       ?dup if destroy-instance then
 331       ?dup if close-dev then
 332     then
 333   then
 334
 335   \ restore active-package and my-self
 336   dup >si.save-ihandle @ to my-self
 337   dup >si.save-phandle @ active-package!
 338
 339   \ free any allocated memory
 340   dup >si.free_me 2@ free-mem
 341   sinfo.size free-mem
 342 ;
 343
 344 : (path-resolution) ( context sinfo -- )
 345   >r r@ >si.path 2@
 346   ( context pathstr pathlen )
 347
 348   \ this allocates a copy of the string
 349   pathres-resolve-aliases
 350   2dup r@ >si.free_me 2!
 351
 352   \ If the pathname, after possible alias expansion, begins with "/",
 353   \ begin the search at the root node. Otherwise, begin at the active
 354   \ package.
 355
 356   dup if                    \ make sure string is not empty
 357     over c@ 2f = if
 358       swap char+ swap /c -  \ Remove the "/" from PATH_NAME.
 359       \ Set the active package to the root node.
 360       device-tree @ active-package!
 361     then
 362   then
 363
 364   r@ >si.path 2!
 365   0 0 r@ >si.unit_addr 2!
 366   0 0 r@ >si.arguments 2!
 367   0 r@ >si.top-ihandle !
 368
 369   \ If there is no active package, exit this procedure, returning false.
 370   ( context )
 371   active-package 0= if -99 throw then
 372
 373   \ Begin the creation of an instance chain.
 374   \ NOTE--If, at this step, the active package is not the root node and
 375   \ we are in open-dev or execute-device-method contexts, the instance
 376   \ chain that results from the path resolution process may be incomplete.
 377
 378   active-package swap
 379   ( virt-active-node context )
 380   begin
 381     r@ >si.path 2@ nip          \ nonzero path?
 382   while
 383     \ ( active-node context )
 384     \ is this open-dev or execute-device-method context?
 385     dup if
 386       r@ link-one
 387       over active-package <> my-self >in.interposed !
 388       r@ invoke-open
 389       r@ handle-interposers
 390     then
 391     over active-package!
 392
 393     r@ >si.path 2@              ( PATH )
 394
 395     ascii / left-split          ( PATH COMPONENT )
 396     ascii : left-split          ( PATH ARGS NODE_ADDR )
 397     ascii @ left-split          ( PATH ARGS UNIT_ADDR NODE_NAME )
 398
 399     r@ >si.node_name 2!
 400     r@ >si.unit_addr 2!
 401     r@ >si.arguments 2!
 402     r@ >si.path 2!
 403
 404     ( virt-active-node context )
 405
 406     \ 4.3.1 i) pathname has a leading %?
 407     r@ >si.node_name 2@ 2dup 2dup ascii % strchr nip = if
 408       1- swap 1+ swap r@ >si.node_name 2!
 409       " /packages" find-dev drop active-package!
 410       r@ find-child
 411     else
 412       2drop
 413       nip r@ find-child swap over
 414       ( new-node context new-node )
 415     then
 416
 417     \ (optional: open any nodes between parent and child )
 418
 419     active-package!
 420   repeat
 421
 422   ( virt-active-node type )
 423   dup if r@ link-one then
 424   1 = if
 425     dup active-package <> my-self >in.interposed !
 426     r@ invoke-open
 427     r@ handle-interposers
 428   then
 429   active-package!
 430
 431   r> drop
 432 ;
 433
 434 : path-resolution ( context path-addr path-len -- sinfo true | false )
 435   \ allocate and clear the search block
 436   sinfo.size alloc-mem >r
 437   r@ sinfo.size 0 fill
 438
 439   \ store path
 440   r@ >si.path 2!
 441
 442   \ save ihandle and phandle
 443   my-self r@ >si.save-ihandle !
 444   active-package r@ >si.save-phandle !
 445
 446   \ save context (if we take an exception)
 447   dup
 448
 449   r@ ['] (path-resolution)
 450   catch ?dup if
 451     ( context xxx xxx error )
 452     r> true path-res-cleanup
 453
 454     \ rethrow everything except our "cleanup throw"
 455     dup -99 <> if throw then
 456     3drop
 457
 458     \ ( context ) throw an exception if this is find-device context
 459     if false else -22 throw then
 460     exit
 461   then
 462
 463   \ ( context )
 464   drop r> true
 465   ( sinfo true )
 466 ;
 467
 468
 469 : open-dev ( dev-str dev-len -- ihandle | 0 )
 470   1 -rot path-resolution 0= if false exit then
 471
 472   ( sinfo )
 473   my-self swap
 474   false path-res-cleanup
 475
 476   ( ihandle )
 477 ;
 478
 479 : execute-device-method
 480 ( ... dev-str dev-len met-str met-len -- ... false | ?? true )
 481   2swap
 482   2 -rot path-resolution 0= if 2drop false exit then
 483   ( method-str method-len sinfo )
 484   >r
 485   my-self ['] $call-method catch
 486   if 3drop false else true then
 487   r> true path-res-cleanup
 488 ;
 489
 490 : find-device ( dev-str dev-len -- )
 491   2dup " .." strcmp 0= if
 492     2drop
 493     active-package dup if >dn.parent @ then
 494     \ ".." in root note?
 495     dup 0= if -22 throw then
 496     active-package!
 497     exit
 498   then
 499   0 -rot path-resolution 0= if false exit then
 500   ( sinfo )
 501   active-package swap
 502   true path-res-cleanup
 503   active-package!
 504 ;
 505
 506 \ find-device, but without side effects
 507 : (find-dev) ( dev-str dev-len -- phandle true | false )
 508   active-package -rot
 509   ['] find-device catch if 3drop false exit then
 510   active-package swap active-package! true
 511 ;
 512
 513 \ Tuck on a node at the end of the chain being created.
 514 \ This implementation follows the interpose recommended practice
 515 \ (v0.2 draft).
 516
 517 : interpose ( arg-str arg-len phandle -- )
 518   to interpose-ph
 519   strdup interpose-args 2!
 520 ;
 521
 522 ['] (find-dev) to find-dev