summaryrefslogtreecommitdiffstats
path: root/qemu/roms/openbios/forth/debugging
diff options
context:
space:
mode:
Diffstat (limited to 'qemu/roms/openbios/forth/debugging')
-rw-r--r--qemu/roms/openbios/forth/debugging/build.xml18
-rw-r--r--qemu/roms/openbios/forth/debugging/client.fs299
-rw-r--r--qemu/roms/openbios/forth/debugging/fcode.fs14
-rw-r--r--qemu/roms/openbios/forth/debugging/firmware.fs90
-rw-r--r--qemu/roms/openbios/forth/debugging/see.fs114
5 files changed, 535 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/debugging/build.xml b/qemu/roms/openbios/forth/debugging/build.xml
new file mode 100644
index 000000000..3b9a0ca44
--- /dev/null
+++ b/qemu/roms/openbios/forth/debugging/build.xml
@@ -0,0 +1,18 @@
+<build>
+
+ <!--
+ build description for forth debugging command group
+
+ Copyright (C) 2004-2005 by Stefan Reinauer
+ See the file "COPYING" for further information about
+ the copyright and warranty status of this work.
+ -->
+
+ <dictionary name="openbios" target="forth">
+ <object source="client.fs"/>
+ <object source="fcode.fs"/>
+ <object source="firmware.fs"/>
+ <object source="see.fs"/>
+ </dictionary>
+
+</build>
diff --git a/qemu/roms/openbios/forth/debugging/client.fs b/qemu/roms/openbios/forth/debugging/client.fs
new file mode 100644
index 000000000..f37440445
--- /dev/null
+++ b/qemu/roms/openbios/forth/debugging/client.fs
@@ -0,0 +1,299 @@
+\ 7.6 Client Program Debugging command group
+
+
+\ 7.6.1 Registers display
+
+: ctrace ( -- )
+ ;
+
+: .registers ( -- )
+ ;
+
+: .fregisters ( -- )
+ ;
+
+\ to ( param [old-name< >] -- )
+
+
+\ 7.6.2 Program download and execute
+
+struct ( saved-program-state )
+ /n field >sps.entry
+ /n field >sps.file-size
+ /n field >sps.file-type
+constant saved-program-state.size
+create saved-program-state saved-program-state.size allot
+
+variable state-valid
+0 state-valid !
+
+variable file-size
+
+: !load-size file-size ! ;
+
+: load-size file-size @ ;
+
+
+\ File types identified by (init-program)
+
+0 constant elf-boot
+1 constant elf
+2 constant bootinfo
+3 constant xcoff
+4 constant pe
+5 constant aout
+10 constant fcode
+11 constant forth
+12 constant bootcode
+
+
+: init-program ( -- )
+ \ Call down to the lower level for relocation etc.
+ s" (init-program)" $find if
+ execute
+ else
+ s" Unable to locate (init-program)!" type cr
+ then
+ ;
+
+: (find-bootdevice) ( param-str param-len -- bootpath-str bootpath-len)
+ \ Parse the <param> string which is a space-separated list of one or
+ \ more potential boot devices, and return the first one that can be
+ \ successfully opened.
+
+ \ Space-separated bootpath string
+ bl left-split \ bootpathstr bootpathstr-len bootdevstr bootdevstr-len
+ dup 0= if
+
+ \ None specified. As per IEEE-1275 specification, search through each value
+ \ in boot-device and use the first that returns a valid ihandle on open.
+
+ 2drop \ drop the empty device string as we're going to use our own
+
+ s" boot-device" $find drop execute
+ bl left-split
+ begin
+ dup
+ while
+ 2dup s" Trying " type type s" ..." type cr
+ 2dup open-dev ?dup if
+ close-dev
+ 2swap drop 0 \ Fake end of string so we exit loop
+ else
+ 2drop
+ bl left-split
+ then
+ repeat
+ 2drop
+ then
+
+ \ bootargs
+ 2swap dup 0= if
+ \ None specified, use default from nvram
+ 2drop s" boot-file" $find drop execute
+ then
+
+ \ Set the bootargs property
+ encode-string
+ " /chosen" (find-dev) if
+ " bootargs" rot (property)
+ then
+;
+
+\ Locate the boot-device opened by this ihandle (currently taken as being
+\ the first non-interposed package in the instance chain)
+
+: ihandle>boot-device-handle ( ihandle -- 0 | device-ihandle -1 )
+ >r 0
+ begin r> dup >in.my-parent @ dup >r while
+ ( result ihandle R: ihandle.parent )
+ dup >in.interposed @ 0= if
+ \ Find the first non-interposed package
+ over 0= if
+ swap drop
+ else
+ drop
+ then
+ else
+ drop
+ then
+ repeat
+ r> drop drop
+
+ dup 0<> if
+ -1
+ then
+;
+
+: $load ( devstr len )
+ open-dev ( ihandle )
+ dup 0= if
+ drop
+ exit
+ then
+ dup >r
+ " load-base" evaluate swap ( load-base ihandle )
+ dup ihandle>phandle " load" rot find-method ( xt 0|1 )
+ if swap call-package !load-size else cr ." Cannot find load for this package" 2drop then
+
+ \ If the boot device path doesn't contain an explicit partition id, e.g. cd:,\\:tbxi
+ \ then the interposed partition package may have auto-probed a suitable partition. If
+ \ this is the case then it will have set the " selected-partition-args" property in
+ \ the partition package to contain the new device arguments.
+ \
+ \ In order to ensure that bootpath contains the partition argument, we use the contents
+ \ of this property if it exists to override the boot device arguments when generating
+ \ the full bootpath using get-instance-path.
+
+ my-self
+ r@ to my-self
+ " selected-partition-args" get-inherited-property 0= if
+ decode-string 2swap 2drop
+ ( myself-save partargs-str partargs-len )
+ r@ ihandle>boot-device-handle if
+ ( myself-save partargs-str partargs-len block-ihandle )
+ \ Override the arguments before get-instance-path
+ dup >in.arguments 2@ >r >r dup >r ( R: block-ihandle arg-len arg-str )
+ >in.arguments 2! ( myself-save )
+ r@ " get-instance-path" $find if
+ execute ( myself-save bootpathstr bootpathlen )
+ then
+ \ Now write the original arguments back
+ r> r> r> rot >in.arguments 2! ( myself-save bootpathstr bootpathlen R: )
+ rot ( bootpathstr bootpathlen myself-save )
+ then
+ else
+ my-self " get-instance-path" $find if
+ execute ( myself-save bootpathstr pathlen )
+ rot ( bootpathstr bootpathlen myself-save )
+ then
+ then
+ to my-self
+
+ \ Set bootpath property in /chosen
+ encode-string " /chosen" (find-dev) if
+ " bootpath" rot (property)
+ then
+
+ r> close-dev
+ init-program
+ ;
+
+: load ( "{params}<cr>" -- )
+ linefeed parse
+ (find-bootdevice)
+ $load
+;
+
+: dir ( "{paths}<cr>" -- )
+ linefeed parse
+ ascii , split-after
+ 2dup open-dev dup 0= if
+ drop
+ cr ." Unable to locate device " type
+ 2drop
+ exit
+ then
+ -rot 2drop -rot 2 pick
+ " dir" rot ['] $call-method catch
+ if
+ 3drop
+ cr ." Cannot find dir for this package"
+ then
+ close-dev
+;
+
+: go ( -- )
+ state-valid @ not if
+ s" No valid state has been set by load or init-program" type cr
+ exit
+ then
+
+ \ Call the architecture-specific code to launch the client image
+ s" (go)" $find if
+ execute
+ else
+ ." go is not yet implemented"
+ 2drop
+ then
+ ;
+
+
+\ 7.6.3 Abort and resume
+
+\ already defined !?
+\ : go ( -- )
+\ ;
+
+
+\ 7.6.4 Disassembler
+
+: dis ( addr -- )
+ ;
+
+: +dis ( -- )
+ ;
+
+\ 7.6.5 Breakpoints
+: .bp ( -- )
+ ;
+
+: +bp ( addr -- )
+ ;
+
+: -bp ( addr -- )
+ ;
+
+: --bp ( -- )
+ ;
+
+: bpoff ( -- )
+ ;
+
+: step ( -- )
+ ;
+
+: steps ( n -- )
+ ;
+
+: hop ( -- )
+ ;
+
+: hops ( n -- )
+ ;
+
+\ already defined
+\ : go ( -- )
+\ ;
+
+: gos ( n -- )
+ ;
+
+: till ( addr -- )
+ ;
+
+: return ( -- )
+ ;
+
+: .breakpoint ( -- )
+ ;
+
+: .step ( -- )
+ ;
+
+: .instruction ( -- )
+ ;
+
+
+\ 7.6.6 Symbolic debugging
+: .adr ( addr -- )
+ ;
+
+: sym ( "name< >" -- n )
+ ;
+
+: sym>value ( addr len -- addr len false | n true )
+ ;
+
+: value>sym ( n1 -- n1 false | n2 addr len true )
+ ;
diff --git a/qemu/roms/openbios/forth/debugging/fcode.fs b/qemu/roms/openbios/forth/debugging/fcode.fs
new file mode 100644
index 000000000..76099558d
--- /dev/null
+++ b/qemu/roms/openbios/forth/debugging/fcode.fs
@@ -0,0 +1,14 @@
+\ 7.7 FCode Debugging command group
+
+\ The user interface versions of these FCode functions allow
+\ the user to debug FCode programs by providing named commands
+\ corresponding to FCode functions.
+
+: headerless ( -- )
+ ;
+
+: headers ( -- )
+ ;
+
+: apply ( ... "method-name< >device-specifier< >" -- ??? )
+ ;
diff --git a/qemu/roms/openbios/forth/debugging/firmware.fs b/qemu/roms/openbios/forth/debugging/firmware.fs
new file mode 100644
index 000000000..5e16a6c57
--- /dev/null
+++ b/qemu/roms/openbios/forth/debugging/firmware.fs
@@ -0,0 +1,90 @@
+\ 7.5 Firmware Debugging command group
+
+
+\ 7.5.1 Automatic stack display
+
+: (.s
+ depth 0 ?do
+ depth i - 1- pick .
+ loop
+ depth 0<> if ascii < emit space then
+ ;
+
+: showstack ( -- )
+ ['] (.s to status
+ ;
+
+: noshowstack ( -- )
+ ['] noop to status
+ ;
+
+\ 7.5.2 Serial download
+
+: dl ( -- )
+ ;
+
+
+\ 7.5.3 Dictionary
+
+\ 7.5.3.1 Dictionary search
+: .calls ( xt -- )
+ ;
+
+: $sift ( text-addr text-len -- )
+ ;
+
+: sifting ( "text< >" -- )
+ ;
+
+\ : words ( -- )
+\ \ Implemented in forth bootstrap.
+\ ;
+
+
+\ 7.5.3.2 Decompiler
+
+\ implemented in see.fs
+
+\ : see ( "old-name< >" -- )
+\ ;
+
+\ : (see) ( xt -- )
+\ ;
+
+
+\ 7.5.3.3 Patch
+
+: patch ( "new-name< >old-name< >word-to-patch< >" -- )
+ ;
+
+: (patch) ( new-n1 num1? old-n2 num2? xt -- )
+ ;
+
+
+\ 7.5.3.4 Forth source-level debugger
+
+: debug ( "old-name< >" -- )
+ parse-word \ Look up word CFA in dictionary
+ $find
+ 0 = if
+ ." could not locate word for debugging"
+ 2drop
+ else
+ (debug
+ then
+ ;
+
+: stepping ( -- )
+ ;
+
+: tracing ( -- )
+ ;
+
+: debug-off ( -- )
+ (debug-off)
+ ;
+
+: resume ( -- )
+ \ Set interpreter termination flag
+ 1 to terminate?
+ ;
diff --git a/qemu/roms/openbios/forth/debugging/see.fs b/qemu/roms/openbios/forth/debugging/see.fs
new file mode 100644
index 000000000..6977d29eb
--- /dev/null
+++ b/qemu/roms/openbios/forth/debugging/see.fs
@@ -0,0 +1,114 @@
+\ tag: Forth Decompiler
+\
+\ this code implements IEEE 1275-1994 ch. 7.5.3.2
+\
+\ Copyright (C) 2003 Stefan Reinauer
+\
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+1 value (see-indent)
+
+: (see-cr)
+ cr (see-indent) spaces
+ ;
+
+: indent+
+ (see-indent) 2+ to (see-indent)
+ ;
+
+: indent-
+ (see-indent) 2- to (see-indent)
+ ;
+
+: (see-colon)
+ dup ." : " cell - lfa2name type (see-cr)
+ begin
+ cell+ dup @ dup ['] (semis) <>
+ while
+ space
+ dup
+ case
+
+ ['] do?branch of
+ ." if" (see-cr) indent+
+ drop cell+
+ endof
+
+ ['] dobranch of
+ ." then" indent- (see-cr)
+ drop cell+
+ endof
+
+ ['] (begin) of
+ ." begin" indent+ (see-cr)
+ drop
+ endof
+
+ ['] (again) of
+ ." again" (see-cr)
+ drop
+ endof
+
+ ['] (until) of
+ ." until" (see-cr)
+ drop
+ endof
+
+ ['] (while) of
+ indent- (see-cr)
+ ." while"
+ indent+ (see-cr)
+ drop 2 cells +
+ endof
+
+ ['] (repeat) of
+ indent- (see-cr)
+ ." repeat"
+ (see-cr)
+ drop 2 cells +
+ endof
+
+ ['] (lit) of
+ ." ( lit ) h# "
+ drop 1 cells +
+ dup @ u.
+ endof
+
+ ['] (") of
+ 22 emit space drop dup cell+ @
+ 2dup swap 2 cells + swap type
+ 22 emit
+ + aligned cell+
+ endof
+
+ cell - lfa2name type
+ endcase
+ repeat
+ cr ." ;"
+ 2drop
+ ;
+
+: (see) ( xt -- )
+ cr
+ dup @ case
+ 1 of
+ (see-colon)
+ endof
+ 3 of
+ ." constant " dup cell - lfa2name type ." = " execute .
+ endof
+ 4 of
+ ." variable " dup cell - lfa2name type ." = " execute @ .
+ endof
+ 5 of
+ ." defer " dup cell - lfa2name type cr
+ ." is " cell+ @ cell - lfa2name type cr
+ endof
+ ." primword " swap cell - lfa2name type
+ endcase
+ cr
+ ;
+
+: see ' (see) ;