![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to client.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs|
Return to client.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs |
1.1 root 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:
1.1.1.3 ! root 16: 0 VALUE debug-client-interface?
! 17:
1.1 root 18: \ First, the machinery.
19:
20: VOCABULARY client-voc \ We store all client-interface callable words here.
21:
22: 6789 CONSTANT sc-exit
23: 4711 CONSTANT sc-yield
24:
25: VARIABLE 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
1.1.1.3 ! root 70: \ Some special call was made but we don't know that to do with it...
1.1 root 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:
100: ALSO client-voc DEFINITIONS
101:
102: : exit sc-exit THROW ;
103:
104: : yield sc-yield THROW ;
105:
106: : test ( zstr -- missing? )
1.1.1.2 root 107: \ XXX: Should only look in client-voc...
1.1.1.3 ! root 108: zcount
! 109: debug-client-interface? IF
! 110: ." ci: test " 2dup type cr
! 111: THEN
1.1.1.2 root 112: ALSO client-voc $find PREVIOUS IF
113: drop FALSE
114: ELSE
115: 2drop TRUE
116: THEN
117: ;
1.1 root 118:
119: : finddevice ( zstr -- phandle )
1.1.1.3 ! root 120: zcount
! 121: debug-client-interface? IF
! 122: ." ci: finddevice " 2dup type cr
! 123: THEN
! 124: find-node dup 0= IF drop -1 THEN
! 125: ;
1.1 root 126:
127: : getprop ( phandle zstr buf len -- len' )
128: >r >r zcount rot get-property
129: 0= IF r> swap dup r> min swap >r move r>
130: ELSE r> r> 2drop -1 THEN ;
131:
132: : getproplen ( phandle zstr -- len )
133: zcount rot get-property 0= IF nip ELSE -1 THEN ;
134:
135: : setprop ( phandle zstr buf len -- size|-1 )
136: dup >r \ save len
137: encode-bytes ( phandle zstr prop-addr prop-len )
138: 2swap zcount rot ( prop-addr prop-len name-addr name-len phandle )
139: current-node @ >r \ save current node
140: set-node \ change to specified node
141: property \ set property
142: r> set-node \ restore original node
143: r> \ always return size, because we can not fail.
144: ;
145:
146: \ VERY HACKISH
147: : canon ( zstr buf len -- len' )
148: over >r move r> zcount nip ;
149:
150: : nextprop ( phandle zstr buf -- flag ) \ -1 invalid, 0 end, 1 ok
151: >r zcount rot next-property IF r> zplace 1 ELSE r> drop 0 THEN ;
152:
1.1.1.3 ! root 153: : open ( zstr -- ihandle )
! 154: zcount
! 155: debug-client-interface? IF
! 156: ." ci: open " 2dup type cr
! 157: THEN
! 158: open-dev
! 159: ;
! 160:
! 161: : close ( ihandle -- )
! 162: debug-client-interface? IF
! 163: ." ci: close " dup . cr
! 164: THEN
! 165: close-dev
! 166: ;
1.1 root 167:
168: \ Now implemented: should return -1 if no such method exists in that node
169: : write ( ihandle str len -- len' ) rot s" write" rot
170: ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
171: : read ( ihandle str len -- len' ) rot s" read" rot
172: ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
173: : seek ( ihandle hi lo -- status ) swap rot s" seek" rot
174: ['] $call-method CATCH IF 2drop 3drop -1 THEN ;
175:
176: \ A real claim implementation: 3.2% memory fat :-)
177: : claim ( addr len align -- base )
1.1.1.3 ! root 178: debug-client-interface? IF
! 179: ." ci: claim " .s cr
! 180: THEN
1.1 root 181: dup IF rot drop
182: ['] claim CATCH IF 2drop -1 THEN
183: ELSE
184: ['] claim CATCH IF 3drop -1 THEN
185: THEN
186: ;
187:
1.1.1.3 ! root 188: : release ( addr len -- )
! 189: debug-client-interface? IF
! 190: ." ci: release " .s cr
! 191: THEN
! 192: release
! 193: ;
1.1 root 194:
195: : instance-to-package ( ihandle -- phandle )
196: ihandle>phandle ;
197:
198: : package-to-path ( phandle buf len -- len' )
199: 2>r node>path 2r> string-to-buffer ;
200: : instance-to-path ( ihandle buf len -- len' )
201: 2>r instance>path 2r> string-to-buffer ;
202: : instance-to-interposed-path ( ihandle buf len -- len' )
203: 2>r instance>qpath 2r> string-to-buffer ;
204:
205: : call-method ( str ihandle arg ... arg -- result return ... return )
1.1.1.3 ! root 206: nargs flip-stack zcount
! 207: debug-client-interface? IF
! 208: ." ci: call-method " 2dup type cr
! 209: THEN
! 210: rot ['] $call-method CATCH
1.1 root 211: nrets 0= IF drop ELSE \ if called with 0 return args do not return the catch result
212: dup IF nrets 1 ?DO -444 LOOP THEN
213: nrets flip-stack
1.1.1.3 ! root 214: THEN
! 215: ;
1.1 root 216:
217: \ From the PAPR.
218: : test-method ( phandle str -- missing? )
1.1.1.3 ! root 219: zcount
! 220: debug-client-interface? IF
! 221: ." ci: test-method " 2dup type cr
! 222: THEN
! 223: rot find-method dup IF nip THEN 0=
! 224: ;
1.1 root 225:
226: : milliseconds milliseconds ;
227:
228: : start-cpu ( phandle addr r3 -- )
229: >r >r
230: s" reg" rot get-property 0= IF drop l@
231: ELSE true ABORT" start-cpu called with invalid phandle" THEN
232: r> r> of-start-cpu drop
233: ;
234:
235: \ Quiesce firmware and assert that all hardware is in a sane state
236: \ (e.g. assert that no background DMA is running anymore)
237: : quiesce ( -- )
1.1.1.3 ! root 238: debug-client-interface? IF
! 239: ." ci: quiesce" cr
! 240: THEN
1.1 root 241: \ The main quiesce call is defined in quiesce.fs
242: quiesce
243: ;
244:
245: \
246: \ User Interface, defined in 6.3.2.6
247: \
248: : interpret ( ... zstr -- result ... )
1.1.1.3 ! root 249: zcount
! 250: debug-client-interface? IF
! 251: ." ci: interpret " 2dup type cr
! 252: THEN
! 253: ['] evaluate CATCH
! 254: ;
1.1 root 255:
256: \ Allow the client to register a callback
257: : set-callback ( newfunc -- oldfunc )
258: client-callback @ swap client-callback ! ;
259:
260: PREVIOUS DEFINITIONS
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.