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

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: patch.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 ============================================
\ patch.fth 2.11 01/04/06
\ Copyright 1985-1994 Bradley Forthware
\ copyright: Copyright 1995-2001 Sun Microsystems, Inc.  All Rights Reserved

\  Patch utility.  Allows you to make patches to already-defined words.
\   Usage:
\     PATCH new old word-to-patch
\         In the definition of "word-to-patch", replaces the first
\         occurence of "old" with "new".  "new" may be either a word
\         or a number.  "old" may be either a word or a number.
\
\     n-new  n-old  NPATCH  word-to-patch
\         In the definition of "word-to-patch", replaces the first
\         compiled instance of the number "n-old" with the number
\         "n-new".
\
\     n-new  n-old  start-adr  end-adr  (NPATCH
\         replaces the first occurrence of "n-old" in the word "acf"
\         with "n-new"
\
\     acf-new  acf-old  acf  (PATCH
\         replaces the first occurrence of "acf-old" in the word "acf"
\         with "acf-new"
\
\     new new-type   old old-type  acf  (PATCH)
\         replaces the first occurrence of "old" in the word "acf" with "new".
\         If "new-type" is true, "new" is a number, otherwise "new" is an acf.
\         If "old-type" is true, "old" is a number, otherwise "old" is an acf.
\
\     n  start-adr end-adr   SEARCH
\         searches for an occurrence of "n" between start-adr and
\         end-adr.  Leaves the adress where found and a success flag.
\
\     c  start-adr end-adr   CSEARCH
\         searches for a byte between start-adr and end-adr
\
\     w  start-adr end-adr   WSEARCH
\         searches for a 16-bit word between start-adr and end-adr
\
\     acf  start-adr end-adr TSEARCH
\         searches for a compiled adress between start-adr and end-adr
\
\

decimal

: csearch ( c start end -- loc true | false )
   false -rot swap  ?do			( c false )
      over i c@ = if
	 drop i swap true leave
      then
   /c +loop  nip
;
: wsearch  ( w start end -- loc true | false )
   rot n->w		\ strip off any high bits
   false 2swap  swap  ?do		( w false )
      over i w@ = if
	 drop i swap true leave
      then
   /w +loop  nip
;
: tsearch  ( adr start end -- loc true | false )
   false -rot  swap  ?do			( targ false )
      over i token@ = if
	 drop i swap true leave
      then
      \ Can't use /token because tokens could be 32-bits, aligned on 16-bit
      \ boundaries, with 16-bit branch offsets realigning the token list.
   #talign +loop  nip
;
: search  ( n start end -- loc true | false )
   false -rot  swap  ?do		( n false )
      over i @ = if
	 drop i swap true leave
      then
   #talign +loop  nip
;

headerless

: get-next-token  ( adr -- adr token )
   dup token@                 ( n adr token )
   dup ['] unnest =  abort" Can't find word to replace"   ( n adr token )
;

: find-lit  ( n acf -- adr )
   >body
   begin
      get-next-token             ( n adr token )
\t16  dup  ['] (wlit)  =  if     ( n adr token )
\t16     drop                    ( n adr )
\t16     2dup ta1+ w@ 1-  =  if  ( n adr )
\t16        nip exit             ( adr )
\t16     else                    ( n adr )
\t16        ta1+ wa1+            ( n adr' )
\t16     then                    ( n adr )
\t16  else                       ( n adr token )
       dup  ['] (lit) =  if      ( n adr token )
	  drop                   ( n adr )
	  2dup ta1+ @  =  if     ( n adr )
	     nip exit            ( adr )
	  else                   ( n adr )
	     ta1+ na1+           ( n adr' )
	  then                   ( n adr )
       else                      ( n adr token )
	  ['] (llit) =  if       ( n adr )
	     2dup ta1+ l@ 1-  =  if  ( n adr )
		nip exit             ( adr )
	     else                    ( n adr )
		ta1+ la1+            ( n adr' )
	     then                    ( n adr' )
	  else                       ( n adr )
	     ta1+                    ( n adr' )
	  then                       ( n adr' )
       then                          ( n adr' )
\t16 then
   again
;

: find-token  ( n acf -- adr )
   >body
   begin
      get-next-token                ( n adr token )
      2 pick =  if  nip exit  then  ( n adr )
      ta1+                          ( n adr' )
   again
;

: make-name  ( n digit -- adr len )
   >r  <# u#s ascii # hold  r> hold u#>   ( adr len )
;

: put-constant  ( n adr -- )
   over
   base @  d# 16 =  if
      ascii h make-name
   else
      push-decimal
      ascii d make-name
      pop-base
   then                           ( n adr name-adr name-len )

   \ We don't use  "create .. does> @  because we want this word
   \ to decompile as 'constant'

   warning @ >r  warning off
   $header       ( n adr )
   constant-cf swap ,             ( adr )
   r> warning !

   lastacf swap token!
;

: put-noop  ( adr -- )  ta1+  ['] noop swap token!  ;

\t16 : short-number?  ( n -- flag )  -1  h# fffe  between  ;
\t32 : long-number?  ( n -- flag )  -1  h# ffff.fffe n->l between  ;

headers
: (patch)  ( new number?  old number?  word -- )
   swap  if                         ( new number? old acf )  \ Dest. is num
      find-lit                      ( new number? adr )

\t16  dup token@ ['] (wlit) =  if   ( new number? old )  \ Dest. slot is wlit
\t16     swap  if                   ( new adr )   \ replacement is a number
\t16        over short-number?  if  ( new adr )   \ replacement is short num
\t16           ta1+ swap 1+ swap w! ( )
\t16           exit
\t16        then                    ( new adr )   \ Replacement is long num
\t16        tuck put-constant       ( adr )
\t16        put-noop                ( )
\t16        exit
\t16     then                       ( new adr )  \ replacement is a word
\t16     tuck token!  put-noop      ( )
\t16     exit
\t16  then                          ( new number? adr )  \ Dest. slot is lit

\t32  dup token@ ['] (llit) =  if   ( new number? old )  \ Dest. slot is wlit
\t32     swap  if                   ( new adr )   \ replacement is a number
\t32        over long-number?  if   ( new adr )   \ replacement is short num
64\ \t32       ta1+ swap 1+ swap l! ( )
32\ \t32       ta1+ l!              ( )
\t32           exit
\t32        then                    ( new adr )   \ Replacement is long num
\t32        tuck put-constant       ( adr )
\t32        put-noop                ( )
\t32        exit
\t32     then                       ( new adr )  \ replacement is a word
\t32     tuck token!  put-noop      ( )
\t32     exit
\t32  then                          ( new number? adr )  \ Dest. slot is lit

      swap  if  ta1+ !  exit  then  ( new adr )  \ replacement is a word

      tuck token!                   ( adr )
32\ \t16  dup put-noop  ta1+               ( )
64\ \t16  dup put-noop  ta1+ dup put-noop  dup put-noop  ta1+  ( )
64\ \t32  dup put-noop  ta1+
      put-noop                             ( )
      exit
   then                             ( new number? old acf )  \ Dest. is token

   find-token                       ( new number? adr )
   swap if  put-constant exit  then ( new adr )  \ replacement is a number
   token!
;

headerless
: get-word-type  \ word  ( -- val number? )
   parse-word  $find  if  false exit  then  ( adr len )
   $dnumber?  1 <> abort" ?"  true
;

headers
: (npatch  ( newn oldn acf -- )  >r true tuck  r>  (patch)  ;

: (patch  ( new-acf old-acf acf -- )  >r false tuck r>  (patch)  ;

\ substitute new for first occurrence of old in word "name"
: npatch  \ name  ( new old -- )
   true tuck  '  ( new true old true acf )  (patch)
;

: patch  \ new old word  ( -- )
   get-word-type   get-word-type  '  (patch)
;
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: patch.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	\ patch.fth 2.11 01/04/06
	43	\ Copyright 1985-1994 Bradley Forthware
	44	\ copyright: Copyright 1995-2001 Sun Microsystems, Inc. All Rights Reserved
	45
	46	\ Patch utility. Allows you to make patches to already-defined words.
	47	\ Usage:
	48	\ PATCH new old word-to-patch
	49	\ In the definition of "word-to-patch", replaces the first
	50	\ occurence of "old" with "new". "new" may be either a word
	51	\ or a number. "old" may be either a word or a number.
	52	\
	53	\ n-new n-old NPATCH word-to-patch
	54	\ In the definition of "word-to-patch", replaces the first
	55	\ compiled instance of the number "n-old" with the number
	56	\ "n-new".
	57	\
	58	\ n-new n-old start-adr end-adr (NPATCH
	59	\ replaces the first occurrence of "n-old" in the word "acf"
	60	\ with "n-new"
	61	\
	62	\ acf-new acf-old acf (PATCH
	63	\ replaces the first occurrence of "acf-old" in the word "acf"
	64	\ with "acf-new"
65	\
66	\ new new-type old old-type acf (PATCH)
67	\ replaces the first occurrence of "old" in the word "acf" with "new".
68	\ If "new-type" is true, "new" is a number, otherwise "new" is an acf.
69	\ If "old-type" is true, "old" is a number, otherwise "old" is an acf.
70	\
71	\ n start-adr end-adr SEARCH
72	\ searches for an occurrence of "n" between start-adr and
73	\ end-adr. Leaves the adress where found and a success flag.
74	\
75	\ c start-adr end-adr CSEARCH
76	\ searches for a byte between start-adr and end-adr
77	\
78	\ w start-adr end-adr WSEARCH
79	\ searches for a 16-bit word between start-adr and end-adr
80	\
81	\ acf start-adr end-adr TSEARCH
82	\ searches for a compiled adress between start-adr and end-adr
83	\
84	\
85
86	decimal
87
88	: csearch ( c start end -- loc true \| false )
89	false -rot swap ?do ( c false )
90	over i c@ = if
91	drop i swap true leave
92	then
93	/c +loop nip
94	;
95	: wsearch ( w start end -- loc true \| false )
96	rot n->w \ strip off any high bits
97	false 2swap swap ?do ( w false )
98	over i w@ = if
99	drop i swap true leave
100	then
101	/w +loop nip
102	;
103	: tsearch ( adr start end -- loc true \| false )
104	false -rot swap ?do ( targ false )
105	over i token@ = if
106	drop i swap true leave
107	then
108	\ Can't use /token because tokens could be 32-bits, aligned on 16-bit
109	\ boundaries, with 16-bit branch offsets realigning the token list.
110	#talign +loop nip
111	;
112	: search ( n start end -- loc true \| false )
113	false -rot swap ?do ( n false )
114	over i @ = if
115	drop i swap true leave
116	then
117	#talign +loop nip
118	;
119
120	headerless
121
122	: get-next-token ( adr -- adr token )
123	dup token@ ( n adr token )
124	dup ['] unnest = abort" Can't find word to replace" ( n adr token )
125	;
126
127	: find-lit ( n acf -- adr )
128	>body
129	begin
130	get-next-token ( n adr token )
131	\t16 dup ['] (wlit) = if ( n adr token )
132	\t16 drop ( n adr )
133	\t16 2dup ta1+ w@ 1- = if ( n adr )
134	\t16 nip exit ( adr )
135	\t16 else ( n adr )
136	\t16 ta1+ wa1+ ( n adr' )
137	\t16 then ( n adr )
138	\t16 else ( n adr token )
139	dup ['] (lit) = if ( n adr token )
140	drop ( n adr )
141	2dup ta1+ @ = if ( n adr )
142	nip exit ( adr )
143	else ( n adr )
144	ta1+ na1+ ( n adr' )
145	then ( n adr )
146	else ( n adr token )
147	['] (llit) = if ( n adr )
148	2dup ta1+ l@ 1- = if ( n adr )
149	nip exit ( adr )
150	else ( n adr )
151	ta1+ la1+ ( n adr' )
152	then ( n adr' )
153	else ( n adr )
154	ta1+ ( n adr' )
155	then ( n adr' )
156	then ( n adr' )
157	\t16 then
158	again
159	;
160
161	: find-token ( n acf -- adr )
162	>body
163	begin
164	get-next-token ( n adr token )
165	2 pick = if nip exit then ( n adr )
166	ta1+ ( n adr' )
167	again
168	;
169
170	: make-name ( n digit -- adr len )
171	>r <# u#s ascii # hold r> hold u#> ( adr len )
172	;
173
174	: put-constant ( n adr -- )
175	over
176	base @ d# 16 = if
177	ascii h make-name
178	else
179	push-decimal
180	ascii d make-name
181	pop-base
182	then ( n adr name-adr name-len )
183
184	\ We don't use "create .. does> @ because we want this word
185	\ to decompile as 'constant'
186
187	warning @ >r warning off
188	$header ( n adr )
189	constant-cf swap , ( adr )
190	r> warning !
191
192	lastacf swap token!
193	;
194
195	: put-noop ( adr -- ) ta1+ ['] noop swap token! ;
196
197	\t16 : short-number? ( n -- flag ) -1 h# fffe between ;
198	\t32 : long-number? ( n -- flag ) -1 h# ffff.fffe n->l between ;
199
200	headers
201	: (patch) ( new number? old number? word -- )
202	swap if ( new number? old acf ) \ Dest. is num
203	find-lit ( new number? adr )
204
205	\t16 dup token@ ['] (wlit) = if ( new number? old ) \ Dest. slot is wlit
206	\t16 swap if ( new adr ) \ replacement is a number
207	\t16 over short-number? if ( new adr ) \ replacement is short num
208	\t16 ta1+ swap 1+ swap w! ( )
209	\t16 exit
210	\t16 then ( new adr ) \ Replacement is long num
211	\t16 tuck put-constant ( adr )
212	\t16 put-noop ( )
213	\t16 exit
214	\t16 then ( new adr ) \ replacement is a word
215	\t16 tuck token! put-noop ( )
216	\t16 exit
217	\t16 then ( new number? adr ) \ Dest. slot is lit
218
219	\t32 dup token@ ['] (llit) = if ( new number? old ) \ Dest. slot is wlit
220	\t32 swap if ( new adr ) \ replacement is a number
221	\t32 over long-number? if ( new adr ) \ replacement is short num
222	64\ \t32 ta1+ swap 1+ swap l! ( )
223	32\ \t32 ta1+ l! ( )
224	\t32 exit
225	\t32 then ( new adr ) \ Replacement is long num
226	\t32 tuck put-constant ( adr )
227	\t32 put-noop ( )
228	\t32 exit
229	\t32 then ( new adr ) \ replacement is a word
230	\t32 tuck token! put-noop ( )
231	\t32 exit
232	\t32 then ( new number? adr ) \ Dest. slot is lit
233
234	swap if ta1+ ! exit then ( new adr ) \ replacement is a word
235
236	tuck token! ( adr )
237	32\ \t16 dup put-noop ta1+ ( )
238	64\ \t16 dup put-noop ta1+ dup put-noop dup put-noop ta1+ ( )
239	64\ \t32 dup put-noop ta1+
240	put-noop ( )
241	exit
242	then ( new number? old acf ) \ Dest. is token
243
244	find-token ( new number? adr )
245	swap if put-constant exit then ( new adr ) \ replacement is a number
246	token!
247	;
248
249	headerless
250	: get-word-type \ word ( -- val number? )
251	parse-word $find if false exit then ( adr len )
252	$dnumber? 1 <> abort" ?" true
253	;
254
255	headers
256	: (npatch ( newn oldn acf -- ) >r true tuck r> (patch) ;
257
258	: (patch ( new-acf old-acf acf -- ) >r false tuck r> (patch) ;
259
260	\ substitute new for first occurrence of old in word "name"
261	: npatch \ name ( new old -- )
262	true tuck ' ( new true old true acf ) (patch)
263	;
264
265	: patch \ new old word ( -- )
266	get-word-type get-word-type ' (patch)
267	;
268