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