\ *****************************************************************************
\ * 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
\ ****************************************************************************/


\ Client interface.

0 VALUE debug-client-interface?

\ First, the machinery.

VOCABULARY client-voc \ We store all client-interface callable words here.

6789  CONSTANT  sc-exit
4711  CONSTANT  sc-yield

VARIABLE  client-callback \ Address of client's callback function

: client-data  ciregs >r3 @ ;
: nargs  client-data la1+ l@ ;
: nrets  client-data la1+ la1+ l@ ;
: client-data-to-stack
  client-data 3 la+ nargs 0 ?DO dup l@ swap la1+ LOOP drop ;
: stack-to-client-data
  client-data nargs nrets + 2 + la+ nrets 0 ?DO tuck l! /l - LOOP drop ;

: call-client ( args len client-entry -- )
  \ (args, len) describe the argument string, client-entry is the address of
  \ the client's .entry symbol, i.e. where we eventually branch to.
  \ ciregs is a variable that describes the register set of the host processor,
  \ see slof/fs/exception.fs for details
  \ client-entry-point maps to client_entry_point in slof/entry.S which is
  \ the SLOF entry point when calling a SLOF client interface word from the
  \ client.
  \ We pass the arguments for the client in R6 and R7, the client interface
  \ entry point address is passed in R5.
  >r  ciregs >r7 !  ciregs >r6 !  client-entry-point @ ciregs >r5 !
  \ Initialise client-stack-pointer
  cistack ciregs >r1 !

  s" linux,initrd-end" get-chosen IF decode-int nip nip ELSE 0 THEN
  s" linux,initrd-start" get-chosen IF decode-int nip nip ELSE 0 THEN
		    ( end start )
  tuck -	    ( start len )
  ciregs >r4 !
  ciregs >r3 !

  \ jump-client maps to call_client in slof/entry.S
  \ When jump-client returns, R3 holds the address of a NUL-terminated string
  \ that holds the client interface word the client wants to call, R4 holds
  \ the return address.
  r> jump-client drop
  BEGIN
    client-data-to-stack
    \ Now create a Forth-style string, look it up in the client dictionary and
    \ execute it, guarded by CATCH. Result of xt == 0 is stored on the return
    \ stack
    client-data l@ zcount
    \ XXX: Should only look in client-voc...
    ALSO client-voc $find PREVIOUS
    dup 0= >r IF 
      CATCH
      \ If a client interface word needs some special treatment, like exit and
      \ yield, then the implementation needs to use THROW to indicate its needs
      ?dup IF
        dup CASE
          sc-exit OF drop r> drop EXIT ENDOF
          sc-yield OF drop r> drop EXIT ENDOF
        ENDCASE
        \ Some special call was made but we don't know that to do with it...
        THROW
      THEN
      stack-to-client-data
    ELSE
      cr type ."  NOT FOUND"
    THEN
    \ Return to the client
    r> ciregs >r3 !  ciregs >r4 @ jump-client 
  UNTIL ;

: flip-stack ( a1 ... an n -- an ... a1 )  ?dup IF 1 ?DO i roll LOOP THEN ;

: (callback) ( "service-name<>" "arguments<cr>" -- )
  client-callback @  \ client-callback points to the function prolog
  dup 8 + @ ciregs >r2 !  \ Set up the TOC pointer (???)
  @ call-client ;  \ Resolve the function's address from the prolog
' (callback) to callback

: (continue-client)
  s" "  \ make call-client happy, client won't use the string anyways.
  ciregs >r4 @ call-client ;
' (continue-client) to continue-client

