Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: common.fth | |
4 | \ | |
5 | \ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved. | |
6 | \ | |
7 | \ - Do no alter or remove copyright notices | |
8 | \ | |
9 | \ - Redistribution and use of this software in source and binary forms, with | |
10 | \ or without modification, are permitted provided that the following | |
11 | \ conditions are met: | |
12 | \ | |
13 | \ - Redistribution of source code must retain the above copyright notice, | |
14 | \ this list of conditions and the following disclaimer. | |
15 | \ | |
16 | \ - Redistribution in binary form must reproduce the above copyright notice, | |
17 | \ this list of conditions and the following disclaimer in the | |
18 | \ documentation and/or other materials provided with the distribution. | |
19 | \ | |
20 | \ Neither the name of Sun Microsystems, Inc. or the names of contributors | |
21 | \ may be used to endorse or promote products derived from this software | |
22 | \ without specific prior written permission. | |
23 | \ | |
24 | \ This software is provided "AS IS," without a warranty of any kind. | |
25 | \ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, | |
26 | \ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A | |
27 | \ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN | |
28 | \ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR | |
29 | \ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR | |
30 | \ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN | |
31 | \ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR | |
32 | \ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE | |
33 | \ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, | |
34 | \ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF | |
35 | \ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. | |
36 | \ | |
37 | \ You acknowledge that this software is not designed, licensed or | |
38 | \ intended for use in the design, construction, operation or maintenance of | |
39 | \ any nuclear facility. | |
40 | \ | |
41 | \ ========== Copyright Header End ============================================ | |
42 | id: @(#)common.fth 2.28 03/12/11 09:22:43 | |
43 | purpose: The basic FCode byte code interpreter loop | |
44 | copyright: Copyright 1990-2002 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Use is subject to license terms. | |
46 | ||
47 | \ The basic FCode byte code interpreter loop | |
48 | ||
49 | ||
50 | \ "Generic" byte code interpreter. These words are used to interpret | |
51 | \ byte code streams. The action to be performed for each byte code | |
52 | \ in the stream is defined externally, so the interpreter code in this | |
53 | \ file may be used by several programs, such as the byte code recompiler | |
54 | \ in the CPU boot PROM and the byte code display program. | |
55 | ||
56 | ||
57 | headers | |
58 | ||
59 | nuser interpreter-pointer \ Points to next byte code in stream | |
60 | nuser fcode-verbose? \ Print out fcodes as they are encountered | |
61 | ||
62 | headerless | |
63 | ||
64 | [ifnexist] chdump | |
65 | also hidden | |
66 | : chdump ( addr len -- ) push-hex ['] c@ to dc@ d.2 pop-base ; | |
67 | previous | |
68 | [then] | |
69 | ||
70 | [ifnexist] char? | |
71 | : char? ( byte -- flag ) | |
72 | dup bl h# 7e between ( byte printable?) | |
73 | over carret = rot linefeed = ( printable? cr? nl?) | |
74 | or or ( printable?) | |
75 | ; | |
76 | [then] | |
77 | ||
78 | ||
79 | nuser more-bytes? \ True when stream is not exhausted | |
80 | \ nuser table# \ Remembers table # of last code encountered | |
81 | \ nuser code# \ Remembers code # of last code encountered | |
82 | nuser fc-spread \ The distance between successive bytes in | |
83 | \ the code stream. If the bytes are stored | |
84 | \ in an 8-bit PROM connected to one of the | |
85 | \ byte lanes of a 32-bit bus, spread is 4. | |
86 | nuser offset16? \ Are offsets 16 bits long? | |
87 | ||
88 | \ Get the next byte code from the byte code stream | |
89 | : get-byte ( -- byte-code ) | |
90 | interpreter-pointer @ c@ fc-spread @ interpreter-pointer +! ( byte-code ) | |
91 | \ h# 100 0 do loop \ Debug ONLY | |
92 | ; | |
93 | ||
94 | d# 16 constant #token-tables \ Maximum number of token tables | |
95 | ||
96 | h# 100 constant tokens/table | |
97 | tokens/table /token * constant /token-area | |
98 | tokens/table 8 / constant /immed-area \ 1 bit for each token | |
99 | ||
100 | /token-area /immed-area + constant /token-table | |
101 | ||
102 | \ 0 value token-table0 | |
103 | \ #token-tables /token-table * buffer: token-table0 | |
104 | ||
105 | \ /stringbuf buffer: string-buf \ buffer for collecting strings | |
106 | d# 258 buffer: string-buf \ buffer for collecting strings | |
107 | ||
108 | variable token-tables-ptr \ Token ptr to array of pointers to token tables | |
109 | : token-tables ( -- tables-pointer ) token-tables-ptr token@ ; | |
110 | ||
111 | 8 constant local-table# \ First table # for local codes | |
112 | ||
113 | ||
114 | \ Terminate interpretation of the byte code stream. This is invoked | |
115 | \ by byte codes 0 and ff, so that the byte code interpreter will exit | |
116 | \ when an unprogrammed section of the PROM is encountered. | |
117 | headers | |
118 | : end0 ( -- ) more-bytes? off ; immediate \ For end value 0 | |
119 | : end1 ( -- ) [compile] end0 ; immediate \ For end value ff | |
120 | : ferror ( -- ) | |
121 | ." Unimplemented FCode token before address " interpreter-pointer @ .h cr | |
122 | [compile] end0 | |
123 | ; | |
124 | : obsolete-fcode ( -- ) ferror ; | |
125 | ||
126 | headerless | |
127 | ||
128 | : ttbl-align ( -- ) \ like acf-align without 'lastacf side-effect | |
129 | begin here #acf-align 1- and | |
130 | while 0 c, | |
131 | repeat | |
132 | ; | |
133 | ||
134 | : init-tables ( -- ) | |
135 | ttbl-align here | |
136 | #token-tables /token * allot | |
137 | ( here ) token-tables-ptr token! | |
138 | token-tables #token-tables /token * bounds | |
139 | ?do i !null-token /token +loop | |
140 | ; | |
141 | ||
142 | \ Return the address of the numbered token table. If space for that | |
143 | \ table hasn't yet been allocated, allocate it. | |
144 | : >token-table ( table# -- table-adr ) | |
145 | token-tables over ta+ get-token? if ( table# table-adr ) | |
146 | nip ( table-adr ) | |
147 | else ( table# ) | |
148 | ttbl-align here ( table# table-adr ) | |
149 | /token-area /immed-area + allot ( table# table-adr ) | |
150 | tokens/table 0 do ( table# table-adr ) | |
151 | dup i ta+ ['] ferror swap token! ( table# table-adr ) | |
152 | loop ( table# table-adr ) | |
153 | tuck token-tables rot ta+ token! ( table-adr ) | |
154 | dup /token-area + /immed-area note-string erase ( table-adr ) | |
155 | then ( table-adr ) | |
156 | ; | |
157 | ||
158 | \ Immediate bits for each token are at the end of the table, | |
159 | \ starting at (table-addr + /token-area). The bits are | |
160 | \ addressed individually, without regard for their numeric | |
161 | \ value within a byte, word, long or extended-cell. This | |
162 | \ means that the bit for token#0 is the highest-order bit | |
163 | \ in the array. This is not as confusing to implement as | |
164 | \ it is to explain; the bitset bitclear and bittest | |
165 | \ functions handle the mechanics of it all. This means | |
166 | \ that the pair ( N array-addr ) points to the same bit | |
167 | \ as ( {N mod 8} {array-addr + N/8} ) | |
168 | \ | |
169 | \ While this is a change from previous versions, it has | |
170 | \ no impact on compatibility: the token-tables and their | |
171 | \ associated "immediate" bits are local to a consolidation. | |
172 | \ | |
173 | : >offset ( code# table-addr -- bitoffset byteaddr ) | |
174 | /token-area + | |
175 | ; | |
176 | ||
177 | : set-immed ( code# table-addr -- ) | |
178 | >offset bitset | |
179 | ; | |
180 | ||
181 | : clear-immed ( code# table-addr -- ) | |
182 | >offset bitclear | |
183 | ; | |
184 | ||
185 | : immed? ( code# table-addr -- flag ) | |
186 | >offset bittest | |
187 | ; | |
188 | ||
189 | \ Gets a signed offset from the byte code stream. | |
190 | : get-offset ( -- n ) | |
191 | fcode-verbose? @ if interpreter-pointer @ then ( [? iptr ?] ) | |
192 | get-byte | |
193 | offset16? @ if | |
194 | 8 << get-byte + d# 16 | |
195 | else | |
196 | d# 24 | |
197 | then ( [? iptr ?] raw-offset shift-amount ) | |
198 | tuck << l->n swap >>a ( [? iptr ?] offset ) | |
199 | ||
200 | \ For Verbose-mode, print the amount of the offset and the (target). | |
201 | fcode-verbose? @ if ( iptr offset ) | |
202 | push-hex tuck ( offset iptr offset ) | |
203 | dup s. fc-spread @ * + fake-name .id ( offset ) | |
204 | pop-base | |
205 | then | |
206 | ; | |
207 | ||
208 | \ Gets a 16-bit word from the byte code stream. | |
209 | : get-word ( -- 16bit ) get-byte 8 << get-byte + ; | |
210 | ||
211 | \ Gets a longword from the byte code stream. | |
212 | : get-long ( -- long ) get-word d# 16 << get-word + | |
213 | fcode-verbose? @ if dup .h then | |
214 | ; | |
215 | ||
216 | \ Allow text strings only. Not composites, and no null-byte separators. | |
217 | ||
218 | : all-text? ( adr len -- flag ) | |
219 | false -rot bounds ?do drop ( -- ) | |
220 | i c@ char? dup 0= ?leave | |
221 | loop ( all-characters-printable? ) | |
222 | ; | |
223 | ||
224 | \ Types a string as bytes if it is not legitimately text. | |
225 | : protected-type ( $addr,len -- ) | |
226 | 2dup all-text? if type | |
227 | else 2dup | |
228 | ." ""( " chdump ." )""" | |
229 | dup if 2dup | |
230 | ." \ " | |
231 | [ also hidden ] emit.ln [ previous ] | |
232 | then 2drop | |
233 | then | |
234 | ; | |
235 | ||
236 | \ Gets a string from the byte code stream. | |
237 | : get-bstring ( -- adr len ) | |
238 | get-byte ( len ) dup string-buf c! ( len ) | |
239 | string-buf 1+ swap bounds ?do get-byte i c! loop | |
240 | string-buf count | |
241 | fcode-verbose? @ if ??cr 8 to-column 2dup protected-type cr then | |
242 | ; | |
243 | ||
244 | : token\immed ( code# table-addr -- xt immediate? ) | |
245 | 2dup immed? >r ( code# table-addr ) | |
246 | swap ta+ token@ r> | |
247 | ; | |
248 | headers | |
249 | \ Don't change fcode-find to return -1|0|1 like find, because | |
250 | \ some people use it to "rehead" definitions. If we need a function | |
251 | \ that returns -1|0|1, give it a different name. | |
252 | : fcode-find ( code# table# -- xt immediate? ) | |
253 | >token-table ( code# table-addr ) | |
254 | token\immed ( xt immediate? ) | |
255 | ; | |
256 | headerless | |
257 | \ Gets the address of a Forth word from the byte code stream. | |
258 | \ The byte code stream contains a byte code. The address of the | |
259 | \ Forth word corresponding to that byte code is found and returned. | |
260 | ||
261 | defer get-token-hook ' noop is get-token-hook | |
262 | ||
263 | : next-fc-token ( -- xt immediate? ) | |
264 | fcode-verbose? @ if | |
265 | ??cr interpreter-pointer @ u. ascii : emit 3 spaces | |
266 | then | |
267 | get-byte | |
268 | dup #token-tables >= over 0= or ( byte table0? ) | |
269 | if 0 else get-byte swap then ( code# table# ) | |
270 | fcode-verbose? @ if | |
271 | push-hex | |
272 | dup [ also hidden ] .2 over .2 [ previous ] | |
273 | pop-base | |
274 | then | |
275 | get-token-hook | |
276 | fcode-find ( xt immediate? ) | |
277 | fcode-verbose? @ if | |
278 | over .name dup if ['] immediate .name then | |
279 | then | |
280 | ; | |
281 | headers | |
282 | : get-token ( fcode# -- xt immediate? ) wbsplit fcode-find ; | |
283 | ||
284 | : set-token ( xt immediate? fcode# -- ) | |
285 | wbsplit >token-table ( xt immediate? code# table-addr ) | |
286 | rot if ( xt immediate? code# table-addr ) | |
287 | 2dup set-immed ( xt code# table-addr ) | |
288 | else ( xt code# table-addr ) | |
289 | 2dup clear-immed ( xt code# table-addr ) | |
290 | then ( xt code# table-addr ) | |
291 | swap ta+ token! | |
292 | ; | |
293 | ||
294 | headerless | |
295 | \ The action performed for each token in the byte code stream. Before | |
296 | \ executing byte-interpret, an action routine must be installed in | |
297 | \ do-byte-compile. | |
298 | defer do-byte-compile ( xt immediate? -- ) | |
299 | : verify-fcode-prom-checksum ( -- ) | |
300 | get-byte 3 < if ( ) | |
301 | get-word drop \ Checksum ( ) | |
302 | get-long drop \ Length ( ) | |
303 | else ( ) | |
304 | get-word ( cksum ) | |
305 | 0 get-long ( cksum 0 length ) | |
306 | interpreter-pointer @ >r ( cksum 0 length ) ( r: ip ) | |
307 | 8 - 0 ?do get-byte + loop ( cksum cksum' ) ( r: ip ) | |
308 | r> interpreter-pointer ! ( cksum cksum' ) | |
309 | lwsplit + lwsplit + h# 0ffff and <> if ( ) | |
310 | ." Incorrect FCode PROM checksum " ( ) | |
311 | then ( ) | |
312 | then ( ) | |
313 | ; | |
314 | headers | |
315 | variable fcode-checksum? fcode-checksum? off | |
316 | : version1 ( -- ) | |
317 | offset16? off | |
318 | fcode-checksum? @ if | |
319 | verify-fcode-prom-checksum | |
320 | else | |
321 | get-byte drop \ Pad byte | |
322 | get-word drop \ Checksum, | |
323 | get-long drop \ Length | |
324 | then | |
325 | ; | |
326 | : offset16 ( -- ) offset16? on ; | |
327 | headerless | |
328 | : (version2) ( spread -- ) | |
329 | fc-spread @ negate interpreter-pointer +! \ Undo previous increment | |
330 | fc-spread ! | |
331 | fc-spread @ interpreter-pointer +! \ Do new increment | |
332 | offset16 | |
333 | fcode-checksum? @ fc-spread @ and if | |
334 | verify-fcode-prom-checksum | |
335 | else | |
336 | get-byte drop \ Pad byte | |
337 | get-word drop \ Checksum, | |
338 | get-long drop \ Length | |
339 | then | |
340 | ; | |
341 | headers | |
342 | : start0 ( -- ) 0 (version2) ; | |
343 | : start1 ( -- ) 1 (version2) ; | |
344 | : start2 ( -- ) 2 (version2) ; | |
345 | : start4 ( -- ) 4 (version2) ; | |
346 | headerless | |
347 | \ The byte code interpreter loop. adr is the starting address of | |
348 | \ the byte code stream, and spread is the distance between successive | |
349 | \ bytes in the stream. | |
350 | : byte-interpret ( adr spread -- ) | |
351 | warning @ >r warning off | |
352 | fc-spread @ >r interpreter-pointer @ >r more-bytes? @ >r offset16? @ >r | |
353 | ||
354 | fc-spread ! interpreter-pointer ! more-bytes? on | |
355 | ||
356 | begin | |
357 | more-bytes? @ | |
358 | while | |
359 | next-fc-token do-byte-compile | |
360 | repeat | |
361 | ||
362 | r> offset16? ! r> more-bytes? ! r> interpreter-pointer ! r> fc-spread ! | |
363 | r> warning ! | |
364 | ; | |
365 | headers |