--- /dev/null
+\ *****************************************************************************
+\ * 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 !
+ \ 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
+;
+
+\
+\ 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 ! ;
+
+PREVIOUS DEFINITIONS
Code Review / kvmfornfv.git / blobdiff