Add qemu 2.4.0

Change-Id: Ic99cbad4b61f8b127b7dc74d04576c0bcbaaf4f5
Signed-off-by: Yang Zhang <yang.z.zhang@intel.com>

1 files changed, 422 insertions, 0 deletions

diff --git a/qemu/roms/SLOF/slof/fs/debug.fs b/qemu/roms/SLOF/slof/fs/debug.fs
new file mode 100644
index 000000000..e54f729fe
--- /dev/null
+++ b/qemu/roms/SLOF/slof/fs/debug.fs
@@ -0,0 +1,422 @@
+\ *****************************************************************************
+\ * Copyright (c) 2004, 2008 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ *     IBM Corporation - initial implementation
+\ ****************************************************************************/
+
+
+\ Get the name of Forth command whose execution token is xt
+
+: xt>name ( xt -- str len )
+    BEGIN
+	cell - dup c@ 0 2 within IF
+	    dup 2+ swap 1+ c@ exit
+	THEN
+    AGAIN
+;
+
+cell -1 * CONSTANT -cell
+: cell- ( n -- n-cell-size )
+   [ cell -1 * ] LITERAL +
+;
+
+\ Search for xt of given address
+: find-xt-addr ( addr -- xt )
+   BEGIN
+      dup @ <colon> = IF
+	 EXIT
+      THEN
+      cell-
+   AGAIN
+;
+
+: (.immediate) ( xt -- )
+   \ is it immediate?
+   xt>name drop 2 - c@ \ skip len and flags
+   immediate? IF
+     ."  IMMEDIATE"
+   THEN
+;
+
+: (.xt) ( xt -- )
+   xt>name type
+;
+
+\ Trace back on current return stack.
+\ Start at 1, since 0 is return of trace-back itself
+
+: trace-back (  )
+   1
+   BEGIN
+      cr dup dup . ."  : " rpick dup . ."  : "
+      ['] tib here within IF
+	  dup rpick find-xt-addr (.xt)
+      THEN
+      1+ dup rdepth 5 - >= IF cr drop EXIT THEN
+   AGAIN
+;
+
+VARIABLE see-my-type-column
+
+: (see-my-type) ( indent limit xt str len -- indent limit xt )
+   dup see-my-type-column @ + dup 50 >= IF
+      -rot over "  " comp 0= IF
+         \ blank causes overflow: just enforce new line with next call
+         2drop see-my-type-column !
+      ELSE
+         rot drop                     ( indent limit xt str len )
+         \ Need to copy string since we use (u.) again (kills internal buffer):
+         pocket swap 2dup >r >r       ( indent limit xt str pk len  R: len pk )
+         move r> r>                   ( indent limit xt pk len )
+         2 pick (u.) dup -rot
+         cr type                      ( indent limit xt pk len xt-len )
+         " :" type 1+                 ( indent limit xt pk len prefix-len )
+         5 pick dup spaces +          ( indent limit xt pk len prefix-len )
+         over + see-my-type-column !  ( indent limit xt pk len )
+         type
+      THEN                            ( indent limit xt )
+   ELSE
+      see-my-type-column ! type       ( indent limit xt )
+   THEN
+;
+
+: (see-my-type-init) ( -- )
+   ffff see-my-type-column !        \ just enforce a new line
+;
+
+: (see-colon-body) ( indent limit xt -- indent limit xt )
+   (see-my-type-init)                              \ enforce new line
+   BEGIN                                           ( indent limit xt )
+      cell+ 2dup <>
+      over @
+      dup <semicolon> <>
+      rot and			                   ( indent limit xt @xt flag )
+   WHILE                                           ( indent limit xt @xt )
+      xt>name (see-my-type) "  " (see-my-type)
+      dup @                                        ( indent limit xt @xt)
+      CASE
+	 <0branch>  OF cell+ dup @
+                    over + cell+ dup >r
+                    (u.) (see-my-type) r>          ( indent limit xt target)
+                    2dup < IF
+                       over 4 pick 3 + -rot recurse
+                       nip nip nip cell-           ( indent limit xt )
+                    ELSE
+                       drop                        ( indent limit xt )
+                    THEN
+                    (see-my-type-init) ENDOF       \ enforce new line
+	 <branch>   OF cell+ dup @ over + cell+ (u.)
+                    (see-my-type) "  " (see-my-type) ENDOF
+	 <do?do>    OF cell+ dup @ (u.) (see-my-type)
+                    "  " (see-my-type) ENDOF
+	 <lit>      OF cell+ dup @ (u.) (see-my-type)
+                    "  " (see-my-type) ENDOF
+	 <dotick>   OF cell+ dup @ xt>name (see-my-type)
+                    "  " (see-my-type) ENDOF
+	 <doloop>   OF cell+ dup @ (u.) (see-my-type)
+                    "  " (see-my-type) ENDOF
+	 <do+loop>  OF cell+ dup @ (u.) (see-my-type)
+                    "  " (see-my-type) ENDOF
+	 <doleave>  OF cell+ dup @ over + cell+ (u.)
+                    (see-my-type) "  " (see-my-type) ENDOF
+	 <do?leave> OF cell+ dup @ over + cell+ (u.)
+                    (see-my-type) "  " (see-my-type) ENDOF
+	 <sliteral> OF cell+ " """ (see-my-type) dup count dup >r
+                    (see-my-type) " """ (see-my-type)
+                    "  " (see-my-type)
+                    r> -cell and + ENDOF
+      ENDCASE
+   REPEAT
+   drop
+;
+
+: (see-colon) ( xt -- )
+   (see-my-type-init)
+   1 swap 0 swap                                    ( indent limit xt )
+   " : " (see-my-type) dup xt>name (see-my-type)
+   rot drop 4 -rot (see-colon-body)                 ( indent limit xt )
+   rot drop 1 -rot (see-my-type-init) " ;" (see-my-type)
+   3drop 
+;
+
+\ Create words are a bit tricky. We find out where their code points.
+\ If this code is part of SLOF, it is not a user generated CREATE.
+
+: (see-create) ( xt -- )
+   dup cell+ @
+   CASE
+      <2constant> OF
+         dup cell+ cell+ dup @ swap cell+ @ . .  ." 2CONSTANT "
+      ENDOF
+
+      <instancevalue> OF
+         dup cell+ cell+ @ . ." INSTANCE VALUE "
+      ENDOF
+
+      <instancevariable> OF
+         ." INSTANCE VARIABLE "
+      ENDOF
+
+      dup OF
+         ." CREATE "
+      ENDOF
+   ENDCASE
+   (.xt)
+;
+
+\ Decompile Forth command whose execution token is xt
+
+: (see) ( xt -- )
+   cr dup dup @
+   CASE
+      <variable> OF ." VARIABLE " (.xt) ENDOF
+      <value>    OF dup execute . ." VALUE " (.xt) ENDOF
+      <constant> OF dup execute . ." CONSTANT " (.xt) ENDOF
+      <defer>    OF dup cell+ @ swap ." DEFER " (.xt) ."  is " (.xt) ENDOF
+      <alias>    OF dup cell+ @ swap ." ALIAS " (.xt) ."  " (.xt) ENDOF
+      <buffer:>  OF ." BUFFER: " (.xt) ENDOF
+      <create>   OF (see-create) ENDOF
+      <colon>    OF (see-colon)  ENDOF
+      dup        OF ." ??? PRIM " (.xt) ENDOF
+   ENDCASE
+   (.immediate) cr
+  ;
+
+\ Decompile Forth command old-name
+
+: see ( "old-name<>" -- )
+   ' (see)
+;
+
+\ Work in progress...
+
+0    value forth-ip
+true value trace>stepping?
+true value trace>print?
+true value trace>up?
+0    value trace>depth
+0    value trace>rdepth
+0    value trace>recurse
+: trace-depth+ ( -- ) trace>depth 1+ to trace>depth ;
+: trace-depth- ( -- ) trace>depth 1- to trace>depth ;
+
+: stepping ( -- )
+    true to trace>stepping?
+;
+
+: tracing ( -- )
+    false to trace>stepping?
+;
+
+: trace-print-on ( -- )
+    true to trace>print?
+;
+
+: trace-print-off ( -- )
+    false to trace>print?
+;
+
+
+\ Add n to ip
+
+: fip-add ( n -- )
+   forth-ip + to forth-ip
+;
+
+\ Save execution token address and content
+
+0 value debug-last-xt
+0 value debug-last-xt-content
+
+: trace-print ( -- )
+   forth-ip cr u. ." : "
+   forth-ip @ 
+   dup ['] breakpoint = IF drop debug-last-xt-content THEN
+   xt>name type ."  "
+   ."     ( " .s  ."  )  | "
+;
+
+: trace-interpret ( -- )
+   rdepth 1- to trace>rdepth
+   BEGIN
+      depth . [char] > dup emit emit space
+      source expect                        ( str len )
+      ['] interpret catch print-status
+   AGAIN
+;
+
+\ Main trace routine, trace a colon definition
+
+: trace-xt ( xt -- )
+    trace>recurse IF
+       r> drop                                \ Drop return of 'trace-xt call
+       cell+                                  \ Step over ":"
+    ELSE
+       debug-last-xt-content <colon> = IF
+          \ debug colon-definition
+          ['] breakpoint @ debug-last-xt !    \ Re-arm break point
+          r> drop                             \ Drop return of 'trace-xt call
+          cell+                               \ Step over ":"
+       ELSE
+          ['] breakpoint debug-last-xt !      \ Re-arm break point
+          2r> 2drop
+       THEN
+    THEN
+
+    to forth-ip
+    true to trace>print?
+    BEGIN
+       trace>print? IF trace-print THEN
+
+       forth-ip                                              ( ip )
+       trace>stepping? IF
+	  BEGIN
+             key
+             CASE
+		[char] d OF dup @ @ <colon> = IF             \ recurse only into colon definitions
+			                         trace-depth+
+                                                 1 to trace>recurse
+                                                 dup >r @ recurse
+		                              THEN true ENDOF
+	        [char] u OF trace>depth IF tracing trace-print-off true ELSE false THEN ENDOF
+	        [char] f OF drop cr trace-interpret ENDOF	\ quit trace and start interpreter FIXME rstack
+	        [char] c OF tracing true ENDOF
+		[char] t OF trace-back false ENDOF
+		[char] q OF drop cr quit ENDOF
+	        20       OF true ENDOF
+		dup      OF cr ." Press d:       Down into current word" cr
+		            ." Press u:       Up to caller" cr
+		            ." Press f:       Switch to forth interpreter, 'resume' will continue tracing" cr
+                            ." Press c:       Switch to tracing" cr
+		            ." Press <space>: Execute current word" cr
+		            ." Press q:       Abort execution, switch to interpreter" cr
+		            false ENDOF
+	     ENDCASE
+	  UNTIL
+       THEN	                                              ( ip' )
+       dup to forth-ip @                                      ( xt )
+       dup ['] breakpoint = IF drop debug-last-xt-content THEN
+       dup                                                    ( xt xt )
+
+       CASE
+	    <sliteral>  OF drop forth-ip cell+ dup dup c@ + -cell and to forth-ip ENDOF
+	    <dotick>    OF drop forth-ip cell+ @ cell fip-add ENDOF
+	    <lit>       OF drop forth-ip cell+ @ cell fip-add ENDOF
+	    <doto>      OF drop forth-ip cell+ @ cell+ ! cell fip-add ENDOF
+	    <(doito)>   OF drop forth-ip cell+ @ cell+ cell+ @ >instance ! cell fip-add ENDOF
+	    <0branch>   OF drop IF
+		                    cell fip-add
+		                ELSE
+				    forth-ip cell+ @ cell+ fip-add THEN
+			ENDOF
+            <do?do>     OF drop 2dup <> IF
+				           swap >r >r cell fip-add
+		                        ELSE
+					   forth-ip cell+ @ cell+ fip-add 2drop THEN
+		        ENDOF
+	    <branch>    OF drop forth-ip cell+ @ cell+ fip-add ENDOF
+	    <doleave>   OF drop r> r> 2drop forth-ip cell+ @ cell+ fip-add ENDOF		
+	    <do?leave>  OF drop IF
+		                   r> r> 2drop forth-ip cell+ @ cell+ fip-add
+		                ELSE
+		                   cell fip-add
+		                THEN
+		        ENDOF		
+	    <doloop>    OF drop r> 1+ r> 2dup = IF
+		                                   2drop cell fip-add
+		                                ELSE >r >r
+						    forth-ip cell+ @ cell+ fip-add THEN
+			ENDOF
+	    <do+loop>   OF drop r> + r> 2dup >= IF
+		                                   2drop cell fip-add
+		                                ELSE >r >r
+						    forth-ip cell+ @ cell+ fip-add THEN
+			ENDOF
+
+	    <semicolon> OF trace>depth 0> IF
+		                             trace-depth- 1 to trace>recurse
+                                             stepping drop r> recurse
+		                          ELSE
+		                             drop exit THEN
+			ENDOF
+            <exit>      OF trace>depth 0> IF
+		                             trace-depth- stepping drop r> recurse
+		                          ELSE
+				             drop exit THEN
+			ENDOF
+	    dup         OF execute ENDOF
+	ENDCASE
+	forth-ip cell+ to forth-ip
+    AGAIN
+;
+
+\ Resume execution from tracer
+: resume ( -- )
+    trace>rdepth rdepth!
+    forth-ip cell - trace-xt
+;
+
+\ Turn debug off, by erasing breakpoint
+
+: debug-off ( -- )
+    debug-last-xt IF
+	debug-last-xt-content debug-last-xt !  \ Restore overwritten token
+	0 to debug-last-xt
+    THEN
+;
+
+
+
+\ Entry point for debug
+
+: (break-entry) ( -- )
+   debug-last-xt dup @ ['] breakpoint <> swap  ( debug-addr? debug-last-xt )
+   debug-last-xt-content swap !                \ Restore overwritten token
+   r> drop                                     \ Don't return to bp, but to caller
+   debug-last-xt-content <colon> <> and IF     \ Execute non colon definition
+      debug-last-xt cr u. ." : "
+      debug-last-xt xt>name type ."  "
+      ."     ( " .s  ."  )  | "
+      key drop
+      debug-last-xt execute
+   ELSE
+      debug-last-xt 0 to trace>depth 0 to trace>recurse trace-xt   \ Trace colon definition
+   THEN
+;
+
+\ Put entry point bp defer
+' (break-entry) to BP
+
+\ Mark an address for debugging
+
+: debug-address ( addr --  )
+   debug-off                       ( xt )  \ Remove active breakpoint
+   dup to debug-last-xt            ( xt )  \ Save token for later debug
+   dup @ to debug-last-xt-content  ( xt )  \ Save old value
+   ['] breakpoint swap !
+;
+
+\ Mark the command indicated by xt for debugging
+
+: (debug ( xt --  )
+   debug-off                       ( xt )  \ Remove active breakpoint
+   dup to debug-last-xt            ( xt )  \ Save token for later debug
+   dup @ to debug-last-xt-content  ( xt )  \ Save old value
+   ['] breakpoint @ swap !
+;
+
+\ Mark the command indicated by xt for debugging
+
+: debug ( "old-name<>" -- )
+    parse-word $find IF                       \ Get xt for old-name
+       (debug
+    ELSE
+       ." undefined word " type cr
+    THEN
+;