PageRenderTime 55ms CodeModel.GetById 2ms app.highlight 47ms RepoModel.GetById 1ms app.codeStats 1ms

/qemu/roms/SLOF/slof/fs/debug.fs

https://github.com/javarange/dpdk-ovs
F# | 422 lines | 366 code | 56 blank | 0 comment | 8 complexity | 8634a4842a22f9364ef01d14a9a69bcc MD5 | raw file
  1\ *****************************************************************************
  2\ * Copyright (c) 2004, 2008 IBM Corporation
  3\ * All rights reserved.
  4\ * This program and the accompanying materials
  5\ * are made available under the terms of the BSD License
  6\ * which accompanies this distribution, and is available at
  7\ * http://www.opensource.org/licenses/bsd-license.php
  8\ *
  9\ * Contributors:
 10\ *     IBM Corporation - initial implementation
 11\ ****************************************************************************/
 12
 13
 14\ Get the name of Forth command whose execution token is xt
 15
 16: xt>name ( xt -- str len )
 17    BEGIN
 18	cell - dup c@ 0 2 within IF
 19	    dup 2+ swap 1+ c@ exit
 20	THEN
 21    AGAIN
 22;
 23
 24cell -1 * CONSTANT -cell
 25: cell- ( n -- n-cell-size )
 26   [ cell -1 * ] LITERAL +
 27;
 28
 29\ Search for xt of given address
 30: find-xt-addr ( addr -- xt )
 31   BEGIN
 32      dup @ <colon> = IF
 33	 EXIT
 34      THEN
 35      cell-
 36   AGAIN
 37;
 38
 39: (.immediate) ( xt -- )
 40   \ is it immediate?
 41   xt>name drop 2 - c@ \ skip len and flags
 42   immediate? IF
 43     ."  IMMEDIATE"
 44   THEN
 45;
 46
 47: (.xt) ( xt -- )
 48   xt>name type
 49;
 50
 51\ Trace back on current return stack.
 52\ Start at 1, since 0 is return of trace-back itself
 53
 54: trace-back (  )
 55   1
 56   BEGIN
 57      cr dup dup . ."  : " rpick dup . ."  : "
 58      ['] tib here within IF
 59	  dup rpick find-xt-addr (.xt)
 60      THEN
 61      1+ dup rdepth 5 - >= IF cr drop EXIT THEN
 62   AGAIN
 63;
 64
 65VARIABLE see-my-type-column
 66
 67: (see-my-type) ( indent limit xt str len -- indent limit xt )
 68   dup see-my-type-column @ + dup 50 >= IF
 69      -rot over "  " comp 0= IF
 70         \ blank causes overflow: just enforce new line with next call
 71         2drop see-my-type-column !
 72      ELSE
 73         rot drop                     ( indent limit xt str len )
 74         \ Need to copy string since we use (u.) again (kills internal buffer):
 75         pocket swap 2dup >r >r       ( indent limit xt str pk len  R: len pk )
 76         move r> r>                   ( indent limit xt pk len )
 77         2 pick (u.) dup -rot
 78         cr type                      ( indent limit xt pk len xt-len )
 79         " :" type 1+                 ( indent limit xt pk len prefix-len )
 80         5 pick dup spaces +          ( indent limit xt pk len prefix-len )
 81         over + see-my-type-column !  ( indent limit xt pk len )
 82         type
 83      THEN                            ( indent limit xt )
 84   ELSE
 85      see-my-type-column ! type       ( indent limit xt )
 86   THEN
 87;
 88
 89: (see-my-type-init) ( -- )
 90   ffff see-my-type-column !        \ just enforce a new line
 91;
 92
 93: (see-colon-body) ( indent limit xt -- indent limit xt )
 94   (see-my-type-init)                              \ enforce new line
 95   BEGIN                                           ( indent limit xt )
 96      cell+ 2dup <>
 97      over @
 98      dup <semicolon> <>
 99      rot and			                   ( indent limit xt @xt flag )
100   WHILE                                           ( indent limit xt @xt )
101      xt>name (see-my-type) "  " (see-my-type)
102      dup @                                        ( indent limit xt @xt)
103      CASE
104	 <0branch>  OF cell+ dup @
105                    over + cell+ dup >r
106                    (u.) (see-my-type) r>          ( indent limit xt target)
107                    2dup < IF
108                       over 4 pick 3 + -rot recurse
109                       nip nip nip cell-           ( indent limit xt )
110                    ELSE
111                       drop                        ( indent limit xt )
112                    THEN
113                    (see-my-type-init) ENDOF       \ enforce new line
114	 <branch>   OF cell+ dup @ over + cell+ (u.)
115                    (see-my-type) "  " (see-my-type) ENDOF
116	 <do?do>    OF cell+ dup @ (u.) (see-my-type)
117                    "  " (see-my-type) ENDOF
118	 <lit>      OF cell+ dup @ (u.) (see-my-type)
119                    "  " (see-my-type) ENDOF
120	 <dotick>   OF cell+ dup @ xt>name (see-my-type)
121                    "  " (see-my-type) ENDOF
122	 <doloop>   OF cell+ dup @ (u.) (see-my-type)
123                    "  " (see-my-type) ENDOF
124	 <do+loop>  OF cell+ dup @ (u.) (see-my-type)
125                    "  " (see-my-type) ENDOF
126	 <doleave>  OF cell+ dup @ over + cell+ (u.)
127                    (see-my-type) "  " (see-my-type) ENDOF
128	 <do?leave> OF cell+ dup @ over + cell+ (u.)
129                    (see-my-type) "  " (see-my-type) ENDOF
130	 <sliteral> OF cell+ " """ (see-my-type) dup count dup >r
131                    (see-my-type) " """ (see-my-type)
132                    "  " (see-my-type)
133                    r> -cell and + ENDOF
134      ENDCASE
135   REPEAT
136   drop
137;
138
139: (see-colon) ( xt -- )
140   (see-my-type-init)
141   1 swap 0 swap                                    ( indent limit xt )
142   " : " (see-my-type) dup xt>name (see-my-type)
143   rot drop 4 -rot (see-colon-body)                 ( indent limit xt )
144   rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
145   3drop 
146;
147
148\ Create words are a bit tricky. We find out where their code points.
149\ If this code is part of SLOF, it is not a user generated CREATE.
150
151: (see-create) ( xt -- )
152   dup cell+ @
153   CASE
154      <2constant> OF
155         dup cell+ cell+ dup @ swap cell+ @ . .  ." 2CONSTANT "
156      ENDOF
157
158      <instancevalue> OF
159         dup cell+ cell+ @ . ." INSTANCE VALUE "
160      ENDOF
161
162      <instancevariable> OF
163         ." INSTANCE VARIABLE "
164      ENDOF
165
166      dup OF
167         ." CREATE "
168      ENDOF
169   ENDCASE
170   (.xt)
171;
172
173\ Decompile Forth command whose execution token is xt
174
175: (see) ( xt -- )
176   cr dup dup @
177   CASE
178      <variable> OF ." VARIABLE " (.xt) ENDOF
179      <value>    OF dup execute . ." VALUE " (.xt) ENDOF
180      <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
181      <defer>    OF dup cell+ @ swap ." DEFER " (.xt) ."  is " (.xt) ENDOF
182      <alias>    OF dup cell+ @ swap ." ALIAS " (.xt) ."  " (.xt) ENDOF
183      <buffer:>  OF ." BUFFER: " (.xt) ENDOF
184      <create>   OF (see-create) ENDOF
185      <colon>    OF (see-colon)  ENDOF
186      dup        OF ." ??? PRIM " (.xt) ENDOF
187   ENDCASE
188   (.immediate) cr
189  ;
190
191\ Decompile Forth command old-name
192
193: see ( "old-name<>" -- )
194   ' (see)
195;
196
197\ Work in progress...
198
1990    value forth-ip
200true value trace>stepping?
201true value trace>print?
202true value trace>up?
2030    value trace>depth
2040    value trace>rdepth
2050    value trace>recurse
206: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
207: trace-depth- ( -- ) trace>depth 1- to trace>depth ;
208
209: stepping ( -- )
210    true to trace>stepping?
211;
212
213: tracing ( -- )
214    false to trace>stepping?
215;
216
217: trace-print-on ( -- )
218    true to trace>print?
219;
220
221: trace-print-off ( -- )
222    false to trace>print?
223;
224
225
226\ Add n to ip
227
228: fip-add ( n -- )
229   forth-ip + to forth-ip
230;
231
232\ Save execution token address and content
233
2340 value debug-last-xt
2350 value debug-last-xt-content
236
237: trace-print ( -- )
238   forth-ip cr u. ." : "
239   forth-ip @ 
240   dup ['] breakpoint = IF drop debug-last-xt-content THEN
241   xt>name type ."  "
242   ."     ( " .s  ."  )  | "
243;
244
245: trace-interpret ( -- )
246   rdepth 1- to trace>rdepth
247   BEGIN
248      depth . [char] > dup emit emit space
249      source expect                        ( str len )
250      ['] interpret catch print-status
251   AGAIN
252;
253
254\ Main trace routine, trace a colon definition
255
256: trace-xt ( xt -- )
257    trace>recurse IF
258       r> drop                                \ Drop return of 'trace-xt call
259       cell+                                  \ Step over ":"
260    ELSE
261       debug-last-xt-content <colon> = IF
262          \ debug colon-definition
263          ['] breakpoint @ debug-last-xt !    \ Re-arm break point
264          r> drop                             \ Drop return of 'trace-xt call
265          cell+                               \ Step over ":"
266       ELSE
267          ['] breakpoint debug-last-xt !      \ Re-arm break point
268          2r> 2drop
269       THEN
270    THEN
271
272    to forth-ip
273    true to trace>print?
274    BEGIN
275       trace>print? IF trace-print THEN
276
277       forth-ip                                              ( ip )
278       trace>stepping? IF
279	  BEGIN
280             key
281             CASE
282		[char] d OF dup @ @ <colon> = IF             \ recurse only into colon definitions
283			                         trace-depth+
284                                                 1 to trace>recurse
285                                                 dup >r @ recurse
286		                              THEN true ENDOF
287	        [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
288	        [char] f OF drop cr trace-interpret ENDOF	\ quit trace and start interpreter FIXME rstack
289	        [char] c OF tracing true ENDOF
290		[char] t OF trace-back false ENDOF
291		[char] q OF drop cr quit ENDOF
292	        20       OF true ENDOF
293		dup      OF cr ." Press d:       Down into current word" cr
294		            ." Press u:       Up to caller" cr
295		            ." Press f:       Switch to forth interpreter, 'resume' will continue tracing" cr
296                            ." Press c:       Switch to tracing" cr
297		            ." Press <space>: Execute current word" cr
298		            ." Press q:       Abort execution, switch to interpreter" cr
299		            false ENDOF
300	     ENDCASE
301	  UNTIL
302       THEN	                                              ( ip' )
303       dup to forth-ip @                                      ( xt )
304       dup ['] breakpoint = IF drop debug-last-xt-content THEN
305       dup                                                    ( xt xt )
306
307       CASE
308	    <sliteral>  OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
309	    <dotick>    OF drop forth-ip cell+ @ cell fip-add ENDOF
310	    <lit>       OF drop forth-ip cell+ @ cell fip-add ENDOF
311	    <doto>      OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
312	    <(doito)>   OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
313	    <0branch>   OF drop IF
314		                    cell fip-add
315		                ELSE
316				    forth-ip cell+ @ cell+ fip-add THEN
317			ENDOF
318            <do?do>     OF drop 2dup <> IF
319				           swap >r >r cell fip-add
320		                        ELSE
321					   forth-ip cell+ @ cell+ fip-add 2drop THEN
322		        ENDOF
323	    <branch>    OF drop forth-ip cell+ @ cell+ fip-add ENDOF
324	    <doleave>   OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF		
325	    <do?leave>  OF drop IF
326		                   r> r> 2drop forth-ip cell+ @ cell+ fip-add
327		                ELSE
328		                   cell fip-add
329		                THEN
330		        ENDOF		
331	    <doloop>    OF drop r> 1+ r> 2dup = IF
332		                                   2drop cell fip-add
333		                                ELSE >r >r
334						    forth-ip cell+ @ cell+ fip-add THEN
335			ENDOF
336	    <do+loop>   OF drop r> + r> 2dup >= IF
337		                                   2drop cell fip-add
338		                                ELSE >r >r
339						    forth-ip cell+ @ cell+ fip-add THEN
340			ENDOF
341
342	    <semicolon> OF trace>depth 0> IF
343		                             trace-depth- 1 to trace>recurse
344                                             stepping drop r> recurse
345		                          ELSE
346		                             drop exit THEN
347			ENDOF
348            <exit>      OF trace>depth 0> IF
349		                             trace-depth- stepping drop r> recurse
350		                          ELSE
351				             drop exit THEN
352			ENDOF
353	    dup         OF execute ENDOF
354	ENDCASE
355	forth-ip cell+ to forth-ip
356    AGAIN
357;
358
359\ Resume execution from tracer
360: resume ( -- )
361    trace>rdepth rdepth!
362    forth-ip cell - trace-xt
363;
364
365\ Turn debug off, by erasing breakpoint
366
367: debug-off ( -- )
368    debug-last-xt IF
369	debug-last-xt-content debug-last-xt !  \ Restore overwriten token
370	0 to debug-last-xt
371    THEN
372;
373
374
375
376\ Entry point for debug
377
378: (break-entry) ( -- )
379   debug-last-xt dup @ ['] breakpoint <> swap  ( debug-addr? debug-last-xt )
380   debug-last-xt-content swap !                \ Restore overwriten token
381   r> drop                                     \ Don't return to bp, but to caller
382   debug-last-xt-content <colon> <> and IF     \ Execute non colon definition
383      debug-last-xt cr u. ." : "
384      debug-last-xt xt>name type ."  "
385      ."     ( " .s  ."  )  | "
386      key drop
387      debug-last-xt execute
388   ELSE
389      debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt   \ Trace colon definition
390   THEN
391;
392
393\ Put entry point bp defer
394' (break-entry) to BP
395
396\ Mark an address for debugging
397
398: debug-address ( addr --  )
399   debug-off                       ( xt )  \ Remove active breakpoint
400   dup to debug-last-xt            ( xt )  \ Save token for later debug
401   dup @ to debug-last-xt-content  ( xt )  \ Save old value
402   ['] breakpoint swap !
403;
404
405\ Mark the command indicated by xt for debugging
406
407: (debug ( xt --  )
408   debug-off                       ( xt )  \ Remove active breakpoint
409   dup to debug-last-xt            ( xt )  \ Save token for later debug
410   dup @ to debug-last-xt-content  ( xt )  \ Save old value
411   ['] breakpoint @ swap !
412;
413
414\ Mark the command indicated by xt for debugging
415
416: debug ( "old-name<>" -- )
417    parse-word $find IF                       \ Get xt for old-name
418       (debug
419    ELSE
420       ." undefined word " type cr
421    THEN
422;