335 lines
9.1 KiB
Forth
335 lines
9.1 KiB
Forth
\ *****************************************************************************
|
|
\ * 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
|