[OpenSPARC-T2-SAM] / obp / obp / fm / lib / sparc / objsup.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: objsup.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 ============================================
\ objsup.fth 2.11 99/05/04
\ Copyright 1985-1990 Bradley Forthware

\ SPARC version.
\ Machine dependent support routines used for the objects package.
\ These words know intimate details about the Forth virtual machine
\ implementation.

\ Assembles the common code executed by actions.  That code
\ extracts the next token (which is the acf of the object) from the
\ code stream, and leaves the corresponding apf in scr

headerless

: start-code ( -- )  code-cf !csp  ;

\ Assembles the code which begins a ;code clause
\ For SPARC, the apf of the child word is left in scr
: start-;code  ( -- )  start-code  ;

\ Code for executing an object action.  Extracts the next token
\ (which is the apf of the object) from the code stream and pushes
\ it on the stack.  Then performs the action of "docolon".

\ The Forth token stream contains a pointer to the code:
\ doaction call    sp adec
: doaction  ( -- )  acf-align colon-cf  ;

\ Returns the address of the code executed by the word whose code field
\ address is acf
: >code-adr  ( acf -- code-adr )
\dtc   dup l@ 2 << l->n +    \ Converts relative call instruction to target address
\itc   token@
;

code >action-adr  ( object-acf action# -- )
  ( ... -- object-acf action# #actions true | object-apf action-adr false )
                          \ action# in tos
      sp 0     scr  nget  \ object-acf in scr
\dtc  scr 0    sc1  ld    \ Call instruction in sc1
\dtc  sc1 2    sc1  sll   \ Call relative offset in sc1
64\ \dtc sc1 0    sc1  sra   \ Sign extend
\dtc  scr sc1  sc1  add   \ code address in sc1
\itc  scr 0    sc1  rtget \ code offset in sc1
\itc  sc1 base sc1  add	  \ code address in sc1
      \ You might think that this should be "/n*" and "nget".
      \ Superficially, that is correct.  However, the location of the
      \ #actions field is not necessarily 64-bit aligned, so an
      \ ldx instruction could fail.  Since #actions isn't likely
      \ to be more than 2**32 :-), it suffices to read just 32 bits.
      sc1 -1 /l*  sc2   ld    \ #actions in sc2
      sc2         tos   cmp   \ Test action
      <= if		      \ "true" branch is error
         sp /n    sp    sub   \ Make room on stack (delay slot)
         sp /n    sp    sub   \ The error case needs more room on the stack
         tos      sp 1 /n*  nput  \ Place action# on stack
         sc2      sp 0 /n*  nput  \ Place #actions on stack
      else
         true     tos   move  \ Return true for error  (delay)

\dtc     scr 8       scr   add   \ Compute action-apf from action-acf
\itc     scr /token  scr   add   \ Compute action-apf from action-acf
         scr    sp 1 /n*   nput  \ Put action-apf on stack

\t16     tos 1       tos   sll   \ Convert #actions to token offset
\t32     tos 2       tos   sll   \ Convert #actions to token offset
         sc1 tos     sc1   sub   \ Skip back several tokens
         sc1 -1 /n*  sc1   rtget \ Get action-adr token
         sc1 base    sc1   add   \ Relocate
         sc1    sp 0 /n*   nput  \ Put action-adr on stack
         false       tos   move  \ Return false for no error
      then
c;

headers
: action-name  \ name  ( action# -- )
   create  		\ Store action number in data field
\t16   w,
\t32   l,
   ;code               ( -- object-pfa )
\t16  apf         scr  lduh	\ Action# in scr
\t32  apf         scr  ld	\ Action# in scr

      ip  0       sc1  rtget	\ Object acf in sc1
      ip  /token  ip   add	\ Advance to next token
      sc1 base    sc1  add	\ Relocate

      tos         sp   push
\dtc  sc1 8       tos  add	\ Compute and push object-apf
\itc  sc1 /token  tos  add	\ Compute and push object-apf

\dtc  sc1 0       sc2  ld	\ Call instruction in sc2
\dtc  sc2 2       sc2  sll	\ Call relative offset in sc2
64\ \dtc sc2 0       sc2  sra	\ Sign extend
\dtc  sc1 sc2     sc1  add	\ default action code address
\itc  sc1 0       sc1  rtget	\ relative version of ..
\itc  sc1 base    sc1  add	\ default action code address

\t16  scr 1       scr  sll      \ Convert action# to token offset
\t32  scr 2       scr  sll      \ Convert action# to token offset
      sc1 scr     sc1  sub      \ Skip back action# tokens
      sc1 -1 /n*  scr  rtget    \ Get action-adr token

\dtc  scr base    %g0  jmpl	\ Tail of "next"

\itc  scr base    sc1  add
\itc  sc1 0       scr  rtget    \ Tail of "next"
\itc  scr base    %g0  jmpl

      nop
end-code

: >action#  ( apf -- action# )
\t16  w@
\t32  l@
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: objsup.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	\ objsup.fth 2.11 99/05/04
	43	\ Copyright 1985-1990 Bradley Forthware
	44
	45	\ SPARC version.
	46	\ Machine dependent support routines used for the objects package.
	47	\ These words know intimate details about the Forth virtual machine
	48	\ implementation.
	49
	50	\ Assembles the common code executed by actions. That code
	51	\ extracts the next token (which is the acf of the object) from the
	52	\ code stream, and leaves the corresponding apf in scr
	53
	54	headerless
	55
	56	: start-code ( -- ) code-cf !csp ;
	57
	58	\ Assembles the code which begins a ;code clause
	59	\ For SPARC, the apf of the child word is left in scr
	60	: start-;code ( -- ) start-code ;
	61
	62	\ Code for executing an object action. Extracts the next token
	63	\ (which is the apf of the object) from the code stream and pushes
	64	\ it on the stack. Then performs the action of "docolon".
65
66	\ The Forth token stream contains a pointer to the code:
67	\ doaction call sp adec
68	: doaction ( -- ) acf-align colon-cf ;
69
70	\ Returns the address of the code executed by the word whose code field
71	\ address is acf
72	: >code-adr ( acf -- code-adr )
73	\dtc dup l@ 2 << l->n + \ Converts relative call instruction to target address
74	\itc token@
75	;
76
77	code >action-adr ( object-acf action# -- )
78	( ... -- object-acf action# #actions true \| object-apf action-adr false )
79	\ action# in tos
80	sp 0 scr nget \ object-acf in scr
81	\dtc scr 0 sc1 ld \ Call instruction in sc1
82	\dtc sc1 2 sc1 sll \ Call relative offset in sc1
83	64\ \dtc sc1 0 sc1 sra \ Sign extend
84	\dtc scr sc1 sc1 add \ code address in sc1
85	\itc scr 0 sc1 rtget \ code offset in sc1
86	\itc sc1 base sc1 add \ code address in sc1
87	\ You might think that this should be "/n*" and "nget".
88	\ Superficially, that is correct. However, the location of the
89	\ #actions field is not necessarily 64-bit aligned, so an
90	\ ldx instruction could fail. Since #actions isn't likely
91	\ to be more than 2**32 :-), it suffices to read just 32 bits.
92	sc1 -1 /l* sc2 ld \ #actions in sc2
93	sc2 tos cmp \ Test action
94	<= if \ "true" branch is error
95	sp /n sp sub \ Make room on stack (delay slot)
96	sp /n sp sub \ The error case needs more room on the stack
97	tos sp 1 /n* nput \ Place action# on stack
98	sc2 sp 0 /n* nput \ Place #actions on stack
99	else
100	true tos move \ Return true for error (delay)
101
102	\dtc scr 8 scr add \ Compute action-apf from action-acf
103	\itc scr /token scr add \ Compute action-apf from action-acf
104	scr sp 1 /n* nput \ Put action-apf on stack
105
106	\t16 tos 1 tos sll \ Convert #actions to token offset
107	\t32 tos 2 tos sll \ Convert #actions to token offset
108	sc1 tos sc1 sub \ Skip back several tokens
109	sc1 -1 /n* sc1 rtget \ Get action-adr token
110	sc1 base sc1 add \ Relocate
111	sc1 sp 0 /n* nput \ Put action-adr on stack
112	false tos move \ Return false for no error
113	then
114	c;
115
116	headers
117	: action-name \ name ( action# -- )
118	create \ Store action number in data field
119	\t16 w,
120	\t32 l,
121	;code ( -- object-pfa )
122	\t16 apf scr lduh \ Action# in scr
123	\t32 apf scr ld \ Action# in scr
124
125	ip 0 sc1 rtget \ Object acf in sc1
126	ip /token ip add \ Advance to next token
127	sc1 base sc1 add \ Relocate
128
129	tos sp push
130	\dtc sc1 8 tos add \ Compute and push object-apf
131	\itc sc1 /token tos add \ Compute and push object-apf
132
133	\dtc sc1 0 sc2 ld \ Call instruction in sc2
134	\dtc sc2 2 sc2 sll \ Call relative offset in sc2
135	64\ \dtc sc2 0 sc2 sra \ Sign extend
136	\dtc sc1 sc2 sc1 add \ default action code address
137	\itc sc1 0 sc1 rtget \ relative version of ..
138	\itc sc1 base sc1 add \ default action code address
139
140	\t16 scr 1 scr sll \ Convert action# to token offset
141	\t32 scr 2 scr sll \ Convert action# to token offset
142	sc1 scr sc1 sub \ Skip back action# tokens
143	sc1 -1 /n* scr rtget \ Get action-adr token
144
145	\dtc scr base %g0 jmpl \ Tail of "next"
146
147	\itc scr base sc1 add
148	\itc sc1 0 scr rtget \ Tail of "next"
149	\itc scr base %g0 jmpl
150
151	nop
152	end-code
153
154	: >action# ( apf -- action# )
155	\t16 w@
156	\t32 l@
157	;