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
160 VALUE debug-client-interface?
17
18\ First, the machinery.
19
20VOCABULARY client-voc \ We store all client-interface callable words here.
21
226789  CONSTANT  sc-exit
234711  CONSTANT  sc-yield
24
25VARIABLE  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
49  s" linux,initrd-end" get-chosen IF decode-int nip nip ELSE 0 THEN
50  s" linux,initrd-start" get-chosen IF decode-int nip nip ELSE 0 THEN
51		    ( end start )
52  tuck -	    ( start len )
53  ciregs >r4 !
54  ciregs >r3 !
55
56  \ jump-client maps to call_client in slof/entry.S
57  \ When jump-client returns, R3 holds the address of a NUL-terminated string
58  \ that holds the client interface word the client wants to call, R4 holds
59  \ the return address.
60  r> jump-client drop
61  BEGIN
62    client-data-to-stack
63    \ Now create a Forth-style string, look it up in the client dictionary and
64    \ execute it, guarded by CATCH. Result of xt == 0 is stored on the return
65    \ stack
66    client-data l@ zcount
67    \ XXX: Should only look in client-voc...
68    ALSO client-voc $find PREVIOUS
69    dup 0= >r IF
70      CATCH
71      \ If a client interface word needs some special treatment, like exit and
72      \ yield, then the implementation needs to use THROW to indicate its needs
73      ?dup IF
74        dup CASE
75          sc-exit OF drop r> drop EXIT ENDOF
76          sc-yield OF drop r> drop EXIT ENDOF
77        ENDCASE
78        \ Some special call was made but we don't know that to do with it...
79        THROW
80      THEN
81      stack-to-client-data
82    ELSE
83      cr type ."  NOT FOUND"
84    THEN
85    \ Return to the client
86    r> ciregs >r3 !  ciregs >r4 @ jump-client
87  UNTIL ;
88
89: flip-stack ( a1 ... an n -- an ... a1 )  ?dup IF 1 ?DO i roll LOOP THEN ;
90
91: (callback) ( "service-name<>" "arguments<cr>" -- )
92  client-callback @  \ client-callback points to the function prolog
93  dup 8 + @ ciregs >r2 !  \ Set up the TOC pointer (???)
94  @ call-client ;  \ Resolve the function's address from the prolog
95' (callback) to callback
96
97: (continue-client)
98  s" "  \ make call-client happy, client won't use the string anyways.
99  ciregs >r4 @ call-client ;
100' (continue-client) to continue-client
101
102\ Utility.
103: string-to-buffer ( str len buf len -- len' )
104  2dup erase rot min dup >r move r> ;
105
106\ Now come the actual client interface words.
107
108ALSO client-voc DEFINITIONS
109
110: exit  sc-exit THROW ;
111
112: yield  sc-yield THROW ;
113
114: test ( zstr -- missing? )
115   \ XXX: Should only look in client-voc...
116   zcount
117   debug-client-interface? IF
118      ." ci: test " 2dup type cr
119   THEN
120   ALSO client-voc $find PREVIOUS IF
121      drop FALSE
122   ELSE
123      2drop TRUE
124   THEN
125;
126
127: finddevice ( zstr -- phandle )
128   zcount
129   debug-client-interface? IF
130      ." ci: finddevice " 2dup type cr
131   THEN
132   2dup " /memory" str= IF
133     \ Workaround: grub passes /memory instead of /memory@0
134     2drop
135     " /memory@0"
136   THEN
137   find-node dup 0= IF drop -1 THEN
138;
139
140: getprop ( phandle zstr buf len -- len' )
141   >r >r zcount rot                     ( str-adr str-len phandle   R: len buf )
142   debug-client-interface? IF
143      ." ci: getprop " 3dup . ." '" type ." '"
144   THEN
145   get-property
146   debug-client-interface? IF
147      dup IF ."  ** not found **" THEN
148      cr
149   THEN
150   0= IF
151      r> swap dup r> min swap >r move r>
152   ELSE
153      r> r> 2drop -1
154   THEN
155;
156
157: getproplen ( phandle zstr -- len )
158  zcount rot get-property 0= IF nip ELSE -1 THEN ;
159
160: setprop ( phandle zstr buf len -- size|-1 )
161   dup >r            \ save len
162   encode-bytes      ( phandle zstr prop-addr prop-len )
163   2swap zcount rot  ( prop-addr prop-len name-addr name-len phandle )
164   current-node @ >r \ save current node
165   set-node          \ change to specified node
166   property          \ set property
167   r> set-node       \ restore original node
168   r>                \ always return size, because we can not fail.
169;
170
171\ VERY HACKISH
172: canon ( zstr buf len -- len' )
173   2dup erase
174   >r >r zcount
175   >r dup c@ [char] / = IF
176      r> r> swap r> over >r min move r>
177   ELSE
178      r> find-alias ?dup 0= IF
179         r> r> 2drop -1
180      ELSE
181         dup -rot r> swap r> min move
182      THEN
183   THEN
184;
185
186: nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok
187  >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ;
188
189: open ( zstr -- ihandle )
190   zcount
191   debug-client-interface? IF
192      ." ci: open " 2dup type cr
193   THEN
194   open-dev
195;
196
197: close ( ihandle -- )
198    debug-client-interface? IF
199	." ci: close " dup . cr
200    THEN
201    s" stdin" get-chosen IF
202	decode-int nip nip over = IF
203	    \ End of life of SLOF now, call platform quiesce as quiesce
204	    \ is an undocumented extension and not everybody supports it
205	    close-dev
206	    quiesce
207	ELSE
208	    close-dev
209	THEN
210    ELSE
211	close-dev
212    THEN
213;
214
215\ Now implemented: should return -1 if no such method exists in that node
216: write ( ihandle str len -- len' )      rot s" write" rot
217	['] $call-method CATCH IF 2drop 3drop -1 THEN ;
218: read  ( ihandle str len -- len' )      rot s" read"  rot
219	['] $call-method CATCH IF 2drop 3drop -1 THEN ;
220: seek  ( ihandle hi lo -- status  ) swap rot s" seek" rot
221	['] $call-method CATCH IF 2drop 3drop -1 THEN ;
222
223\ A real claim implementation: 3.2% memory fat :-)
224: claim  ( addr len align -- base )
225   debug-client-interface? IF
226      ." ci: claim " .s cr
227   THEN
228   dup  IF  rot drop
229      ['] claim CATCH  IF  2drop -1  THEN
230   ELSE
231      ['] claim CATCH  IF  3drop -1  THEN
232   THEN
233;
234
235: release ( addr len -- )
236   debug-client-interface? IF
237      ." ci: release " .s cr
238   THEN
239   release
240;
241
242: instance-to-package ( ihandle -- phandle )
243  ihandle>phandle ;
244
245: package-to-path ( phandle buf len -- len' )
246  2>r node>path 2r> string-to-buffer ;
247: instance-to-path ( ihandle buf len -- len' )
248  2>r instance>path 2r> string-to-buffer ;
249: instance-to-interposed-path ( ihandle buf len -- len' )
250  2>r instance>qpath 2r> string-to-buffer ;
251
252: call-method ( str ihandle arg ... arg -- result return ... return )
253  nargs flip-stack zcount
254  debug-client-interface? IF
255     ." ci: call-method " 2dup type cr
256  THEN
257  rot ['] $call-method CATCH
258  nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result
259     dup IF nrets 1 ?DO -444 LOOP THEN
260     nrets flip-stack
261  THEN
262;
263
264\ From the PAPR.
265: test-method ( phandle str -- missing? )
266   zcount
267   debug-client-interface? IF
268      ." ci: test-method " 2dup type cr
269   THEN
270   rot find-method dup IF nip THEN 0=
271;
272
273: milliseconds  milliseconds ;
274
275: start-cpu ( phandle addr r3 -- )
276  >r >r
277  s" reg" rot get-property 0= IF drop l@
278    ELSE true ABORT" start-cpu called with invalid phandle" THEN
279  r> r> of-start-cpu drop
280;
281
282\ Quiesce firmware and assert that all hardware is in a sane state
283\ (e.g. assert that no background DMA is running anymore)
284: quiesce  ( -- )
285   debug-client-interface? IF
286      ." ci: quiesce" cr
287   THEN
288   \ The main quiesce call is defined in quiesce.fs
289   quiesce
290;
291
292\
293\ Standard for Boot, defined in 6.3.2.5:
294\
295: boot  ( zstr -- )
296   zcount
297   debug-client-interface? IF
298      ." ci: boot " 2dup type cr
299   THEN
300   " boot " 2swap $cat " boot-command" $setenv (nvupdate)
301   reset-all
302;
303
304\
305\ User Interface, defined in 6.3.2.6
306\
307: interpret ( ... zstr -- result ... )
308   zcount
309   debug-client-interface? IF
310      ." ci: interpret " 2dup type cr
311   THEN
312   ['] evaluate CATCH
313;
314
315\ Allow the client to register a callback
316: set-callback ( newfunc -- oldfunc )
317  client-callback @ swap client-callback ! ;
318
319\ Custom method to get FDT blob
320: fdt-fetch ( buf len -- ret )
321    fdt-flatten-tree    ( buf len dtb )
322    dup >r
323    >fdth_tsize l@      ( buf len size r: dtb )
324    2dup < IF
325        ." ERROR: need " .d ." bytes, the buffer is " .d ." bytes only" cr
326        drop
327        -1
328    ELSE
329        nip r@ -rot move
330        0
331    THEN
332    r> fdt-flatten-tree-free
333;
334
335PREVIOUS DEFINITIONS
336