\ Utility.
: string-to-buffer ( str len buf len -- len' )
  2dup erase rot min dup >r move r> ;

\ Now come the actual client interface words.

ALSO client-voc DEFINITIONS

: exit  sc-exit THROW ;

: yield  sc-yield THROW ;

: test ( zstr -- missing? )
   \ XXX: Should only look in client-voc...
   zcount
   debug-client-interface? IF
      ." ci: test " 2dup type cr
   THEN
   ALSO client-voc $find PREVIOUS IF
      drop FALSE
   ELSE
      2drop TRUE
   THEN 
;

: finddevice ( zstr -- phandle )
   zcount
   debug-client-interface? IF
      ." ci: finddevice " 2dup type cr
   THEN
   2dup " /memory" str= IF
     \ Workaround: grub passes /memory instead of /memory@0
     2drop
     " /memory@0"
   THEN
   find-node dup 0= IF drop -1 THEN
;

: getprop ( phandle zstr buf len -- len' )
   >r >r zcount rot                     ( str-adr str-len phandle   R: len buf )
   debug-client-interface? IF
      ." ci: getprop " 3dup . ." '" type ." '"
   THEN
   get-property
   debug-client-interface? IF
      dup IF ."  ** not found **" THEN
      cr
   THEN
   0= IF
      r> swap dup r> min swap >r move r>
   ELSE
      r> r> 2drop -1
   THEN
;

: getproplen ( phandle zstr -- len )
  zcount rot get-property 0= IF nip ELSE -1 THEN ;

: setprop ( phandle zstr buf len -- size|-1 )
   dup >r            \ save len
   encode-bytes      ( phandle zstr prop-addr prop-len )
   2swap zcount rot  ( prop-addr prop-len name-addr name-len phandle )
   current-node @ >r \ save current node
   set-node          \ change to specified node
   property          \ set property
   r> set-node       \ restore original node
   r>                \ always return size, because we can not fail.
;

\ VERY HACKISH
: canon ( zstr buf len -- len' )
   2dup erase
   >r >r zcount
   >r dup c@ [char] / = IF
      r> r> swap r> over >r min move r>
   ELSE
      r> find-alias ?dup 0= IF
         r> r> 2drop -1
      ELSE
         dup -rot r> swap r> min move
      THEN
   THEN
;

: nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok
  >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ; 

: open ( zstr -- ihandle )
   zcount
   debug-client-interface? IF
      ." ci: open " 2dup type cr
   THEN
   open-dev
;

: close ( ihandle -- )
    debug-client-interface? IF
	." ci: close " dup . cr
    THEN
    s" stdin" get-chosen IF
	decode-int nip nip over = IF
	    \ End of life of SLOF now, call platform quiesce as quiesce
	    \ is an undocumented extension and not everybody supports it
	    close-dev
	    quiesce
	ELSE
	    close-dev
	THEN
    ELSE
	close-dev
    THEN
;

\ Now implemented: should return -1 if no such method exists in that node
: write ( ihandle str len -- len' )      rot s" write" rot
	['] $call-method CATCH IF 2drop 3drop -1 THEN ;
: read  ( ihandle str len -- len' )      rot s" read"  rot
	['] $call-method CATCH IF 2drop 3drop -1 THEN ;
: seek  ( ihandle hi lo -- status  ) swap rot s" seek" rot
	['] $call-method CATCH IF 2drop 3drop -1 THEN ;

\ A real claim implementation: 3.2% memory fat :-)
: claim  ( addr len align -- base )
   debug-client-interface? IF
      ." ci: claim " .s cr
   THEN
   dup  IF  rot drop
      ['] claim CATCH  IF  2drop -1  THEN
   ELSE
      ['] claim CATCH  IF  3drop -1  THEN
   THEN
;

: release ( addr len -- )
   debug-client-interface? IF
      ." ci: release " .s cr
   THEN
   release
;

: instance-to-package ( ihandle -- phandle )
  ihandle>phandle ;

: package-to-path ( phandle buf len -- len' )
  2>r node>path 2r> string-to-buffer ;
: instance-to-path ( ihandle buf len -- len' )
  2>r instance>path 2r> string-to-buffer ;
: instance-to-interposed-path ( ihandle buf len -- len' )
  2>r instance>qpath 2r> string-to-buffer ;

: call-method ( str ihandle arg ... arg -- result return ... return )
  nargs flip-stack zcount
  debug-client-interface? IF
     ." ci: call-method " 2dup type cr
  THEN
  rot ['] $call-method CATCH
  nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result
     dup IF nrets 1 ?DO -444 LOOP THEN
     nrets flip-stack 
  THEN
;

\ From the PAPR.
: test-method ( phandle str -- missing? )
   zcount
   debug-client-interface? IF
      ." ci: test-method " 2dup type cr
   THEN
   rot find-method dup IF nip THEN 0=
;

: milliseconds  milliseconds ;

: start-cpu ( phandle addr r3 -- )
  >r >r 
  s" reg" rot get-property 0= IF drop l@ 
    ELSE true ABORT" start-cpu called with invalid phandle" THEN 
  r> r> of-start-cpu drop
;

\ Quiesce firmware and assert that all hardware is in a sane state
\ (e.g. assert that no background DMA is running anymore)
: quiesce  ( -- )
   debug-client-interface? IF
      ." ci: quiesce" cr
   THEN
   \ The main quiesce call is defined in quiesce.fs
   quiesce
;

\
\ Standard for Boot, defined in 6.3.2.5:
\
: boot  ( zstr -- )
   zcount
   debug-client-interface? IF
      ." ci: boot " 2dup type cr
   THEN
   " boot " 2swap $cat " boot-command" $setenv (nvupdate)
   reset-all
;

\
\ User Interface, defined in 6.3.2.6
\
: interpret ( ... zstr -- result ... )
   zcount
   debug-client-interface? IF
      ." ci: interpret " 2dup type cr
   THEN
   ['] evaluate CATCH
;

\ Allow the client to register a callback
: set-callback ( newfunc -- oldfunc )
  client-callback @ swap client-callback ! ;

\ Custom method to get FDT blob
: fdt-fetch ( buf len -- ret )
    fdt-flatten-tree    ( buf len dtb )
    dup >r
    >fdth_tsize l@      ( buf len size r: dtb )
    2dup < IF
        ." ERROR: need " .d ." bytes, the buffer is " .d ." bytes only" cr
        drop
        -1
    ELSE
        nip r@ -rot move
        0
    THEN
    r> fdt-flatten-tree-free
;

PREVIOUS DEFINITIONS