[OpenSPARC-T2-SAM] / obp / obp / fm / meta / sparc / target.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: target.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 ============================================
purpose: 
copyright: Copyright 1990-2003 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.
\ Copyright 1985-1990 Bradley Forthware

\ Target configuration - SPARC

decimal

only forth also meta assembler definitions
: normal ( -- )   \ Perform target-dependent assembler initialization
;

only forth also meta definitions

: init-relocation-t ; immediate

: lobyte th 0ff and ;
: hibyte 8 >> lobyte ;

\t16-t tshift-t constant tshift-t

2 constant /w-t
4 constant /l-t
8 constant /d-t
32\ /l-t constant /n-t
64\ /d-t constant /n-t

\t16-t /w-t constant /a-t
\t32-t /l-t constant /a-t
/a-t constant /thread-t
\t16-t /w-t constant /token-t
\t32-t /l-t constant /token-t
\t16-t /w-t constant /link-t
\t32-t /l-t constant /link-t
/token-t constant /defer-t
/n-t th 800 * constant user-size-t
/n-t th 200 1- * constant ps-size-t
/n-t th 200 1- * constant rs-size-t
\t16-t /w-t constant /user#-t
\t32-t /l-t constant /user#-t

\ 32 bit host Forth compiling 32-bit target Forth
: l->n-t ; immediate
: n->l-t ; immediate
: n->n-t ; immediate
: s->l-t ; immediate

: c!-t ( n add -- ) >hostaddr c! ;
: c@-t ( target-address -- n ) >hostaddr c@ ;

\ SPARC is big-endian
: w!-t ( n add -- )
   over hibyte over c!-t  ca1+ swap lobyte swap c!-t
;
: l!-t ( l add -- ) >r lwsplit r@ w!-t r> /w-t + w!-t ;
: !-t  ( n add -- ) l!-t ;

: w@-t ( target-address -- n )
   dup c@-t 8 << swap 1+ c@-t or
;
: l@-t ( target-address -- n )
   dup >r /w-t + w@-t  r> w@-t  wljoin
;
32\ : @-t  ( target-address -- n ) l@-t ;
64\ : @-t  ( target-address -- n ) /l + l@-t ;

\ Store target data types into the host address space.
: c-t!  ( c host-address -- )  c!  ;
: w-t!  ( w host-address -- )
   over hibyte  over c-t!  ca1+  swap lobyte swap c-t!
;
: l-t!  ( l host-address -- )  >r  lwsplit  r@ w-t!  r> /w-t + w-t!  ;
32\ : n-t!  ( n host-address -- )  l-t!  ;
64\ : n-t!  ( n host-address -- )  /l + l-t!  ;

\ Next 3 are machine-independent
: c,-t ( byte -- )  dp-t @ c!-t 1 dp-t +! ;
: w,-t ( word -- )  dp-t @ w!-t /w-t dp-t +! ;
: l,-t ( long -- )  dp-t @ l!-t /l-t dp-t +! ;

32\ : ,-t ( n -- )  l,-t  ;        \ for 32 bit stacks
64\ : ,-t ( n -- )
64\    dup h# 8000.0000 and  if
64\       dup h# ffff.ff00 u>  if  -1  else  0  then
64\    else 0  then  l,-t l,-t
64\ ;
: ,user#-t ( user# -- )
\t32-t  l,-t
\t16-t  w,-t
;

: a@-t ( target-address -- target-address )
\t16-t   w@-t tshift-t <<  origin-t +
\t32-t   l@-t
;
: a!-t ( token target-address -- )
\t16-t   swap  origin-t -  tshift-t >>  swap  w!-t
\t32-t   l!-t
;
: token@-t ( target-address -- target-acf )  a@-t  ;
: token!-t ( acf target-address -- )  a!-t  ;

: rlink@-t  ( occurrence -- next-occurrence )
\t16-t   w@-t 1 <<  origin-t +
\t32-t   a@-t
;
: rlink!-t  ( next-occurrence occurrence -- )
\t16-t   swap  origin-t -  1 >>  swap  w!-t
\t32-t   token!-t
;


