Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | \ ========== Copyright Header Begin ========================================== |
2 | \ | |
3 | \ Hypervisor Software File: extra.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: @(#)extra.fth 3.15 03/12/08 13:22:13 | |
43 | purpose: | |
44 | copyright: Copyright 1994-2003 Sun Microsystems, Inc. All Rights Reserved | |
45 | copyright: Copyright 1985-1994 Bradley Forthware | |
46 | copyright: Use is subject to license terms. | |
47 | ||
48 | \ Definitions originally from kerncode.fth which are not used in the | |
49 | \ "run-time" version. | |
50 | hex | |
51 | ||
52 | \ Execute a Forth word given a pointer to a code field address | |
53 | code perform ( addr-of-acf -- ) | |
54 | tos 0 scr rtget | |
55 | sp tos get | |
56 | scr base %g0 jmpl | |
57 | sp ainc | |
58 | end-code | |
59 | ||
60 | \ Select a vocabulary thread by hashing the lookup name. | |
61 | \ Hashing function: Use the lower 2 bits of the first character in | |
62 | \ the name to select one of 4 threads in the array pointed-to by voc-ptr. | |
63 | headerless | |
64 | code hash ( str-addr voc-apf -- thread ) | |
65 | \ The next 2 lines are equivalent to ">threads", which in this | |
66 | \ implementation happens to be the same as ">body >user" | |
67 | \t32 tos 8 tos ld \ Get the user number | |
68 | \t16 tos 2 tos lduh \ Get the user number | |
69 | up tos tos add \ Find the address of the threads | |
70 | ||
71 | sp scr pop | |
72 | scr 1 scr ldub | |
73 | bubble | |
74 | scr 3 scr and | |
75 | \t16 scr 1 scr sll | |
76 | \t32 scr 2 scr sll | |
77 | tos scr tos add | |
78 | c; | |
79 | headers | |
80 | \ Search a vocabulary thread (link) for a name matching string. | |
81 | \ If found, return its code field address and -1 if immediate, 1 if not | |
82 | \ immediate. If not found, return the string and 0. | |
83 | ||
84 | \ Name field: | |
85 | \ name: forth-style packed string, no tag bits | |
86 | \ flag: 40 bit is immediate bit | |
87 | \ Padding is optionally inserted between the name and the flags | |
88 | \ so that the byte after the flag byte is on an even boundary. | |
89 | ||
90 | \t32 code search-thread ( string link origin -- acf -1 | acf 1 | string 0 ) | |
91 | \t32 sp tos pop \ Discard origin; we already have it in a register | |
92 | \t32 \ Registers: | |
93 | \t32 \ tos alf of word being tested | |
94 | \t32 \ scr string | |
95 | \t32 \ sc1 name being tested | |
96 | \t32 \ sc2 # of characters left to test | |
97 | \t32 \ string is kept on the top of the external stack | |
98 | \t32 | |
99 | \t32 begin | |
100 | \t32 tos base cmp 0<> \ Test for end of list | |
101 | \t32 while | |
102 | \t32 tos /token sc1 add \ Get name address of word to test | |
103 | \t32 sp scr get \ Get string address | |
104 | \t32 bubble | |
105 | \t32 scr 0 sc2 ldub \ get the name field length | |
106 | \t32 begin | |
107 | \t32 scr 0 sc3 ldub \ Compare 2 characters | |
108 | \t32 sc1 0 sc4 ldub | |
109 | \t32 bubble | |
110 | \t32 sc3 sc4 cmp | |
111 | \t32 0= while \ Keep looking as long as characters match | |
112 | \t32 nop | |
113 | \t32 scr 1 scr add \ Increment byte pointers | |
114 | \t32 sc2 1 sc2 subcc \ Decrement byte counter | |
115 | \t32 0< if \ If we've tested all chars, the names match. | |
116 | \t32 sc1 1 sc1 add \ Delay slot | |
117 | \t32 sc1 0 tos ldub \ Get flags byte into tos register | |
118 | \t32 | |
119 | \t32 \dtc sc1 4 sc1 add \ Now find the code field by | |
120 | \t32 \dtc sc1 -4 sc1 and \ aligning to the next 4 byte boundary | |
121 | \t32 | |
122 | \t32 \itc sc1 2 sc1 add \ Now find the code field by | |
123 | \t32 \itc sc1 -2 sc1 and \ aligning to the next 2 byte boundary | |
124 | \t32 | |
125 | \t32 tos 20 %g0 andcc \ Test the alias flag | |
126 | \t32 0<> if | |
127 | \t32 nop | |
128 | \t32 sc1 0 sc1 rtget \ Get acf | |
129 | \t32 sc1 base sc1 add \ Relocate | |
130 | \t32 \itc else | |
131 | \t32 \itc nop | |
132 | \t32 \itc sc1 0 sc2 lduh \ Is is a realigned code word? | |
133 | \t32 \itc sc2 0 cmp | |
134 | \t32 \itc = if nop | |
135 | \t32 \itc sc1 2 sc1 add \ Align to 4 byte boundary | |
136 | \t32 \itc then | |
137 | \t32 | |
138 | \t32 then | |
139 | \t32 | |
140 | \t32 sc1 sp put \ Replace string on stack with acf | |
141 | \t32 tos 40 %g0 andcc \ Test the immediate flag | |
142 | \t32 0<> if | |
143 | \t32 -1 tos move \ Not immediate \ Delay slot | |
144 | \t32 ( else ) | |
145 | \t32 1 tos move \ Immediate | |
146 | \t32 then | |
147 | \t32 inhibit-delay | |
148 | \t32 next | |
149 | \t32 then | |
150 | \t32 repeat | |
151 | \t32 nop | |
152 | \t32 | |
153 | \t32 \ The names did not match, so check the next name in the list | |
154 | \t32 tos 0 tos rtget \ Fetch next link | |
155 | \t32 tos base tos add | |
156 | \t32 repeat | |
157 | \t32 nop | |
158 | \t32 | |
159 | \t32 \ If we get here, we've checked all the names with no luck | |
160 | \t32 0 tos move | |
161 | \t32 c; | |
162 | ||
163 | code ($find-next) ( adr len link -- adr len alf true | adr len false ) | |
164 | \ Registers: | |
165 | \ tos alf of word being tested | |
166 | \ scr string | |
167 | \ sc1 anf of word being tested | |
168 | \ sc2 # of characters left to test | |
169 | \ sc3 character from string | |
170 | \ sc4 character from name | |
171 | \ sc5 string length | |
172 | \ string is kept on the top of the external stack | |
173 | ||
174 | sp 1 /n* scr nget \ Get string address | |
175 | ||
176 | sp 0 /n* sc5 nget \ get the name field length | |
177 | ||
178 | ahead | |
179 | scr sc5 scr add \ Point to end of string | |
180 | ||
181 | begin | |
182 | tos /token tos sub \ >link | |
183 | tos 1 sc1 sub \ sc1 points to count byte at *end* of string | |
184 | ||
185 | %g0 sc5 sc2 subcc \ Set starting loop index and cond. codes | |
186 | begin | |
187 | sc1 sc2 sc4 ldub \ Get character from name field | |
188 | scr sc2 sc3 ldub \ Get character from search string | |
189 | sc3 sc4 cmp \ Compare 2 characters | |
190 | <> until | |
191 | sc2 1 sc2 addcc \ Increment loop index | |
192 | ||
193 | 0> if \ If we've tested all name chars, we | |
194 | sc1 0 sc4 ldub \ get the count byte from the name field | |
195 | sc4 h# 1f sc4 and \ may have a match; check the count byte | |
196 | sc4 sc5 cmp \ Compare count bytes | |
197 | = if | |
198 | nop | |
199 | tos sp push \ Push alf above str$ | |
200 | -1 tos move \ True on top of stack means "found" | |
201 | next | |
202 | then | |
203 | then | |
204 | ||
205 | but then | |
206 | \ The names did not match, so check the next name in the list | |
207 | tos 0 tos rtget \ Fetch next link ( next acf ) | |
208 | tos 0 cmp \ Test for end of list | |
209 | = until | |
210 | tos base tos add \ Relocate | |
211 | ||
212 | \ If we get here, we've checked all the names with no luck | |
213 | 0 tos move | |
214 | c; | |
215 | ||
216 | headers | |
217 | : ?negate ( n1 n2 -- n3 ) if negate then ; | |
218 | ||
219 | code wflip ( l1 -- l2 ) \ word-swap the low two words; clear the rest. | |
220 | tos /n 2 - 8 * scr slln \ lowest word to upper word of scr | |
221 | 64\ tos /n 4 - 8 * tos slln \ second word to upper word of tos | |
222 | tos d# 16 tos srln \ second word to 2nd-from-upper word of tos | |
223 | tos scr tos or \ Join with lowest word (the rest is cleared). | |
224 | 64\ tos /n 4 - 8 * tos srln \ and back into place | |
225 | c; | |
226 | ||
227 | code toggle ( addr byte-mask -- ) | |
228 | sp 0 /n* scr nget | |
229 | bubble | |
230 | scr 0 sc1 ldub | |
231 | bubble | |
232 | sc1 tos sc1 xor | |
233 | sc1 scr 0 stb | |
234 | sp 1 /n* tos nget | |
235 | sp 2 /n* sp add | |
236 | c; | |
237 | code log2 ( n -- log2-of-n ) | |
238 | %g0 1 scr sub \ result -> scr Init'l = -1; return -1 if N was zero. | |
239 | begin | |
240 | tos %g0 %g0 subcc | |
241 | 0<> while | |
242 | tos 1 tos srln | |
243 | repeat | |
244 | scr 1 scr add | |
245 | scr tos move | |
246 | c; | |
247 | \ | |
248 | \ Extract some of the rightmost bits from a cell | |
249 | code bits ( mask #bits -- mask' bits ) | |
250 | sp %g0 scr nget \ scr <= mask | |
251 | scr tos sc1 srln \ sc1 <= mask' | |
252 | 1 sc2 set | |
253 | sc2 tos tos slln | |
254 | tos 1 tos sub \ tos <= lowbits | |
255 | scr tos tos and \ tos <= bits | |
256 | sc1 %g0 sp nput \ mask' => next-on-stack | |
257 | c; | |
258 | ||
259 | code s->l ( n.signed -- l ) inhibit-delay c; | |
260 | 32\ code l->n ( l -- n ) inhibit-delay c; | |
261 | 64\ code l->n ( l -- n ) tos 0 tos sra c; | |
262 | code n->a ( n -- a ) inhibit-delay c; | |
263 | 32\ code l->w ( l -- w ) tos d# 16 tos sll tos d# 16 tos srl c; | |
264 | 64\ code l->w ( l -- w ) tos d# 48 tos sllx tos d# 48 tos srlx c; | |
265 | 32\ code n->w ( n -- w ) tos d# 16 tos sll tos d# 16 tos srl c; | |
266 | 64\ code n->w ( n -- w ) tos d# 48 tos sllx tos d# 48 tos srlx c; | |
267 | ||
268 | code l>r ( l -- ) tos rp push sp tos pop c; | |
269 | code lr> ( -- l ) tos sp push rp tos pop c; | |
270 | code lr@ ( -- l ) tos sp push rp tos get c; | |
271 | ||
272 | headerless | |
273 | code /t* ( n -- n*/t ) tos 2 tos sll c; | |
274 | headers | |
275 | ||
276 | \t16 tshift-t constant tshift \ Shift factor for offset tokens | |
277 | ||
278 | #talign-t constant #talign \ Alignment of tokens compiled in colon defs. | |
279 | ||
280 | #linkalign-t constant #linkalign | |
281 | /l constant #align \ Hardware alignment: instruction, word fetches | |
282 | ||
283 | \t16 1 tshift-t << constant #acf-align \ Code field alignment | |
284 | \t32 #acf-align-t constant #acf-align | |
285 | ||
286 | : align ( -- ) #align (align) ; | |
287 | : talign ( -- ) #talign (align) ; | |
288 | : taligned ( adr -- adr' ) #talign round-up ; | |
289 | \ headerless | |
290 | : linkalign ( -- ) #linkalign (align) ; | |
291 | headers | |
292 | ||
293 | : u* ( un1 un2 -- product ) um* drop ; |