[OpenSPARC-T2-SAM] / obp / obp / fm / kernel / sparc / extra.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: extra.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)extra.fth 3.15 03/12/08 13:22:13
purpose: 
copyright: Copyright 1994-2003 Sun Microsystems, Inc.  All Rights Reserved
copyright: Copyright 1985-1994 Bradley Forthware
copyright: Use is subject to license terms.

\ Definitions originally from kerncode.fth which are not used in the
\ "run-time" version.
hex

\ Execute a Forth word given a pointer to a code field address
code perform ( addr-of-acf -- )
   tos 0      scr  rtget
   sp         tos  get
   scr base   %g0  jmpl
   sp              ainc
end-code

\ Select a vocabulary thread by hashing the lookup name.
\ Hashing function:  Use the lower 2 bits of the first character in
\ the name to select one of 4 threads in the array pointed-to by voc-ptr.
headerless
code hash  ( str-addr voc-apf -- thread )
   \ The next 2 lines are equivalent to ">threads", which in this
   \ implementation happens to be the same as ">body >user"
\t32   tos 8   tos   ld		\ Get the user number
\t16   tos 2   tos   lduh	\ Get the user number
   up tos  tos   add	\ Find the address of the threads

   sp      scr   pop
   scr 1   scr   ldub
   bubble
   scr 3   scr   and
\t16   scr 1   scr   sll
\t32   scr 2   scr   sll
   tos scr tos   add
c;
headers
\ Search a vocabulary thread (link) for a name matching string.
\ If found, return its code field address and -1 if immediate, 1 if not
\ immediate.  If not found, return the string and 0.

\ Name field:
\     name: forth-style packed string, no tag bits
\     flag: 40 bit is immediate bit
\ Padding is optionally inserted between the name and the flags
\ so that the byte after the flag byte is on an even boundary.

\t32 code search-thread ( string link origin -- acf -1  | acf 1  | string 0 )
\t32    sp  tos  pop      \ Discard origin; we already have it in a register
\t32 \ Registers:
\t32 \ tos    alf of word being tested
\t32 \ scr    string
\t32 \ sc1    name being tested
\t32 \ sc2    # of characters left to test
\t32 \ string is kept on the top of the external stack
\t32
\t32    begin
\t32       tos base   cmp    0<>	\ Test for end of list
\t32    while
\t32       tos /token  sc1  add		\ Get name address of word to test
\t32       sp          scr  get    	\ Get string address
\t32       bubble
\t32       scr 0    sc2  ldub		\ get the name field length
\t32       begin
\t32          scr 0  sc3  ldub		\ Compare 2 characters
\t32          sc1 0  sc4  ldub
\t32 	 bubble
\t32          sc3 sc4     cmp
\t32       0= while			\ Keep looking as long as characters match
\t32 	 nop
\t32          scr 1  scr  add		\ Increment byte pointers
\t32          sc2 1  sc2  subcc		\ Decrement byte counter
\t32          0< if			\ If we've tested all chars, the names match.
\t32          sc1 1  sc1  add		\ Delay slot
\t32             sc1 0   tos  ldub	\ Get flags byte into tos register
\t32
\t32 \dtc        sc1 4   sc1  add	\ Now find the code field by
\t32 \dtc        sc1 -4  sc1  and	\ aligning to the next 4 byte boundary
\t32
\t32 \itc        sc1 2   sc1  add	\ Now find the code field by
\t32 \itc        sc1 -2  sc1  and	\ aligning to the next 2 byte boundary
\t32
\t32 	    tos 20  %g0  andcc  	\ Test the alias flag
\t32 	    0<> if
\t32        nop
\t32 	       sc1 0      sc1  rtget	\ Get acf
\t32           sc1 base   sc1  add	\ Relocate
\t32 \itc   else
\t32 \itc      nop
\t32 \itc      sc1 0   sc2  lduh	\ Is is a realigned code word?
\t32 \itc      sc2 0        cmp
\t32 \itc      = if  nop
\t32 \itc         sc1 2 sc1 add		\ Align to 4 byte boundary
\t32 \itc      then
\t32
\t32        then
\t32
\t32 	    sc1     sp   put		\ Replace string on stack with acf
\t32 	    tos 40  %g0  andcc  	\ Test the immediate flag
\t32 	    0<> if
\t32 	       -1   tos  move		\ Not immediate  \ Delay slot
\t32 	    ( else )
\t32 	       1    tos  move		\ Immediate
\t32 	    then
\t32             inhibit-delay
\t32 	    next
\t32          then
\t32       repeat
\t32          nop
\t32
\t32       \ The names did not match, so check the next name in the list
\t32       tos 0     tos  rtget		\ Fetch next link
\t32       tos base  tos  add
\t32    repeat
\t32       nop
\t32
\t32    \ If we get here, we've checked all the names with no luck
\t32    0  tos   move
\t32 c;

