\ Do not use this file except in compliance with the License. You may \ obtain a copy of the License at http://www.microcore.org/License/ \ Software distributed under the License is distributed on an "AS IS" basis, \ WITHOUT WARRANTY OF ANY KIND, either express or implied. \ See the License for the specific language governing rights and limitations \ under the License. \ \ Time-stamp: "21Jun2009 10:30:55 Ulrich Hoffmann" \ Last change: KS 22.11.2015 12:41:15 \ \ The Original Code is: DEBUGGER.FS \ \ Microcore Debuger reimplemented in Forth based on ideas of the Microcore \ Debugger written in C by Andrej Kostrov \ \ This is the MicroCore single step debugger and tracer. \ The target MicroCore system is connected via an umbilical \ link to the host system. A communications protocol allows \ to transfer execution tokens (addresses) to the target where \ a tiny debug interpreter executes these tokens. See file monitor.fs \ for target side details. \ \ Revision History: \ 2009-06-21: added abort to stop debugging immediately \ 2009-04-15: some words renamed \ 2009-04-11: breakpoints, nest, end-trace \ 2009-04-01: page structure in source code, \ enhanced communication control flow, \ interpreter in single step mode, \ watch points with multiple target memory cells, \ debug interpreter with search order \ 2009-03-25: early support for single stepping \ 2009-02-14: initial port to gforth include monitor.fs \ debug support in the target system \ Debugger output support words Host : .hex## ( x -- ) temp_hex dup <# # # #> type ; : .hex ( x -- ) temp_hex ." $" u. ; \ Table data structure : Table: ( size itemsize -- ) \ { len | size | len*x } Create 0 , dup , cells allot ; : table-length ( table -- len ) @ ; : table-size ( table -- size ) cell+ @ ; : table-data ( table -- 'data ) 2 cells + ; : table-clear ( table -- ) off ; : table-bounds ( table -- to from ) dup table-data swap table-length cells bounds ; : table-iterate ( i*x xt table -- j*x ) table-bounds ?DO ( i*x xt ) I @ swap dup >r execute r> 1 cells +LOOP ( j*x xt ) drop ; : table-2iterate ( i*x xt table -- j*x ) table-bounds ?DO ( i*x xt ) I 2@ rot dup >r execute r> 2 cells +LOOP ( j*x xt ) drop ; \ : table-show ( table -- ) \ ['] . swap table-iterate ; \ ... append, remove : table-append ( item table -- ) dup table-length 1+ over table-size over < Abort" Table exhausted!" ( item table length ) over ! ( item table ) dup @ cells + cell+ ! ; : >table-item ( i table -- addr ) 2dup table-length u< 0= Abort" Table index out of range" 2 cells + swap cells + ; : table-item ( i table -- x ) >table-item @ ; : table-remove ( i table -- ) dup >r 2dup table-length swap - 1- ( rest ) >r >table-item dup cell+ swap ( from to ) r> cells cmove -1 r> +! ; : table-pop ( table -- x ) dup table-length 1- swap 2dup table-item >r table-remove r> ; : table-drop ( table -- ) table-pop drop ; \ ... find items : table-find ( item table -- i tf | ff ) dup table-length 0 ?DO ( item table ) 2dup I swap table-item = IF 2drop I true UNLOOP EXIT THEN LOOP ( item table ) 2drop false ; : table-2find ( item table -- i tf | ff ) dup table-length 0 ?DO ( item table ) 2dup I swap table-item = IF 2drop I true UNLOOP EXIT THEN 2 +LOOP ( item table ) 2drop false ; \ ... dynamic tables \ : allocate-table ( n -- table ) \ dup 2 + cells allocate throw \ dup off swap over cell+ ! ; \ : free-table ( table -- ) free throw ; \ Debugger communication Variable Umbilical Umbilical off : (tx ( x -- ) term-emit term-flush ; : tx ( x -- ) Umbilical @ IF cr ." sendByte: " dup .hex## THEN (tx ; : rx ( -- x ) term-key Umbilical @ 0= ?EXIT cr ." receiveByte: " dup .hex## ; : rx? ( -- flag ) term-key? ; : rxflush ( -- ) BEGIN rx? WHILE rx drop REPEAT ; \ ... logging words : log-cr ( -- ) Umbilical @ IF cr THEN ; : log-string ( addr len -- ) Umbilical @ IF type ELSE 2drop THEN ; : log-word ( x -- ) Umbilical @ IF temp_hex dup <# # # # # # # #> type ELSE drop THEN ; \ ... send and receive variable length data words data_width #code /mod swap 0= 0= - Constant #bytes/word : transmit ( x -- ) log-cr s" transmit: " log-string dup log-word 0 #bytes/word 1- ?DO dup I 8 * rshift $FF and tx -1 +LOOP drop ; : receive ( -- x ) rx dup $80 and IF -1 ELSE 0 THEN 8 lshift or #bytes/word 1- 0 ?DO 8 lshift rx or LOOP log-cr s" receive: " log-string dup log-word ; \ ... target communications protocol : ack ( -- ) mark_ack tx ; : nack ( -- ) mark_nack tx ; : *nack ( -- ) #bytes/word 0 ?DO nack LOOP ; &18 Constant #nack-detected &19 Constant #protocol-error &20 Constant #handshake-error -1 Constant #abort -&13 Constant #unknown -&28 Constant #bye : ?ack ( -- ) rx mark_ack case? ?EXIT mark_nack case? IF #nack-detected throw THEN 1 IF ." The byte " .hex## ." was unexpected " ELSE drop THEN #protocol-error throw ; : >target ( x -- ) mark_debug tx transmit ?ack ; : target> ( -- x ) BEGIN rx mark_debug = UNTIL receive ack ; : host-target ( -- u ) [ 8 cells data_width - ] Literal dup 0< abort" target data width > host data width" ; : dtarget> ( -- d ) target> target> swap dup #signbit and IF host-target 0 ?DO 2* LOOP host-target 0 ?DO 2/ LOOP THEN \ sign extension swap host-target 0 ?DO 2* LOOP swap host-target 0 ?DO d2/ LOOP ; \ ... handshake : handshake ( -- ) hex rxflush ." H" 0 >target BEGIN ." A" target> -1 <> WHILE 0 >target REPEAT BEGIN ." N" rx? 0= IF $5F5 >target THEN \ shorten replies if target still sends data target> $505 - WHILE key? IF break_key? IF #handshake-error throw THEN THEN REPEAT ." D" 0 >target ." S" target> ." H" ?dup IF ." Error: Handshake error. 0 expected, " .hex ." received" #handshake-error throw THEN ." AKE" ; : do-handshake ( -- ) ." , " handshake ." done" ; \ ... download program image : (send-image ( t-addr len cpuInit -- ) *nack rxflush IF mark_reset ELSE mark_start THEN tx over transmit \ t-addr dup transmit \ len bounds ?DO I opcode@ tx LOOP ?ack ; ' (send-image is send-image : boot-image ( -- ) 0 there true send-image there Transferred ! ; : reset ( -- ) 0 0 true send-image ; \ ... setting breakpoints : set-breakpoint ( addr -- ) *nack mark_start tx transmit \ t-addr 1 transmit \ len op_BREAK tx ?ack ; : restore-instruction ( addr -- ) *nack mark_start tx dup transmit \ t-addr 1 transmit \ len >memory @ tx ?ack ; \ handling target messages include messages.fs : do-reset ( -- ) cr ." uCore reset detected!" handshake ; Defer do-handle-breakpoint : ?OK ( -- ) BEGIN target> ?dup 0= ?EXIT #warmboot case? IF do-reset EXIT THEN #breakpoint case? IF target> target> IF #protocol-error throw THEN do-handle-breakpoint ELSE do_messages THEN AGAIN ; \ debugger words, which can be compiled into debug target code Target : . ( n -- ) #dot message out! ; : .r ( n u -- ) #dotr message out! out! ; : u. ( u -- ) #udot message out! ; : d. ( d -- ) #ddot message out! out! ; : (cr ( -- ) #cret message ; : (here ( -- addr ) #here message in@ ; : (allot ( n -- ) #allot message out! ; : emit ( char -- ) #emit message out! ; Host T definitions Forth : allot ( n -- ) comp? IF T (allot H EXIT THEN dbg? IF t> THEN Tdp +! ; : here ( -- addr ) comp? IF T (here H EXIT THEN Tdp @ dbg? 0= ?EXIT >t ; : cr ( -- ) comp? IF T (cr H EXIT THEN cr ; Forth definitions \ send addresses and literals : (t_execute ( xt -- ) >target ?OK ; ' (t_execute is t_execute : (t> ( -- x ) [t'] \out! >target target> ?OK ; ' (t> IS t> : (>t ( x -- ) [t'] \in@ >target >target ?OK ; ' (>t IS >t : (t_@ ( addr -- x ) >t [t'] \@ t_execute t> ; ' (t_@ IS t_@ : (t_! ( x addr -- ) swap >t >t [t'] \! t_execute ; ' (t_! IS t_! \ permanent and temporary breakpoints : install-breakpoint ( taddr table -- ) Verbose @ IF ." installing breakpoint " over .hex THEN over set-breakpoint 2dup table-find IF drop 2drop EXIT THEN table-append ; : remove-breakpoint ( taddr table -- ) Verbose @ IF ." removing breakpoint " over .hex THEN over restore-instruction swap over table-find IF swap table-remove ELSE drop THEN ; : remove-all-breakpoints ( table -- ) BEGIN dup table-length WHILE 0 over table-item over remove-breakpoint REPEAT drop ; : set-all-breakpoints ( table -- ) ['] set-breakpoint swap table-iterate ; &32 Table: permanent-breakpoints &8 Table: temporary-breakpoints : install-temporary-breakpoint ( taddr -- ) temporary-breakpoints install-breakpoint ; : permanent-breakpoint? ( taddr -- f ) permanent-breakpoints table-find dup IF nip THEN ; : .breakpoint ( taddr -- ) Colons .listname ; \ move temporary breakpoints &32 Table: nests : -nest ( -- ) nests table-length 0= ?EXIT nests table-pop install-temporary-breakpoint ; : target-address ( addr -- addr' ) dup nibbles@ nibbles> swap >branch drop + 1+ ; : advance-breakpoint ( addr nextaddr -- ) over opcode@ ( oldaddr newaddr opcode ) op_EXIT case? IF -nest 2drop EXIT THEN op_ZEXIT case? IF t> dup >t 0= IF -nest 2drop EXIT THEN op_ZEXIT THEN op_NZEXIT case? IF t> dup >t IF -nest 2drop EXIT THEN op_NZEXIT THEN dup lit_op? IF drop ( oldaddr newaddr ) over >branch drop opcode@ a_branch? IF ( oldaddr newaddr ) dup install-temporary-breakpoint \ after jump swap nibbles@ nibbles> + install-temporary-breakpoint \ at jump target EXIT THEN ( oldaddr newaddr ) nip install-temporary-breakpoint \ after literal EXIT THEN \ sequential execution drop nip install-temporary-breakpoint \ after instruction ; \ watchpoints &32 Table: watches : .watch ( n xt -- ) cr swap >r dup >name ." " .name ." = " >body @ r> bounds ?DO I t_@ . LOOP ; : .watches ( -- ) ['] .watch watches table-2iterate ; : add-watch ( addr n -- ) swap watches table-append watches table-append ; : find-watch ( addr -- ) watches table-2find ; : remove-watch ( i -- ) dup watches table-remove watches table-remove ; \ debug-interpreter Target Forth get-current Host Constant target-wordlist : s' ( -- hostxt ) \ ' symbol table name target-wordlist search-wordlist 0= IF #unknown throw THEN ; \ ... messages : .target ( -- ) warnings on \ cr ." /----------------------------------------------------------------\" \ cr ." | MicroCore - use bye to return |" \ cr ; : .host ( -- ) warnings off \ cr ." | MicroCore |" \ cr ." \----------------------------------------------------------------/" \ cr \ cr ." Back in the host " ; \ ... main loop : debugger-interpret ( -- ) BEGIN name dup WHILE target-compiler REPEAT 2drop ; : input ( -- ) \ get a line to tib \ similar to query, but gforth query has problems with a partially \ initialized system try gforth-0.6.2 -e query and do some input \ to see the address violation tib /line accept #tib ! >in off ; : (debugger ( -- ) .watches permanent-breakpoints set-all-breakpoints temporary-breakpoints remove-all-breakpoints cr ." uCore> " input debugger-interpret ; : handle-debug-error ( n -- ) #unknown case? IF ." ?" EXIT THEN #nack-detected case? IF ." nack from target" do-handshake EXIT THEN #protocol-error case? IF ." garbage from target, try pressing reset on target" rxflush do-handshake EXIT THEN ( ." Error " . ) doerror ; \ ... top level command : debugger ( -- ) .target Target debugging on nests table-clear BEGIN ['] (debugger catch ?dup IF #bye case? IF .host debugging off Host EXIT THEN handle-debug-error ELSE comp? IF ." ]" ELSE ." ok" THEN THEN AGAIN ; ' debugger Alias dbg \ ... breakpoint action Variable signed signed on : show-dstack ( -- ) [t'] copyds >target target> ( depth ) 0 ?DO target> signed @ IF . ELSE u. THEN LOOP ?OK ; : show-breakpoint ( addr -- addr' ) .instruction space &40 position show-dstack ; : another-command? ( -- f ) #tib @ ; : trigger-resume ( -- ) #tib off ; : interpret-breakpoint-commands ( addr nextaddr -- addr' nextaddr' ) ['] debugger-interpret catch 0 case? IF another-command? 0= ?EXIT ." ok" EXIT THEN #unknown case? IF ." ?" EXIT THEN #abort case? IF ." aborted" EXIT THEN throw ; \ ... breakpoint handler : breakpoint-prompt ( -- ) space nests table-length 1+ 0 DO ." >" LOOP space ; : handle-breakpoint ( addr -- ) temporary-breakpoints remove-all-breakpoints BEGIN ( addr ) dis_output dup show-breakpoint ( addr nextaddr ) &60 position breakpoint-prompt input std_output #tib @ IF interpret-breakpoint-commands THEN ( addr nextaddr ) another-command? WHILE drop REPEAT ( addr nextaddr ) over swap 2dup - IF over restore-instruction advance-breakpoint ELSE 2drop THEN ( addr ) Verbose @ IF ." resuming at " dup .hex THEN [t'] nextstep >target >target ; ' handle-breakpoint is do-handle-breakpoint \ special words available in debugger : addr. ( caddr -- ) #datamask and [ data_width 3 + 4 / ] Literal u.r ; Commands: : bye ( -- ) #bye throw ; : commands ( -- ) get-order Commandlist words set-order ; : help ( -- ) commands ; : ? ( -- ) commands ; : .s ( -- ) show-dstack ; : disasm ( -- ) ( T addr -- ) t> disasm ; : show ( -- ) show ; : ' ( -- ) ( T -- xt ) t' >t ; : hex ( -- ) hex ; : decimal ( -- ) decimal ; : . ( -- ) ( T x -- ) t> . ; : u. ( -- ) ( T x -- ) t> tu. ; : dump ( -- ) ( T addr len -- ) t> t> swap bounds ?DO cr I .addr space I 8 bounds DO I t_@ 8 .r space LOOP 8 +LOOP ; : udump ( -- ) ( T addr len -- ) temp_hex t> t> swap bounds ?DO cr I .addr space I 8 bounds DO I t_@ addr. space LOOP 8 +LOOP ; \ ... times Host Variable times-count times-count off Commands: : times ( n -- ) t> ?dup IF times-count @ 1 + dup times-count ! 1 + u< stop? or IF times-count off EXIT THEN ELSE stop? ?EXIT THEN >in off ; \ ... watchpoints : #watch ( n -- ) s' t> add-watch ; : watch ( -- ) s' 1 add-watch ; : unwatch ( -- ) s' find-watch IF remove-watch EXIT THEN ." is not watched " ; : unwatch-all ( -- ) watches table-clear ; \ ... debug trace end-trace : breakpoint ( taddr -- ) t> permanent-breakpoints install-breakpoint ; : debug ( -- ) s' >body @ permanent-breakpoints install-breakpoint ; : unbug ( -- ) s' >body @ permanent-breakpoints remove-breakpoint ; : breakpoints ( -- ) 2 spaces ['] .breakpoint permanent-breakpoints table-iterate ; : unbug-all ( -- ) permanent-breakpoints remove-all-breakpoints ; : trace ( -- ) s' >body @ dup set-breakpoint t_execute ; ClassRoot definitions : trace ( -- ) Method name search-classes ?dup 0= IF #unknown throw THEN name>int >body @ dup set-breakpoint t_execute ; Commands: : nest ( H addr nextaddr -- addr nextaddr ) over >branch drop opcode@ call? IF dup nests table-append over target-address install-temporary-breakpoint trigger-resume EXIT THEN ." can nest only on calls - " abort ; : unnest ( H addr nextaddr -- addr addr ) -nest drop dup \ trigger skip of advance-breakpoint trigger-resume ; : end-trace ( H addr nextaddr -- addr addr ) unnest nests table-clear temporary-breakpoints remove-all-breakpoints unbug-all ; \ ... jump after abort Host : next-instruction ( addr -- nextaddr ) temp_silent .instruction ; Commands: : jump ( H addr nextaddr -- addr addr ) \ do not execute current instruction, jump over it and break on next dup >r advance-breakpoint r> dup \ trigger not to automatically advance breakpoint trigger-resume ; : after ( H addr nextaddr -- addr addr ) \ to be used at backward jump in a loop to set a breakpoint \ after the loop install-temporary-breakpoint dup \ trigger not to automatically advance breakpoint trigger-resume ; : abort ( H addr nextaddr -- addr addr ) \ immediately stop debugging end-trace [t'] rclear t_execute 2drop [t'] monitor dup ; Only Forth also definitions : run ( -- ) boot-image handshake debugger ; Reinterpreted @ 0= [IF] .( Use RUN to debug the target system. ) cr [THEN] Target SIMULATION [IF] [ELSE] : type ( addr len -- ) ?FOR ld swap emit 1+ NEXT drop ; [THEN]