1\ 7.6 Client Program Debugging command group
2
3\ Saved program state context
4variable __context
50 __context !
6
7: saved-context __context @ @ ;
8
9
10\ 7.6.1    Registers display
11
12: ctrace    ( -- )
13  ;
14
15: .registers    ( -- )
16  ;
17
18: .fregisters    ( -- )
19  ;
20
21\ to    ( param [old-name< >] -- )
22
23
24\ 7.6.2    Program download and execute
25
26struct ( load-state )
27  /n field >ls.entry
28  /n field >ls.file-size
29  /n field >ls.file-type
30  /n field >ls.param
31constant load-state.size
32create load-state load-state.size allot
33
34variable state-valid
350 state-valid !
36
37variable file-size
38
39: !load-size file-size ! ;
40
41: load-size file-size @ ;
42
43
44\ File types identified by (load-state)
450  constant elf-boot
461  constant elf
472  constant bootinfo
483  constant xcoff
494  constant pe
505  constant aout
5110 constant fcode
5211 constant forth
5312 constant bootcode
5413 constant prep
55
56
57: init-program    ( -- )
58  \ Call down to the lower level for relocation etc.
59  s" (init-program)" $find if
60    execute
61  else
62    s" Unable to locate (init-program)!" type cr
63  then
64  ;
65
66: (find-bootdevice) ( param-str param-len -- bootpath-str bootpath-len)
67  \ Parse the <param> string which is a space-separated list of one or
68  \ more potential boot devices, and return the first one that can be
69  \ successfully opened.
70
71  \ Space-separated bootpath string
72  bl left-split 	\ bootpathstr bootpathstr-len bootdevstr bootdevstr-len
73  dup 0= if
74
75    \ None specified. As per IEEE-1275 specification, search through each value
76    \ in boot-device and use the first that returns a valid ihandle on open.
77
78    2drop		\ drop the empty device string as we're going to use our own
79
80    s" boot-device" $find drop execute
81    bl left-split
82    begin
83      dup
84    while
85      2dup s" Trying " type type s" ..." type cr
86      2dup open-dev ?dup if
87        close-dev
88	2swap drop 0	\ Fake end of string so we exit loop
89      else
90        2drop
91        bl left-split
92      then
93    repeat
94    2drop
95  then
96
97  \ bootargs
98  2swap dup 0= if
99    \ None specified, use default from nvram
100    2drop s" boot-file" $find drop execute
101  then
102
103  \ Set the bootargs property
104  encode-string
105  " /chosen" (find-dev) if
106    " bootargs" rot (property)
107  then
108;
109
110\ Locate the boot-device opened by this ihandle (currently taken as being
111\ the first non-interposed package in the instance chain)
112
113: ihandle>boot-device-handle ( ihandle -- 0 | device-ihandle -1 )
114  >r 0
115  begin r> dup >in.my-parent @ dup >r while
116    ( result ihandle R: ihandle.parent )
117    dup >in.interposed @ 0= if
118      \ Find the first non-interposed package
119      over 0= if
120        swap drop
121      else
122        drop
123      then
124    else
125      drop
126    then
127  repeat
128  r> drop drop
129
130  dup 0<> if
131    -1
132  then
133;
134
135: $load ( devstr len )
136  open-dev ( ihandle )
137  dup 0= if
138    drop
139    exit
140  then
141  dup >r
142  " load-base" evaluate swap ( load-base ihandle )
143  dup ihandle>phandle " load" rot find-method ( xt 0|1 )
144  if swap call-package !load-size else cr ." Cannot find load for this package" 2drop then
145
146  \ If the boot device path doesn't contain an explicit partition id, e.g. cd:,\\:tbxi
147  \ then the interposed partition package may have auto-probed a suitable partition. If
148  \ this is the case then it will have set the " selected-partition-args" property in
149  \ the partition package to contain the new device arguments.
150  \
151  \ In order to ensure that bootpath contains the partition argument, we use the contents
152  \ of this property if it exists to override the boot device arguments when generating
153  \ the full bootpath using get-instance-path.
154
155  my-self
156  r@ to my-self
157  " selected-partition-args" get-inherited-property 0= if
158    decode-string 2swap 2drop
159    ( myself-save partargs-str partargs-len )
160    r@ ihandle>boot-device-handle if
161      ( myself-save partargs-str partargs-len block-ihandle )
162      \ Override the arguments before get-instance-path
163      dup >in.arguments 2@ >r >r dup >r    ( R: block-ihandle arg-len arg-str )
164      >in.arguments 2!    ( myself-save )
165      r@ " get-instance-path" $find if
166        execute   ( myself-save bootpathstr bootpathlen )
167      then
168      \ Now write the original arguments back
169      r> r> r> rot >in.arguments 2!   ( myself-save bootpathstr bootpathlen  R: )
170      rot    ( bootpathstr bootpathlen myself-save )
171    then
172  else
173    my-self " get-instance-path" $find if
174      execute  ( myself-save bootpathstr pathlen )
175      rot    ( bootpathstr bootpathlen myself-save )
176    then
177  then
178  to my-self
179
180  \ Set bootpath property in /chosen
181  encode-string " /chosen" (find-dev) if
182    " bootpath" rot (property)
183  then
184
185  r> close-dev
186  init-program
187  ;
188
189: load    ( "{params}<cr>" -- )
190  linefeed parse
191  (find-bootdevice)
192  $load
193;
194
195: dir ( "{paths}<cr>" -- )
196  linefeed parse
197  ascii , split-after
198  2dup open-dev dup 0= if
199    drop
200    cr ." Unable to locate device " type
201    2drop
202    exit
203  then
204  -rot 2drop -rot 2 pick
205  " dir" rot ['] $call-method catch
206  if
207    3drop
208    cr ." Cannot find dir for this package"
209  then
210  close-dev
211;
212
213: go    ( -- )
214  state-valid @ 0= if
215    s" No valid state has been set by load or init-program" type cr
216    exit
217  then
218
219  \ Call any architecture-specific code
220  s" (arch-go)" $find if
221    execute
222  else
223    2drop
224  then
225
226  \ go
227  s" (go)" $find if
228    execute
229  then
230  ;
231
232
233\ 7.6.3    Abort and resume
234
235\ already defined !?
236\ : go    ( -- )
237\   ;
238
239
240\ 7.6.4    Disassembler
241
242: dis    ( addr -- )
243  ;
244
245: +dis    ( -- )
246  ;
247
248\ 7.6.5    Breakpoints
249: .bp    ( -- )
250  ;
251
252: +bp    ( addr -- )
253  ;
254
255: -bp    ( addr -- )
256  ;
257
258: --bp    ( -- )
259  ;
260
261: bpoff    ( -- )
262  ;
263
264: step    ( -- )
265  ;
266
267: steps    ( n -- )
268  ;
269
270: hop    ( -- )
271  ;
272
273: hops    ( n -- )
274  ;
275
276\ already defined
277\ : go    ( -- )
278\   ;
279
280: gos    ( n -- )
281  ;
282
283: till    ( addr -- )
284  ;
285
286: return    ( -- )
287  ;
288
289: .breakpoint    ( -- )
290  ;
291
292: .step    ( -- )
293  ;
294
295: .instruction    ( -- )
296  ;
297
298
299\ 7.6.6    Symbolic debugging
300: .adr    ( addr -- )
301  ;
302
303: sym    ( "name< >" -- n )
304  ;
305
306: sym>value    ( addr len -- addr len false | n true )
307  ;
308
309: value>sym    ( n1 -- n1 false | n2 addr len true )
310  ;
311