qemu/roms/openbios/forth/debugging/client.fs

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