311 lines
6 KiB
Forth
311 lines
6 KiB
Forth
|
\ 7.6 Client Program Debugging command group
|
||
|
|
|
||
|
|
\ Saved program state context
|
||
|
|
variable __context
|
||
|
|
0 __context !
|
||
|
|
|
||
|
|
: saved-context __context @ @ ;
|
||
|
|
|
||
|
|
|
||
|
|
\ 7.6.1 Registers display
|
||
|
|
|
||
|
|
: ctrace ( -- )
|
||
|
|
;
|
||
|
|
|
||
|
|
: .registers ( -- )
|
||
|
|
;
|
||
|
|
|
||
|
|
: .fregisters ( -- )
|
||
|
|
;
|
||
|
|
|
||
|
|
\ to ( param [old-name< >] -- )
|
||
|
|
|
||
|
|
|
||
|
|
\ 7.6.2 Program download and execute
|
||
|
|
|
||
|
|
struct ( load-state )
|
||
|
|
/n field >ls.entry
|
||
|
|
/n field >ls.file-size
|
||
|
|
/n field >ls.file-type
|
||
|
|
/n field >ls.param
|
||
|
|
constant load-state.size
|
||
|
|
create load-state load-state.size allot
|
||
|
|
|
||
|
|
variable state-valid
|
||
|
|
0 state-valid !
|
||
|
|
|
||
|
|
variable file-size
|
||
|
|
|
||
|
|
: !load-size file-size ! ;
|
||
|
|
|
||
|
|
: load-size file-size @ ;
|
||
|
|
|
||
|
|
|
||
|
|
\ File types identified by (load-state)
|
||
|
|
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
|
||
|
|
13 constant prep
|
||
|
|
|
||
|
|
|
||
|
|
: 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 @ 0= if
|
||
|
|
s" No valid state has been set by load or init-program" type cr
|
||
|
|
exit
|
||
|
|
then
|
||
|
|
|
||
|
|
\ Call any architecture-specific code
|
||
|
|
s" (arch-go)" $find if
|
||
|
|
execute
|
||
|
|
else
|
||
|
|
2drop
|
||
|
|
then
|
||
|
|
|
||
|
|
\ go
|
||
|
|
s" (go)" $find if
|
||
|
|
execute
|
||
|
|
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 )
|
||
|
|
;
|