code ($find-next)  ( adr len link -- adr len alf true  |  adr len false )
\ Registers:
\ tos    alf of word being tested
\ scr    string
\ sc1    anf of word being tested
\ sc2    # of characters left to test
\ sc3    character from string
\ sc4    character from name
\ sc5    string length
\ string is kept on the top of the external stack

   sp  1 /n*      scr  nget	\ Get string address

   sp  0 /n*      sc5  nget	\ get the name field length

   ahead
   scr sc5        scr  add	\ Point to end of string

   begin
      tos /token  tos  sub	\ >link
      tos 1       sc1  sub	\ sc1 points to count byte at *end* of string

      %g0 sc5     sc2  subcc	\ Set starting loop index and cond. codes
      begin
	 sc1 sc2  sc4  ldub	\ Get character from name field
	 scr sc2  sc3  ldub	\ Get character from search string
	 sc3 sc4       cmp	\ Compare 2 characters
      <> until
         sc2 1    sc2  addcc	\ Increment loop index

      0> if			\ If we've tested all name chars, we
	 sc1 0      sc4  ldub	\ get the count byte from the name field
	 sc4 h# 1f  sc4  and	\ may have a match; check the count byte
	 sc4 sc5       cmp	\ Compare count bytes
	 = if
	 nop
	    tos   sp   push	\ Push alf above str$
	    -1    tos  move	\ True on top of stack means "found"
	    next
         then
      then

      but then
      \ The names did not match, so check the next name in the list
      tos 0       tos  rtget	\ Fetch next link  ( next acf )
      tos         0    cmp		\ Test for end of list
   = until
      tos base    tos  add		\ Relocate

   \ If we get here, we've checked all the names with no luck
   0  tos   move
c;

headers
: ?negate  ( n1 n2 -- n3 )  if  negate  then  ;

code wflip ( l1 -- l2 )  \ word-swap the low two words; clear the rest.
    tos  /n 2 - 8 *  scr  slln	\  lowest word to upper word of scr
64\ tos  /n 4 - 8 *  tos  slln	\  second word to upper word of tos
    tos d# 16        tos  srln	\  second word to 2nd-from-upper word of tos
    tos       scr    tos  or	\  Join with lowest word (the rest is cleared).
64\ tos  /n 4 - 8 *  tos  srln	\  and back into place
c;

code toggle  ( addr byte-mask -- )
   sp  0 /n*  scr  nget
   bubble
   scr 0    sc1  ldub
   bubble
   sc1 tos  sc1  xor
   sc1     scr 0 stb
   sp 1 /n*  tos  nget
   sp 2 /n*  sp   add
c;
code log2 ( n -- log2-of-n )
   %g0  1  scr  sub	\ result -> scr  Init'l = -1; return -1 if N was zero.
   begin
      tos  %g0  %g0   subcc
   0<> while
      tos    1  tos   srln
   repeat
      scr    1  scr   add
   scr  tos  move
c;
\
\  Extract some of the rightmost bits from a cell
code bits ( mask #bits -- mask' bits )
    sp   %g0   scr    nget	\  scr <=  mask
    scr  tos   sc1    srln      \  sc1 <=  mask'
    1    sc2          set
    sc2  tos   tos    slln
    tos    1   tos    sub	\  tos <= lowbits
    scr  tos   tos    and	\  tos <= bits
    sc1  %g0   sp     nput	\  mask' => next-on-stack
c;

code s->l ( n.signed -- l )  inhibit-delay  c;
32\ code l->n ( l -- n )  inhibit-delay  c;
64\ code l->n ( l -- n )  tos 0 tos sra  c;
code n->a     ( n -- a )  inhibit-delay  c;
32\ code l->w ( l -- w )  tos d# 16  tos  sll   tos d# 16  tos  srl  c;
64\ code l->w ( l -- w )  tos d# 48  tos  sllx  tos d# 48  tos  srlx c;
32\ code n->w ( n -- w )  tos d# 16  tos  sll   tos d# 16  tos  srl  c;
64\ code n->w ( n -- w )  tos d# 48  tos  sllx  tos d# 48  tos  srlx  c;

code l>r  ( l -- )     tos rp push   sp tos pop    c;
code lr>  ( -- l )     tos sp push   rp tos pop    c;
code lr@  ( -- l )     tos sp push   rp tos get    c;

headerless
code /t* ( n -- n*/t )  tos 2  tos  sll  c;
headers

\t16 tshift-t constant tshift	\ Shift factor for offset tokens

#talign-t constant #talign	\ Alignment of tokens compiled in colon defs.

#linkalign-t constant #linkalign
/l constant #align		\ Hardware alignment: instruction, word fetches

\t16 1 tshift-t << constant #acf-align	\ Code field alignment
\t32 #acf-align-t constant #acf-align

: align  ( -- )  #align (align)  ;
: talign  ( -- )  #talign (align)  ;
: taligned  ( adr -- adr' )  #talign round-up  ;
\ headerless
: linkalign  ( -- )  #linkalign (align)  ;
headers

: u*  ( un1 un2 -- product )  um* drop  ;
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 ;