summaryrefslogtreecommitdiffstats
path: root/qemu/roms/SLOF/slof/fs/client.fs
blob: 1b2bb03268b41e438df343463410fce14c2d1a0f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
\ *****************************************************************************
\ * 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