diff options
Diffstat (limited to 'qemu/roms/openbios/forth/debugging')
| -rw-r--r-- | qemu/roms/openbios/forth/debugging/build.xml | 18 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/debugging/client.fs | 299 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/debugging/fcode.fs | 14 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/debugging/firmware.fs | 90 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/debugging/see.fs | 114 |
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) ; |