[OpenSPARC-T2-SAM] / obp / obp / os / sun / symdebug.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: symdebug.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: @(#)symdebug.fth 2.20 04/01/21 12:41:11
purpose: 
copyright: Copyright 1994-2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ Copyright 1985-1990 Bradley Forthware

\ Symbolic debugging extensions
\
\ initsyms  ( adr len -- )
\	Initializes the symbol table.  adr is the address of the header
\	of a memory image of an a.out file, and len is the length of the
\	file.
\
\ <symname>  ( -- value )
\	Typing the name of a symbol leaves its value on the stack
\
\ >sym	( value -- offset symnane )
\	symname is a packed string which is the name of the symbol whose
\	value is closest to, but not greater than, "value" .  Offset
\	is the positive difference between value and the symbol's value.
\
\ The disassembler is modified so that disassembled addresses are displayed
\ symbolically.
\
\ spread  ( -- distance )
\	A value which controls the symbolic display of disassembled
\	addresses.  If the distance from the address to the nearest smaller
\	symbol is less then the spread value , the address will be
\	displayed as "symname+offset"; otherwise just the address
\	will be displayed.  The initial value of spread is hex 1000 (4K).

\ needs a.out-header  ../sun/aout.fth
\ needs /sym  ../unix/nlist.fth

headerless
0 value fileaddr  \ Holds addr where file is copied, starting w/ text seg.

: syms@  ( -- symbol-table-addr )  fileaddr syms0 +  ;
: strings@  ( -- strings-addr )  fileaddr string0 +  ;

0 value strings
0 value /strings
0 value symbols
0 value /symbols
0 value symbol-offset  \ For use when the program is loaded at the wrong place

: >a.out-sym_strx  ( sym-entry -- cstr )  sym_strx l@  strings +  ;
: >a.out-sym_value ( sym-entry -- symbol-address )
   sym_value l@  symbol-offset -
;
: >a.out-sym_type  ( sym-etry --  valid-sym? )  sym_type c@  4 9 between  ;

defer >string    ' >a.out-sym_strx   is >string
defer >value     ' >a.out-sym_value  is >value
defer >sym_type  ' >a.out-sym_type   is >sym_type

0 value /symtab-entry  /aout-symbol to /symtab-entry


d# 80 constant /temp-symbuf
/temp-symbuf buffer: temp-symbuf
: $same?  ( c-string adr,len -- flag )
   temp-symbuf dup /temp-symbuf erase
   swap move temp-symbuf cscount
   1+  \ Compare 0 at end of str as well
    comp  0=
;
: all-syms  ( -- end-syms start-syms )  symbols /symbols  bounds  ;

: $sym>entry  ( adr,len -- sym-entry true | adr,len false )
   /symbols   if     ( adr,len )
      false  -rot    ( false adr,len )
      all-syms  do   ( false adr,len )
	 i >string   ( false adr,len c-string )
	 dup 2over   ( false adr,len next-c-string next-c-string adr,len )
	 $same?  if  ( false adr,len next-c-string )
	    2drop 2drop  true i dup  leave
	 else        ( false adr,len next-c-string )
	    drop     ( false adr,len )
	 then        ( false adr,len  |  true sym-entry sym-entry )
	 /symtab-entry
      +loop          ( false adr,len  |  true sym-entry sym-entry )
      rot dup  if  nip  then
   else              ( adr,len )
      false          ( adr,len false )
   then
;
: $sym>  ( adr,len -- sym-value true | adr,len false )
   $sym>entry  if  >value  true  else  false  then
;

0 value min-sym  \ Holds closest ( <= ) symbol to last .adr
0 value max-sym  \ Holds closest ( >  ) symbol to last .adr
0 value target  \ Holds address being symbolized
h# 1000 value spread   \ Maximum allowed displacement

: ubetween  ( val min max -- )  >r over u<=  swap r> u<=  and ;
: already-within?  ( -- flag )  \ Do previous saved values bracket target?
    max-sym  if
      target  min-sym >value   max-sym >value 1-  ubetween
    else false   \ Don't try it if uninitialized or at max memory
    then
;
: compute-limits  ( oldmin oldmax testsym -- min' max' )
    dup >value >r  -rot  ( testsym min max ) ( rs: testval )
    2dup r@ -rot  ubetween  ( testsym min max between? ) ( rs: testval )
    if r@ target u>   ( testsym min max new-max? )  ( rs: testval )
      if   drop  swap is max-sym  r>   ( min max' )
      else nip   swap is min-sym  r> swap  ( min' max )
      then
    else  rot r> 2drop
    then
;
: find-nearest  ( -- )   \ Min-sym points to final selection
    symbols is min-sym   0 is max-sym
    0  -1  \ Starting min, max values
    all-syms do   ( min max )
       \
       i >sym_type  if  i  compute-limits  then
    /symtab-entry +loop    ( min max )
    2drop
;

headerless0
0 value name-to-value  ( -- name-to-value-func )
0 value value-to-name  ( -- value-to-name-func )

: >sym  ( addr -- offset adr len )
    symbol-offset +  is target     ( )
    already-within?  0= if  find-nearest  then
    target  min-sym >value  -  ( offset )
    dup spread u<  if   \ Only print if offset isn't too big
      min-sym >string  cscount  ( offset adr len )
    else
      drop target 0 0
    then
;
: .offset ( offset -- )
   5  swap  ?dup  if                          ( len offset )
      ." +"  base @ >r  hex (u.)  r> base !   ( len adr,len )
      tuck type - 1-                          ( len' )
   then  1 max spaces
;

headers
\ User word to print nearest symbol for 'addr'
: .adr  ( addr -- )
   [ also disassembler ]
   dup origin  u>=  if  udis.  exit  then

   dup   /symbols if  >sym  else  0 0  then  ( addr offset adr len )
   dup  if                       ( addr offset adr len )
      \ Display  name[+offset]  if name is not null
      2swap >r  udis.  space  type  r> .offset  exit
   then  3drop                   ( addr )

   dup >r  do-value-to-sym  if   ( offset adr,len ) ( r: addr )
      r> udis.  space  type .offset  exit
   else                          ( addr ) ( r: addr )
      r>  drop                   ( addr )
   then                          ( addr )

   value-to-name  if	            ( addr )
      value-to-name  call32	    ( addr retval )
      dup l@ l->n -1 <>  if         ( addr retval )
	 swap udis. space	            ( retval )
	 dup l@ swap la1+ cscount   ( offset name,len )
	 type  .offset  exit        (  )
      then  drop                    ( addr )
   then	                            ( addr )

   \ No symbolic info available.  Display as number
   udis.
   [ previous ]
;

headerless
0 value prev-n2v
0 value prev-v2n
headers

: set-symbol-lookup  (  n2v v2n -- old-n2v  old-v2n )
   name-to-value value-to-name 2swap    ( old-n2v old-v2n  n2v v2n )
   is value-to-name is name-to-value    ( old-n2v old-v2n )
   0 to prev-n2v  0 to prev-v2n         ( old-n2v old-v2n )
;

overload: symbol-lookup-off ( -- )
   symbol-lookup-off
   name-to-value ?dup  if  to prev-n2v  then
   value-to-name ?dup  if  to prev-v2n  then
   0 to name-to-value  0 to value-to-name
;
overload: symbol-lookup-on ( -- )
   symbol-lookup-on
   prev-n2v ?dup  if  to name-to-value  then
   prev-v2n ?dup  if  to value-to-name  then
;

headerless
: $sym-handle-literal?  ( adr,len -- handled? )
   2dup 2>r ($handle-literal?)  if  ( r: adr,len )
      2r> 2drop true  exit
   then  2r>                        ( adr,len )

   $sym>  if  1  do-literal true  exit  then

   do-sym-to-value  if  1 do-literal  true  exit  then

   name-to-value  if                     ( adr,len )
      encode-string over here - allot    ( encoded$ )
      drop  name-to-value  call32  nip   ( retval )
      dup l@ l->n  if                    ( retval )
	 drop false                      ( true )
      else                               ( pstr retval )
	 la1+  l@  1 do-literal  true    ( true )
      then  exit                         ( flag )
   then  2drop false                     ( flag )
;
' $sym-handle-literal?  is $handle-literal?

: copysyms  ( dst-adr -- )
   is symbols
   symbols /symbols +  is  strings
   syms@     symbols  /symbols  move
   strings@  strings  /strings  move
;
headers
\ Another way to calculate "/strings":
\ : /strings  ( -- n )  /syms  if  strings@ @  else  0  then  ;

: (initsyms)  ( file-adr file-size -- )
   swap is fileaddr  ( file-size )
   /text - /data - /reloc - /syms -  is /strings  ( )
   syms@ is symbols  strings@ is strings  /syms is /symbols
   ['] $sym-handle-literal? is $handle-literal?
   /symbols /strings +  allocate-symtab  ( adr )  copysyms

\ XXX What we really need to do:
\   compact the symbol table by removing the boring names (e.g.
\   sccsid) and the boring symbols (e.g. constant names, file names)
\   At the same time, extract the corresponding names into a
\   different area of memory, changing the pointers to 16 bit
\   shifted pointers, and eliminating the type fields.
\   allocate some virtual memory in the monitor's region.
\   allocate physical memory, removing it from the piece list
\   copy the symbol table into that memory
;
: initsyms  ( file-adr file-size -- )
   over a.out-header  /a.out-header  move  ( file-adr file-size )
   ['] >a.out-sym_strx   is >string
   ['] >a.out-sym_value  is >value
   ['] >a.out-sym_type   is >sym_type
   /aout-symbol to /symtab-entry
   (initsyms)
;

\ Patch symbolic debugger into disassembler
also disassembler
' .adr  is showaddr	\ For disassembler
' .adr  is .subname	\ For ctrace
only forth also definitions
headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: symdebug.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: @(#)symdebug.fth 2.20 04/01/21 12:41:11
	43	purpose:
	44	copyright: Copyright 1994-2004 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ Copyright 1985-1990 Bradley Forthware
	48
	49	\ Symbolic debugging extensions
	50	\
	51	\ initsyms ( adr len -- )
	52	\ Initializes the symbol table. adr is the address of the header
	53	\ of a memory image of an a.out file, and len is the length of the
	54	\ file.
	55	\
	56	\ <symname> ( -- value )
	57	\ Typing the name of a symbol leaves its value on the stack
	58	\
	59	\ >sym ( value -- offset symnane )
	60	\ symname is a packed string which is the name of the symbol whose
	61	\ value is closest to, but not greater than, "value" . Offset
	62	\ is the positive difference between value and the symbol's value.
	63	\
	64	\ The disassembler is modified so that disassembled addresses are displayed
65	\ symbolically.
66	\
67	\ spread ( -- distance )
68	\ A value which controls the symbolic display of disassembled
69	\ addresses. If the distance from the address to the nearest smaller
70	\ symbol is less then the spread value , the address will be
71	\ displayed as "symname+offset"; otherwise just the address
72	\ will be displayed. The initial value of spread is hex 1000 (4K).
73
74	\ needs a.out-header ../sun/aout.fth
75	\ needs /sym ../unix/nlist.fth
76
77	headerless
78	0 value fileaddr \ Holds addr where file is copied, starting w/ text seg.
79
80	: syms@ ( -- symbol-table-addr ) fileaddr syms0 + ;
81	: strings@ ( -- strings-addr ) fileaddr string0 + ;
82
83	0 value strings
84	0 value /strings
85	0 value symbols
86	0 value /symbols
87	0 value symbol-offset \ For use when the program is loaded at the wrong place
88
89	: >a.out-sym_strx ( sym-entry -- cstr ) sym_strx l@ strings + ;
90	: >a.out-sym_value ( sym-entry -- symbol-address )
91	sym_value l@ symbol-offset -
92	;
93	: >a.out-sym_type ( sym-etry -- valid-sym? ) sym_type c@ 4 9 between ;
94
95	defer >string ' >a.out-sym_strx is >string
96	defer >value ' >a.out-sym_value is >value
97	defer >sym_type ' >a.out-sym_type is >sym_type
98
99	0 value /symtab-entry /aout-symbol to /symtab-entry
100
101
102	d# 80 constant /temp-symbuf
103	/temp-symbuf buffer: temp-symbuf
104	: $same? ( c-string adr,len -- flag )
105	temp-symbuf dup /temp-symbuf erase
106	swap move temp-symbuf cscount
107	1+ \ Compare 0 at end of str as well
108	comp 0=
109	;
110	: all-syms ( -- end-syms start-syms ) symbols /symbols bounds ;
111
112	: $sym>entry ( adr,len -- sym-entry true \| adr,len false )
113	/symbols if ( adr,len )
114	false -rot ( false adr,len )
115	all-syms do ( false adr,len )
116	i >string ( false adr,len c-string )
117	dup 2over ( false adr,len next-c-string next-c-string adr,len )
118	$same? if ( false adr,len next-c-string )
119	2drop 2drop true i dup leave
120	else ( false adr,len next-c-string )
121	drop ( false adr,len )
122	then ( false adr,len \| true sym-entry sym-entry )
123	/symtab-entry
124	+loop ( false adr,len \| true sym-entry sym-entry )
125	rot dup if nip then
126	else ( adr,len )
127	false ( adr,len false )
128	then
129	;
130	: $sym> ( adr,len -- sym-value true \| adr,len false )
131	$sym>entry if >value true else false then
132	;
133
134	0 value min-sym \ Holds closest ( <= ) symbol to last .adr
135	0 value max-sym \ Holds closest ( > ) symbol to last .adr
136	0 value target \ Holds address being symbolized
137	h# 1000 value spread \ Maximum allowed displacement
138
139	: ubetween ( val min max -- ) >r over u<= swap r> u<= and ;
140	: already-within? ( -- flag ) \ Do previous saved values bracket target?
141	max-sym if
142	target min-sym >value max-sym >value 1- ubetween
143	else false \ Don't try it if uninitialized or at max memory
144	then
145	;
146	: compute-limits ( oldmin oldmax testsym -- min' max' )
147	dup >value >r -rot ( testsym min max ) ( rs: testval )
148	2dup r@ -rot ubetween ( testsym min max between? ) ( rs: testval )
149	if r@ target u> ( testsym min max new-max? ) ( rs: testval )
150	if drop swap is max-sym r> ( min max' )
151	else nip swap is min-sym r> swap ( min' max )
152	then
153	else rot r> 2drop
154	then
155	;
156	: find-nearest ( -- ) \ Min-sym points to final selection
157	symbols is min-sym 0 is max-sym
158	0 -1 \ Starting min, max values
159	all-syms do ( min max )
160	\
161	i >sym_type if i compute-limits then
162	/symtab-entry +loop ( min max )
163	2drop
164	;
165
166	headerless0
167	0 value name-to-value ( -- name-to-value-func )
168	0 value value-to-name ( -- value-to-name-func )
169
170	: >sym ( addr -- offset adr len )
171	symbol-offset + is target ( )
172	already-within? 0= if find-nearest then
173	target min-sym >value - ( offset )
174	dup spread u< if \ Only print if offset isn't too big
175	min-sym >string cscount ( offset adr len )
176	else
177	drop target 0 0
178	then
179	;
180	: .offset ( offset -- )
181	5 swap ?dup if ( len offset )
182	." +" base @ >r hex (u.) r> base ! ( len adr,len )
183	tuck type - 1- ( len' )
184	then 1 max spaces
185	;
186
187	headers
188	\ User word to print nearest symbol for 'addr'
189	: .adr ( addr -- )
190	[ also disassembler ]
191	dup origin u>= if udis. exit then
192
193	dup /symbols if >sym else 0 0 then ( addr offset adr len )
194	dup if ( addr offset adr len )
195	\ Display name[+offset] if name is not null
196	2swap >r udis. space type r> .offset exit
197	then 3drop ( addr )
198
199	dup >r do-value-to-sym if ( offset adr,len ) ( r: addr )
200	r> udis. space type .offset exit
201	else ( addr ) ( r: addr )
202	r> drop ( addr )
203	then ( addr )
204
205	value-to-name if ( addr )
206	value-to-name call32 ( addr retval )
207	dup l@ l->n -1 <> if ( addr retval )
208	swap udis. space ( retval )
209	dup l@ swap la1+ cscount ( offset name,len )
210	type .offset exit ( )
211	then drop ( addr )
212	then ( addr )
213
214	\ No symbolic info available. Display as number
215	udis.
216	[ previous ]
217	;
218
219	headerless
220	0 value prev-n2v
221	0 value prev-v2n
222	headers
223
224	: set-symbol-lookup ( n2v v2n -- old-n2v old-v2n )
225	name-to-value value-to-name 2swap ( old-n2v old-v2n n2v v2n )
226	is value-to-name is name-to-value ( old-n2v old-v2n )
227	0 to prev-n2v 0 to prev-v2n ( old-n2v old-v2n )
228	;
229
230	overload: symbol-lookup-off ( -- )
231	symbol-lookup-off
232	name-to-value ?dup if to prev-n2v then
233	value-to-name ?dup if to prev-v2n then
234	0 to name-to-value 0 to value-to-name
235	;
236	overload: symbol-lookup-on ( -- )
237	symbol-lookup-on
238	prev-n2v ?dup if to name-to-value then
239	prev-v2n ?dup if to value-to-name then
240	;
241
242	headerless
243	: $sym-handle-literal? ( adr,len -- handled? )
244	2dup 2>r ($handle-literal?) if ( r: adr,len )
245	2r> 2drop true exit
246	then 2r> ( adr,len )
247
248	$sym> if 1 do-literal true exit then
249
250	do-sym-to-value if 1 do-literal true exit then
251
252	name-to-value if ( adr,len )
253	encode-string over here - allot ( encoded$ )
254	drop name-to-value call32 nip ( retval )
255	dup l@ l->n if ( retval )
256	drop false ( true )
257	else ( pstr retval )
258	la1+ l@ 1 do-literal true ( true )
259	then exit ( flag )
260	then 2drop false ( flag )
261	;
262	' $sym-handle-literal? is $handle-literal?
263
264	: copysyms ( dst-adr -- )
265	is symbols
266	symbols /symbols + is strings
267	syms@ symbols /symbols move
268	strings@ strings /strings move
269	;
270	headers
271	\ Another way to calculate "/strings":
272	\ : /strings ( -- n ) /syms if strings@ @ else 0 then ;
273
274	: (initsyms) ( file-adr file-size -- )
275	swap is fileaddr ( file-size )
276	/text - /data - /reloc - /syms - is /strings ( )
277	syms@ is symbols strings@ is strings /syms is /symbols
278	['] $sym-handle-literal? is $handle-literal?
279	/symbols /strings + allocate-symtab ( adr ) copysyms
280
281	\ XXX What we really need to do:
282	\ compact the symbol table by removing the boring names (e.g.
283	\ sccsid) and the boring symbols (e.g. constant names, file names)
284	\ At the same time, extract the corresponding names into a
285	\ different area of memory, changing the pointers to 16 bit
286	\ shifted pointers, and eliminating the type fields.
287	\ allocate some virtual memory in the monitor's region.
288	\ allocate physical memory, removing it from the piece list
289	\ copy the symbol table into that memory
290	;
291	: initsyms ( file-adr file-size -- )
292	over a.out-header /a.out-header move ( file-adr file-size )
293	['] >a.out-sym_strx is >string
294	['] >a.out-sym_value is >value
295	['] >a.out-sym_type is >sym_type
296	/aout-symbol to /symtab-entry
297	(initsyms)
298	;
299
300	\ Patch symbolic debugger into disassembler
301	also disassembler
302	' .adr is showaddr \ For disassembler
303	' .adr is .subname \ For ctrace
304	only forth also definitions
305	headers