\ Machine independent
: a,-t  ( adr -- )  here-t /a-t allot-t  a!-t  ;
: token,-t ( token -- )  here-t /token-t allot-t  token!-t  ;

\ These versions of linkx-t are for absolute links
: link@-t ( target-address -- target-address' )  a@-t  ;
: link!-t ( target-address target-address -- )  a!-t  ;
: link,-t ( target-address -- )  a,-t  ;

: a-t@ ( host-address -- target-address )
\t16-t  w@ tshift-t <<  origin-t +
\t32-t  l@
;
: a-t! ( target-address host-address -- )
\t16-t  swap origin-t -  tshift-t >> swap w!
\t32-t  l!
;
: rlink-t@  ( host-adr -- target-adr )
\t16-t  w@ 1 <<  origin-t +
\t32-t  l@
;
: rlink-t!  ( target-adr host-adr -- )
\t16-t  swap origin-t -  1 >> swap w!
\t32-t  l!
;

: token-t@ ( host-address -- target-acf )  a-t@  ;
: token-t! ( target-acf host-address -- )  a-t!  ;
: link-t@  ( host-address -- target-address )  a-t@  ;
: link-t!  ( target-address host-address -- )  a-t!  ;

\ Machine independent
: a-t, ( target-address -- )  here  /a-t allot  a-t!  ;
: token-t, ( target-address -- )  here  /token-t allot  token-t!  ;
: >body-t ( cfa-t -- pfa-t )
\t32-t   8 +		\ Call instruction plus delay instruction
\t16-t   2 +		\ Indirect token
;

1 constant #threads-t

create threads-t   #threads-t /link-t * allot

: $hash-t  ( str voc-ptr -- thread )
   nip swap c@  #threads-t 1- and  /thread-t * +
;

\ Should allocate these dynamically.
\ The dictionary space should be dynamically allocated too.

\ The user area image lives in the host address space.
\ We wish to store into the user area with -t commands so as not
\ to need separate words to store target items into host addresses.
\ That is why user+ returns a target address.

\ Machine Independent

0 constant userarea-t
: setup-user-area ( -- )
   user-size-t alloc-mem is userarea-t
   userarea-t user-size-t  erase
;

: >user-t ( cfa-t -- user-address-t )
   >body-t
\t32-t  l@-t
\t16-t  w@-t
   userarea-t  +
;

: n>link-t ( anf-t -- alf-t )  dup begin 1+ dup c@ h# 80 and until c@ + 1+  ;
: l>name-t ( alf-t -- anf-t )  1- dup c@ h# 1f and -  ;
: >link-t ( acf-t -- alf-t ) /link-t - ;
decimal
/l constant #align-t  \ XXX Is this right ?
\t16-t /w constant #talign-t
\t32-t /l constant #talign-t
\t16-t 1 tshift-t << constant #linkalign-t
\t16-t 1 tshift-t << constant #acf-align-t
\t32-t /l constant #linkalign-t
\t32-t /l constant #acf-align-t
: aligned-t  ( n1 -- n2 )  #align-t 1- +  #align-t negate and  ;
: acf-aligned-t  ( n1 -- n2 )  #acf-align-t 1- +  #acf-align-t negate and  ;

\ NullFix bl -> 0
: align-t ( -- )
   begin   here-t #align-t  1- and   while   0 c,-t   repeat
;
: talign-t ( -- )
   begin   here-t #talign-t 1- and   while   0 c,-t   repeat
;
: linkalign-t  ( -- )
   begin   here-t #linkalign-t 1- and   while   0 c,-t   repeat
;
: acf-align-t  ( -- )
   begin   here-t #acf-align-t 1- and   while   0 c,-t   repeat
;

: entercode ( -- )
   only forth also labels also meta also srassembler
\   assembler
   [ assembler ] normal [ meta ]
;

\ Next 5 are Machine Independent
: cmove-t ( from to-t n -- )
  0 do over c@  over c!-t  1+ swap 1+ swap loop  2drop
;
: place-cstr-t  ( adr len cstr-adr-t -- cstr-adr-t )
   >r  tuck r@ swap cmove-t  ( len ) r@ +  0 swap c!-t  r>
;
: "copy-t ( from to-t -- )
  over c@ 2+  cmove-t
;
: toggle-t ( addr-t n -- ) swap >r r@ c@-t xor r> c!-t ;

: clear-threads-t  ( hostaddr -- )
   #threads-t /link-t * bounds  do
      origin-t i link-t!
   /link +loop
;
: initmeta  ( -- )
   threads-t clear-threads-t  threads-t current-t !
;

\ For compiling branch offsets used by control constructs.
\ These compile relative branches.

\t16-t /w-t constant /branch
\t32-t /l-t constant /branch
: branch! ( from target -- )
   over - ( from offset ) swap
\t16-t   w!-t
\t32-t   l!-t
;
: branch, ( target -- )
   here-t -
\t16-t   w,-t
\t32-t   l,-t
;

: thread-t!  ( thread adr -- )  link-t!  ;

only forth also meta also definitions
: install-target-assembler  ( -- )
   [ also assembler ]
   ['] /l-t    is /asm
   ['] here-t  is here
   ['] allot-t is asm-allot
   ['] l@-t    is asm@
   ['] l!-t    is asm!
   [ previous ]
;
: install-host-assembler  ( -- )
   [ assembler ] resident-assembler [ meta ]
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: target.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	purpose:
	43	copyright: Copyright 1990-2003 Sun Microsystems, Inc. All Rights Reserved
	44	copyright: Use is subject to license terms.
	45	\ Copyright 1985-1990 Bradley Forthware
	46
	47	\ Target configuration - SPARC
	48
	49	decimal
	50
	51	only forth also meta assembler definitions
	52	: normal ( -- ) \ Perform target-dependent assembler initialization
	53	;
	54
	55	only forth also meta definitions
	56
	57	: init-relocation-t ; immediate
	58
	59	: lobyte th 0ff and ;
	60	: hibyte 8 >> lobyte ;
	61
	62	\t16-t tshift-t constant tshift-t
	63
	64	2 constant /w-t
65	4 constant /l-t
66	8 constant /d-t
67	32\ /l-t constant /n-t
68	64\ /d-t constant /n-t
69
70	\t16-t /w-t constant /a-t
71	\t32-t /l-t constant /a-t
72	/a-t constant /thread-t
73	\t16-t /w-t constant /token-t
74	\t32-t /l-t constant /token-t
75	\t16-t /w-t constant /link-t
76	\t32-t /l-t constant /link-t
77	/token-t constant /defer-t
78	/n-t th 800 * constant user-size-t
79	/n-t th 200 1- * constant ps-size-t
80	/n-t th 200 1- * constant rs-size-t
81	\t16-t /w-t constant /user#-t
82	\t32-t /l-t constant /user#-t
83
84	\ 32 bit host Forth compiling 32-bit target Forth
85	: l->n-t ; immediate
86	: n->l-t ; immediate
87	: n->n-t ; immediate
88	: s->l-t ; immediate
89
90	: c!-t ( n add -- ) >hostaddr c! ;
91	: c@-t ( target-address -- n ) >hostaddr c@ ;
92
93	\ SPARC is big-endian
94	: w!-t ( n add -- )
95	over hibyte over c!-t ca1+ swap lobyte swap c!-t
96	;
97	: l!-t ( l add -- ) >r lwsplit r@ w!-t r> /w-t + w!-t ;
98	: !-t ( n add -- ) l!-t ;
99
100	: w@-t ( target-address -- n )
101	dup c@-t 8 << swap 1+ c@-t or
102	;
103	: l@-t ( target-address -- n )
104	dup >r /w-t + w@-t r> w@-t wljoin
105	;
106	32\ : @-t ( target-address -- n ) l@-t ;
107	64\ : @-t ( target-address -- n ) /l + l@-t ;
108
109	\ Store target data types into the host address space.
110	: c-t! ( c host-address -- ) c! ;
111	: w-t! ( w host-address -- )
112	over hibyte over c-t! ca1+ swap lobyte swap c-t!
113	;
114	: l-t! ( l host-address -- ) >r lwsplit r@ w-t! r> /w-t + w-t! ;
115	32\ : n-t! ( n host-address -- ) l-t! ;
116	64\ : n-t! ( n host-address -- ) /l + l-t! ;
117
118	\ Next 3 are machine-independent
119	: c,-t ( byte -- ) dp-t @ c!-t 1 dp-t +! ;
120	: w,-t ( word -- ) dp-t @ w!-t /w-t dp-t +! ;
121	: l,-t ( long -- ) dp-t @ l!-t /l-t dp-t +! ;
122
123	32\ : ,-t ( n -- ) l,-t ; \ for 32 bit stacks
124	64\ : ,-t ( n -- )
125	64\ dup h# 8000.0000 and if
126	64\ dup h# ffff.ff00 u> if -1 else 0 then
127	64\ else 0 then l,-t l,-t
128	64\ ;
129	: ,user#-t ( user# -- )
130	\t32-t l,-t
131	\t16-t w,-t
132	;
133
134	: a@-t ( target-address -- target-address )
135	\t16-t w@-t tshift-t << origin-t +
136	\t32-t l@-t
137	;
138	: a!-t ( token target-address -- )
139	\t16-t swap origin-t - tshift-t >> swap w!-t
140	\t32-t l!-t
141	;
142	: token@-t ( target-address -- target-acf ) a@-t ;
143	: token!-t ( acf target-address -- ) a!-t ;
144
145	: rlink@-t ( occurrence -- next-occurrence )
146	\t16-t w@-t 1 << origin-t +
147	\t32-t a@-t
148	;
149	: rlink!-t ( next-occurrence occurrence -- )
150	\t16-t swap origin-t - 1 >> swap w!-t
151	\t32-t token!-t
152	;
153
154
155	\ Machine independent
156	: a,-t ( adr -- ) here-t /a-t allot-t a!-t ;
157	: token,-t ( token -- ) here-t /token-t allot-t token!-t ;
158
159	\ These versions of linkx-t are for absolute links
160	: link@-t ( target-address -- target-address' ) a@-t ;
161	: link!-t ( target-address target-address -- ) a!-t ;
162	: link,-t ( target-address -- ) a,-t ;
163
164	: a-t@ ( host-address -- target-address )
165	\t16-t w@ tshift-t << origin-t +
166	\t32-t l@
167	;
168	: a-t! ( target-address host-address -- )
169	\t16-t swap origin-t - tshift-t >> swap w!
170	\t32-t l!
171	;
172	: rlink-t@ ( host-adr -- target-adr )
173	\t16-t w@ 1 << origin-t +
174	\t32-t l@
175	;
176	: rlink-t! ( target-adr host-adr -- )
177	\t16-t swap origin-t - 1 >> swap w!
178	\t32-t l!
179	;
180
181	: token-t@ ( host-address -- target-acf ) a-t@ ;
182	: token-t! ( target-acf host-address -- ) a-t! ;
183	: link-t@ ( host-address -- target-address ) a-t@ ;
184	: link-t! ( target-address host-address -- ) a-t! ;
185
186	\ Machine independent
187	: a-t, ( target-address -- ) here /a-t allot a-t! ;
188	: token-t, ( target-address -- ) here /token-t allot token-t! ;
189	: >body-t ( cfa-t -- pfa-t )
190	\t32-t 8 + \ Call instruction plus delay instruction
191	\t16-t 2 + \ Indirect token
192	;
193
194	1 constant #threads-t
195
196	create threads-t #threads-t /link-t * allot
197
198	: $hash-t ( str voc-ptr -- thread )
199	nip swap c@ #threads-t 1- and /thread-t * +
200	;
201
202	\ Should allocate these dynamically.
203	\ The dictionary space should be dynamically allocated too.
204
205	\ The user area image lives in the host address space.
206	\ We wish to store into the user area with -t commands so as not
207	\ to need separate words to store target items into host addresses.
208	\ That is why user+ returns a target address.
209
210	\ Machine Independent
211
212	0 constant userarea-t
213	: setup-user-area ( -- )
214	user-size-t alloc-mem is userarea-t
215	userarea-t user-size-t erase
216	;
217
218	: >user-t ( cfa-t -- user-address-t )
219	>body-t
220	\t32-t l@-t
221	\t16-t w@-t
222	userarea-t +
223	;
224
225	: n>link-t ( anf-t -- alf-t ) dup begin 1+ dup c@ h# 80 and until c@ + 1+ ;
226	: l>name-t ( alf-t -- anf-t ) 1- dup c@ h# 1f and - ;
227	: >link-t ( acf-t -- alf-t ) /link-t - ;
228	decimal
229	/l constant #align-t \ XXX Is this right ?
230	\t16-t /w constant #talign-t
231	\t32-t /l constant #talign-t
232	\t16-t 1 tshift-t << constant #linkalign-t
233	\t16-t 1 tshift-t << constant #acf-align-t
234	\t32-t /l constant #linkalign-t
235	\t32-t /l constant #acf-align-t
236	: aligned-t ( n1 -- n2 ) #align-t 1- + #align-t negate and ;
237	: acf-aligned-t ( n1 -- n2 ) #acf-align-t 1- + #acf-align-t negate and ;
238
239	\ NullFix bl -> 0
240	: align-t ( -- )
241	begin here-t #align-t 1- and while 0 c,-t repeat
242	;
243	: talign-t ( -- )
244	begin here-t #talign-t 1- and while 0 c,-t repeat
245	;
246	: linkalign-t ( -- )
247	begin here-t #linkalign-t 1- and while 0 c,-t repeat
248	;
249	: acf-align-t ( -- )
250	begin here-t #acf-align-t 1- and while 0 c,-t repeat
251	;
252
253	: entercode ( -- )
254	only forth also labels also meta also srassembler
255	\ assembler
256	[ assembler ] normal [ meta ]
257	;
258
259	\ Next 5 are Machine Independent
260	: cmove-t ( from to-t n -- )
261	0 do over c@ over c!-t 1+ swap 1+ swap loop 2drop
262	;
263	: place-cstr-t ( adr len cstr-adr-t -- cstr-adr-t )
264	>r tuck r@ swap cmove-t ( len ) r@ + 0 swap c!-t r>
265	;
266	: "copy-t ( from to-t -- )
267	over c@ 2+ cmove-t
268	;
269	: toggle-t ( addr-t n -- ) swap >r r@ c@-t xor r> c!-t ;
270
271	: clear-threads-t ( hostaddr -- )
272	#threads-t /link-t * bounds do
273	origin-t i link-t!
274	/link +loop
275	;
276	: initmeta ( -- )
277	threads-t clear-threads-t threads-t current-t !
278	;
279
280	\ For compiling branch offsets used by control constructs.
281	\ These compile relative branches.
282
283	\t16-t /w-t constant /branch
284	\t32-t /l-t constant /branch
285	: branch! ( from target -- )
286	over - ( from offset ) swap
287	\t16-t w!-t
288	\t32-t l!-t
289	;
290	: branch, ( target -- )
291	here-t -
292	\t16-t w,-t
293	\t32-t l,-t
294	;
295
296	: thread-t! ( thread adr -- ) link-t! ;
297
298	only forth also meta also definitions
299	: install-target-assembler ( -- )
300	[ also assembler ]
301	['] /l-t is /asm
302	['] here-t is here
303	['] allot-t is asm-allot
304	['] l@-t is asm@
305	['] l!-t is asm!
306	[ previous ]
307	;
308	: install-host-assembler ( -- )
309	[ assembler ] resident-assembler [ meta ]
310	;