\ ***************************************************************************** \ * 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" -- ) 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