qemu/roms/SLOF/slof/fs/client.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 \ Client interface.
  15
  16 0 VALUE debug-client-interface?
  17
  18 \ First, the machinery.
  19
  20 VOCABULARY client-voc \ We store all client-interface callable words here.
  21
  22 6789  CONSTANT  sc-exit
  23 4711  CONSTANT  sc-yield
  24
  25 VARIABLE  client-callback \ Address of client's callback function
  26
  27 : client-data  ciregs >r3 @ ;
  28 : nargs  client-data la1+ l@ ;
  29 : nrets  client-data la1+ la1+ l@ ;
  30 : client-data-to-stack
  31   client-data 3 la+ nargs 0 ?DO dup l@ swap la1+ LOOP drop ;
  32 : stack-to-client-data
  33   client-data nargs nrets + 2 + la+ nrets 0 ?DO tuck l! /l - LOOP drop ;
  34
  35 : call-client ( args len client-entry -- )
  36   \ (args, len) describe the argument string, client-entry is the address of
  37   \ the client's .entry symbol, i.e. where we eventually branch to.
  38   \ ciregs is a variable that describes the register set of the host processor,
  39   \ see slof/fs/exception.fs for details
  40   \ client-entry-point maps to client_entry_point in slof/entry.S which is
  41   \ the SLOF entry point when calling a SLOF client interface word from the
  42   \ client.
  43   \ We pass the arguments for the client in R6 and R7, the client interface
  44   \ entry point address is passed in R5.
  45   >r  ciregs >r7 !  ciregs >r6 !  client-entry-point @ ciregs >r5 !
  46   \ Initialise client-stack-pointer
  47   cistack ciregs >r1 !
  48   \ jump-client maps to call_client in slof/entry.S
  49   \ When jump-client returns, R3 holds the address of a NUL-terminated string
  50   \ that holds the client interface word the client wants to call, R4 holds
  51   \ the return address.
  52   r> jump-client drop
  53   BEGIN
  54     client-data-to-stack
  55     \ Now create a Forth-style string, look it up in the client dictionary and
  56     \ execute it, guarded by CATCH. Result of xt == 0 is stored on the return
  57     \ stack
  58     client-data l@ zcount
  59     \ XXX: Should only look in client-voc...
  60     ALSO client-voc $find PREVIOUS
  61     dup 0= >r IF
  62       CATCH
  63       \ If a client interface word needs some special treatment, like exit and
  64       \ yield, then the implementation needs to use THROW to indicate its needs
  65       ?dup IF
  66         dup CASE
  67           sc-exit OF drop r> drop EXIT ENDOF
  68           sc-yield OF drop r> drop EXIT ENDOF
  69         ENDCASE
  70         \ Some special call was made but we don't know that to do with it...
  71         THROW
  72       THEN
  73       stack-to-client-data
  74     ELSE
  75       cr type ."  NOT FOUND"
  76     THEN
  77     \ Return to the client
  78     r> ciregs >r3 !  ciregs >r4 @ jump-client
  79   UNTIL ;
  80
  81 : flip-stack ( a1 ... an n -- an ... a1 )  ?dup IF 1 ?DO i roll LOOP THEN ;
  82
  83 : (callback) ( "service-name<>" "arguments<cr>" -- )
  84   client-callback @  \ client-callback points to the function prolog
  85   dup 8 + @ ciregs >r2 !  \ Set up the TOC pointer (???)
  86   @ call-client ;  \ Resolve the function's address from the prolog
  87 ' (callback) to callback
  88
  89 : (continue-client)
  90   s" "  \ make call-client happy, client won't use the string anyways.
  91   ciregs >r4 @ call-client ;
  92 ' (continue-client) to continue-client
  93
  94 \ Utility.
  95 : string-to-buffer ( str len buf len -- len' )
  96   2dup erase rot min dup >r move r> ;
  97
  98 \ Now come the actual client interface words.
  99
 100 ALSO client-voc DEFINITIONS
 101
 102 : exit  sc-exit THROW ;
 103
 104 : yield  sc-yield THROW ;
 105
 106 : test ( zstr -- missing? )
 107    \ XXX: Should only look in client-voc...
 108    zcount
 109    debug-client-interface? IF
 110       ." ci: test " 2dup type cr
 111    THEN
 112    ALSO client-voc $find PREVIOUS IF
 113       drop FALSE
 114    ELSE
 115       2drop TRUE
 116    THEN
 117 ;
 118
 119 : finddevice ( zstr -- phandle )
 120    zcount
 121    debug-client-interface? IF
 122       ." ci: finddevice " 2dup type cr
 123    THEN
 124    2dup " /memory" str= IF
 125      \ Workaround: grub passes /memory instead of /memory@0
 126      2drop
 127      " /memory@0"
 128    THEN
 129    find-node dup 0= IF drop -1 THEN
 130 ;
 131
 132 : getprop ( phandle zstr buf len -- len' )
 133    >r >r zcount rot                     ( str-adr str-len phandle   R: len buf )
 134    debug-client-interface? IF
 135       ." ci: getprop " 3dup . ." '" type ." '"
 136    THEN
 137    get-property
 138    debug-client-interface? IF
 139       dup IF ."  ** not found **" THEN
 140       cr
 141    THEN
 142    0= IF
 143       r> swap dup r> min swap >r move r>
 144    ELSE
 145       r> r> 2drop -1
 146    THEN
 147 ;
 148
 149 : getproplen ( phandle zstr -- len )
 150   zcount rot get-property 0= IF nip ELSE -1 THEN ;
 151
 152 : setprop ( phandle zstr buf len -- size|-1 )
 153    dup >r            \ save len
 154    encode-bytes      ( phandle zstr prop-addr prop-len )
 155    2swap zcount rot  ( prop-addr prop-len name-addr name-len phandle )
 156    current-node @ >r \ save current node
 157    set-node          \ change to specified node
 158    property          \ set property
 159    r> set-node       \ restore original node
 160    r>                \ always return size, because we can not fail.
 161 ;
 162
 163 \ VERY HACKISH
 164 : canon ( zstr buf len -- len' )
 165    2dup erase
 166    >r >r zcount
 167    >r dup c@ [char] / = IF
 168       r> r> swap r> over >r min move r>
 169    ELSE
 170       r> find-alias ?dup 0= IF
 171          r> r> 2drop -1
 172       ELSE
 173          dup -rot r> swap r> min move
 174       THEN
 175    THEN
 176 ;
 177
 178 : nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok
 179   >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ;
 180
 181 : open ( zstr -- ihandle )
 182    zcount
 183    debug-client-interface? IF
 184       ." ci: open " 2dup type cr
 185    THEN
 186    open-dev
 187 ;
 188
 189 : close ( ihandle -- )
 190     debug-client-interface? IF
 191         ." ci: close " dup . cr
 192     THEN
 193     s" stdin" get-chosen IF
 194         decode-int nip nip over = IF
 195             \ End of life of SLOF now, call platform quiesce as quiesce
 196             \ is an undocumented extension and not everybody supports it
 197             close-dev
 198             quiesce
 199         ELSE
 200             close-dev
 201         THEN
 202     ELSE
 203         close-dev
 204     THEN
 205 ;
 206
 207 \ Now implemented: should return -1 if no such method exists in that node
 208 : write ( ihandle str len -- len' )      rot s" write" rot
 209         ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
 210 : read  ( ihandle str len -- len' )      rot s" read"  rot
 211         ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
 212 : seek  ( ihandle hi lo -- status  ) swap rot s" seek" rot
 213         ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
 214
 215 \ A real claim implementation: 3.2% memory fat :-)
 216 : claim  ( addr len align -- base )
 217    debug-client-interface? IF
 218       ." ci: claim " .s cr
 219    THEN
 220    dup  IF  rot drop
 221       ['] claim CATCH  IF  2drop -1  THEN
 222    ELSE
 223       ['] claim CATCH  IF  3drop -1  THEN
 224    THEN
 225 ;
 226
 227 : release ( addr len -- )
 228    debug-client-interface? IF
 229       ." ci: release " .s cr
 230    THEN
 231    release
 232 ;
 233
 234 : instance-to-package ( ihandle -- phandle )
 235   ihandle>phandle ;
 236
 237 : package-to-path ( phandle buf len -- len' )
 238   2>r node>path 2r> string-to-buffer ;
 239 : instance-to-path ( ihandle buf len -- len' )
 240   2>r instance>path 2r> string-to-buffer ;
 241 : instance-to-interposed-path ( ihandle buf len -- len' )
 242   2>r instance>qpath 2r> string-to-buffer ;
 243
 244 : call-method ( str ihandle arg ... arg -- result return ... return )
 245   nargs flip-stack zcount
 246   debug-client-interface? IF
 247      ." ci: call-method " 2dup type cr
 248   THEN
 249   rot ['] $call-method CATCH
 250   nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result
 251      dup IF nrets 1 ?DO -444 LOOP THEN
 252      nrets flip-stack
 253   THEN
 254 ;
 255
 256 \ From the PAPR.
 257 : test-method ( phandle str -- missing? )
 258    zcount
 259    debug-client-interface? IF
 260       ." ci: test-method " 2dup type cr
 261    THEN
 262    rot find-method dup IF nip THEN 0=
 263 ;
 264
 265 : milliseconds  milliseconds ;
 266
 267 : start-cpu ( phandle addr r3 -- )
 268   >r >r
 269   s" reg" rot get-property 0= IF drop l@
 270     ELSE true ABORT" start-cpu called with invalid phandle" THEN
 271   r> r> of-start-cpu drop
 272 ;
 273
 274 \ Quiesce firmware and assert that all hardware is in a sane state
 275 \ (e.g. assert that no background DMA is running anymore)
 276 : quiesce  ( -- )
 277    debug-client-interface? IF
 278       ." ci: quiesce" cr
 279    THEN
 280    \ The main quiesce call is defined in quiesce.fs
 281    quiesce
 282 ;
 283
 284 \
 285 \ User Interface, defined in 6.3.2.6
 286 \
 287 : interpret ( ... zstr -- result ... )
 288    zcount
 289    debug-client-interface? IF
 290       ." ci: interpret " 2dup type cr
 291    THEN
 292    ['] evaluate CATCH
 293 ;
 294
 295 \ Allow the client to register a callback
 296 : set-callback ( newfunc -- oldfunc )
 297   client-callback @ swap client-callback ! ;
 298
 299 PREVIOUS DEFINITIONS