home *** CD-ROM | disk | FTP | other *** search
Text File | 1995-09-21 | 21.1 KB | 942 lines | [ TEXT/MSET]
\ This module handles decompilation and debugging. \ June 92 - fixed trap handling for user mode / virtual memory. false value INMOD? \ true if we're decompiling/debugging \ a module objPtr THEMOD class_is module \ This is the module we're \ decompiling/debugging handle THEHDL :class MOD-DIC-MARK super{ dic-mark } var MODCXT var CXTOFFS var MODPTR :m DUMP: ." modPtr: " get: modPtr .h cr ." modCxt: " get: modCxt .h cr ." cxtOffs: " get: cxtOffs .h cr ;m :m SELECTMOD: \ ( ^mod -- ) -> theMod \ Fails if not a module object pointer load: theMod \ Ensure module is loaded handle: theMod put: theHdl nptr: theHdl put: modPtr get: modPtr size: theHdl + 32 - dup put: modCxt 4- @ put: cxtOffs ;m :m SETTOMODTOP: #threads FOR get: modCxt i 2 << + displace get: cxtOffs - i to: links NEXT setc: self ;m :m NEXTINMOD: { \ lfa -- lfa } get: current at: links dup get: modPtr <= IF drop 0 exit then dup -> lfa displace get: current to: links setc: self lfa ;m :m FINDINMOD: { s255 \ addr len lfa -- cfa T | s255 F } s255 count -> len -> addr addr len upper setToModTop: self BEGIN nextinMod: self -> lfa lfa nif s255 false exit then lfa l>name n>count addr len s= IF ( Found it! ) lfa link> true exit THEN AGAIN ;m ;class mod-dic-mark MM : IN ' ( module cfa ) >obj selectMod: MM lock: theMod true -> inMod? theMod use_module ; : NOTIN false -> inMod? ; : SET_MODBASE \ Be awfully careful doing this!! inMod? IF base: theMod 32766 + ELSE -1 THEN -> modbase ; : @ABSM { ^rel-addr \ svModbase -- abs-addr } modbase -> svModbase set_modbase ^rel-addr @abs svModbase -> modbase ; : (GET_CFA) { \ svModbase -- cfa } Mword dup c@ over + c@ & : = IF ( method for a class ) hash recurse \ Recursive call to get class chkClass modbase -> svModbase set_modbase findm nip svModbase -> modbase ELSE inMod? IF \ in a module findinmod: MM nif true abort" not found" then ELSE \ in main dic nilP -> theMod find 0= abort" not found" THEN THEN ; : GET_CFA (get_cfa) ( false -> inMod? ) ; \ ========== DECOMPILER ========== 0 value LOCATION \ Holds the current address in the parameter \ field of the definition being decompiled. 0 value THIS_CFA \ Holds the current cfa. 0 value THAT_CFA \ Holds the cfa called by current instruction 2 value GIN \ "Go in". Holds the current amount to indent. 10 value SAVEBASE \ Saves the number base. 0 value #P \ Number of named parms/local vars. false value CALL? \ True if we're processing a call. 0 value LAST_OBJ \ The last object referenced in debugging : .LOCN \ Prints the current value of LOCATION and the value of the \ word there. location 6 .r location w@ 5 .r location 2+ w@ 5 .r ; : DIN \ "Do indent". Prints the location and then indents. setFwind cr .locn gin spaces location addr>curs drop ; : NXT> \ ( -- n ) Fetches the longword where LOCATION points, and \ updates LOCATION. location w@ 2 ++> location ; : .NO dup . dup decimal . hex bl & ~ within? if emit else drop then ; : .1 1 .r ; : .D 4 7 within? IF ." parm/loc# " 7 swap - .1 EXIT THEN dup 3 = IF drop ." i" EXIT THEN ." D" .1 ; : .A case[ 5 ]=> ." MP" [ 6 ]=> ." SP" [ 7 ]=> ." RP" default=> ." A" .1 ]case ; : STRING? that_cfa 2- w@x -18 = ; : .NAME { cfa -- } cfa .id call? 0EXIT cfa ['] (defer) = if 4 ++> location exit then string? if space & " emit location count 2dup type & " emit + align -> location then ; : ?.PARAMETERS \ ( cfa -- ) Prints any parameters associated with \ this word. drop ; : ?.VALUE \ ( cfa -- ) Prints a value or any other useful (?) \ information associated with this word. drop ; : .WORD \ ( cfa -- ) Prints the name of the word with the given cfa. ( ?mcf ) dup .name dup ?.parameters ?.value ; : SHOW_CLASS { addr \ svModbase -- } modbase -> svModbase set_modbase addr >obj .class: object svModbase -> modbase ; : ?TYP { addr -- addr } addr 2- w@x case[ objCode ]=> ." object of type " addr show_class [ valCode ]=> ." value " addr @ .no default=> drop ]case ; local IDENTIFY? { \ svModbase op mode reg reg1 disp incr -- b } : GETMODE® op $ 7 and -> reg op $ 38 and 3 >> -> mode ; : GETADDR \ ( -- addr ) getMode&Reg mode 5 = nif 0 exit then \ If not d(An), just rtn zero reg \ Reg case[ 3 ]=> lobase [ 4 ]=> hibase [ 5 ]=> theMod nilP <> if base: theMod 32766 + else 0 then default=> drop 0 ]case location w@x + \ Add displ 2 ++> location ; : d(An) getAddr reg 2 = if ." ivar offs " . else cfa? if dup .id space then dup .h ?typ then ; : TRYLIT reg 4 <> ?exit location @ decimal . hex 4 ++> location ; : .ADDR getMode&Reg mode case[ 0 ]=> reg .d [ 1 ]=> reg .a [ 2 ]=> ." (" reg .a ." )" [ 3 ]=> ." (" reg .a ." )+" [ 4 ]=> ." -(" reg .a ." )" [ 5 ]=> d(An) [ 7 ]=> tryLit default=> drop ]case ; : SEE_CASE ; : DO_JSR call? IF ." JSR " else ." JMP " THEN getAddr dup -> that_cfa .name \ that_cfa ['] (case) = IF see_case THEN ; : DO_BSR ." BSR " op $ FF and -> disp 0 -> incr disp 0= if location w@x -> disp 2 -> incr else disp $ 7F > if $ FFFFFF00 or> disp then then disp location + dup -> that_cfa .name incr ++> location ; : DO_BCC ." BRANCH" op $ FF and nif 2 ++> location then ; : DO_LONG# location @ .no 4 ++> location ; : DO_SHORT# op $ FF and .no 2 ++> location ; : DO_LEA op $ E00 and 9 >> -> reg1 op $ 41D2 = if ." self" exit then reg1 NIF getAddr reg 2 = if ." ivar offs " . else ." object " dup -> last_obj 8 - .name then ELSE ." LEA " .addr ." -> " reg1 .a THEN ; : DO_MOVE ." MOVE " .addr ." -> " op 3 >> $ 38 and op 9 >> $ 7 and or -> op .addr ; : 1OP \ ( addr len ) type 2 spaces .addr ; : DO_ADDQ op $ 100 and nif ." ADDQ #" else ." SUBQ #" then op 9 >> 7 and dup nif drop 8 then . ." ," .addr ; : DO_MOVEM op $ FF00 and $ 4800 = if ." MOVEM regs," .addr else ." MOVEM " .addr ." ,regs then 2 ++> location ; : DO_+ETC op $ F000 and case[ $ D000 ]=> ." ADD " true [ $ 9000 ]=> ." SUB " true [ $ C000 ]=> ." AND " true [ $ 8000 ]=> ." OR " true [ $ B000 ]=> op $ 100 and if ." XOR " else ." CMP " then true default=> drop ." trap " op .h false ]case 0exit op 9 >> 7 and -> reg1 op $ 100 and if reg1 .d ." -> " .addr else .addr ." -> " reg1 .d then ; : DO_IMM op 8 >> $ F and case[ 0 ]=> ." OR" [ 2 ]=> ." AND" [ 4 ]=> ." SUB" [ 6 ]=> ." ADD" [ $ A ]=> ." XOR" default=> " ???" ]case op 6 >> 3 and case[ 0 ]=> ." .B " location w@x 2 ++> location [ 1 ]=> ." .W " location w@x 2 ++> location default=> ." .L " location @ 4 ++> location ]case ." #" .h ." -> " .addr ; :loc IDENTIFY? true location w@ -> op 2 ++> location false -> call? 0 -> that_cfa op $ FFC0 and $ 4E80 = if true -> call? do_jsr exit then op $ FFC0 and $ 4EC0 = ( JMP) if do_jsr exit then op $ FF00 and $ 6100 = if true -> call? do_bsr exit then op $ F000 and $ 6000 = if do_bcc exit then op $ 29BC = if do_long# exit then op $ FF00 and $ 7400 = if do_short# exit then op $ 2D16 = if ." DUP" exit then op $ F000 and $ 2000 = if do_move exit then op $ 4E75 = if ." EXIT" exit then op $ 588E = if ." DROP" exit then op $ F000 and $ 5000 = if do_addq exit then op $ F1C0 and $ 41C0 = if do_lea exit then op $ FF00 and dup $ 4800 = swap $ 4C00 = or if do_movem exit then op 12 >> 8 $ D within? nip if do_+etc exit then op $ F000 and nif do_imm exit then op $ FF00 and case[ $ 4200 ]=> " CLR" 1op [ $ 4A00 ]=> " TST" 1op default=> 2drop false ]case ;loc : .INST \ Decompiles the next instruction in the current definition. din identify? drop ; 0 value CL_DEPTH : CRI \ CR plus indent cr cl_depth 2+ spaces ; getSelect PRINT: constant printID : .IVLIST { ^obj ^class \ svModbase thisivar ioffs ^cl -- } ^class ifa displace -> thisivar BEGIN thisivar @ 0>= IF \ Traverse n-way for superclasses BEGIN thisivar @ 0EXIT thisivar @absM -> ^cl cri ." superclass " ^cl .id ^cl ['] object = NIF 2 ++> cl_depth ^obj ^cl recurse 2 --> cl_depth THEN 4 ++> thisivar AGAIN ELSE \ Ordinary ivar thisivar 8 + @absM -> ^cl cri thisivar 12 + w@ -> ioffs ." ivar offset " ioffs . ^cl ['] object = IF ." (bytes)" ELSE ." class " ^cl .id 2 spaces ^obj ioffs + printID ^cl modbase -> svModbase set_modbase findm svModbase -> modbase >r + r> ex-method THEN thisivar 4+ displace -> thisivar THEN AGAIN ; : .SUPERS { ^class \ svModbase thisivar ^cl -- } \ This code is similar to .IVARS above, since we find the superclasses by traversing the ivar chain to find the n-way for the supers. But of course we don't print any ivar information. ^class ifa displace -> thisivar begin thisivar @ 0> if \ Traverse n-way for superclasses begin thisivar @ 0exit thisivar @absM -> ^cl cri ." superclass " ^cl .id ^cl ['] object = nif 2 ++> cl_depth ^cl recurse 2 --> cl_depth then 4 ++> thisivar again else \ Ordinary ivar thisivar 8 + @absM -> ^cl thisivar 4+ displace -> thisivar then again ; ' null vect VV local .WHATEVER { cfa \ ^obj svModbase -- b } : .OBJECT cfa ?typ 2 spaces modbase -> svModbase set_modbase cfa >obj -> ^obj \ Note: we've altered modbase, but print: [ ^obj ] \ it's OK here since none of these ^obj dup >class \ words are local to this module. svModbase -> modbase 0 -> cl_depth .ivlist ; : .CLASS ." Class " cfa dup .id .supers ; : .DEFN ; : .VALUE cfa ?typ ; : .VECT ." Vect -> " 4 ++> cfa \ Step past JSR doVect cfa @ nif 4 ++> cfa ." default: " location cfa -> location identify? drop -> location else cfa @abs .id then ; :loc .WHATEVER \ { cfa -- b } cfa 2- w@x case[ objcode ]=> .object false [ classcode ]=> .class false [ ' .inst 2 - w@x ]=> .defn true [ ' location 2 - w@x ]=> .value false [ ' vv 2 - w@x ]=> .vect false default=> ." ???" drop false ]case ;loc : START { cfa \ ok? -- ok? } \ Sets things up for a new decompilation. \ Returns true if we are to continue. true -> ok? cfa -> location \ location locate_src 2 ++> gin din ." : " cfa dup .id >name c@ 64 and if ." IMMEDIATE" then ok? if cfa -> location else ( back to where we were ) -> location -2 ++> gin then ok? ; : FINISH -2 ++> gin gin if location locate_src then ; : DONE? ( -- b ) location w@ $ 4E75 = drop false ; : (SEE) { cfa \ svBase svLocation next? stop? -- } \ Exported. Decompiles the word with the given cfa. base -> svbase hex cfa locate_src setFwind cfa .whatever IF cfa start ELSE false THEN NIF svbase -> base EXIT THEN location @ -> this_cfa .inst BEGIN true -> next? false -> stop? \ Do it unless we find out \ otherwise key & a & z within? if bl - then case[ & Q ]=> sp0 sp! svbase -> base notin cl cr quit [ 13 ]=> location -> svLocation that_cfa if 2 spaces that_cfa (see) then svLocation -> location [ & U ]=> true -> stop? false -> next? [ & 2 ]=> 2 ++> location [ & P ]=> 8 --> location [ $ 1E ]=> 1up false -> next? [ $ 1F ]=> 1dn false -> next? [ $ 1C ]=> 1Lft false -> next? [ $ 1D ]=> 1rt false -> next? [ $ 37 ]=> home false -> next? [ $ 31 ]=> end false -> next? [ $ 39 ]=> defnUp false -> next? [ $ 33 ]=> defnDn false -> next? default=> drop ]case next? if location @ -> this_cfa .inst then done? stop? or until ( Show last word ) next? IF .inst THEN finish svbase -> base ; : SEE 0 -> gin get_cfa (see) ; \ ======= DEBUGGER ======= variable PROGREGS 64 allot 0 value CURRMODBASE 10 array PCSTK 0 value PC# 0 value PC \ Current user PC on brkpt or trace trap 0 value STATUS \ Current user status word ditto 0 value BP \ Current breakpoint address 0 value BPCONT \ Contents of that location 0 value IBP \ Initial breakpoint address 0 value IBPCONT \ Contents 0 value TTRAPVAL \ Original contents of T trap vector false value DONE? false value GETOUT? false value INITIALIZED? false value IN_CASE? false value DEBUG_STARTED? : PUSHPC PC# to: PCstk 1 ++> PC# ; : POPPC -1 ++> PC# PC# at: PCstk ; : BPON \ ( addr -- ) -> BP BP w@ -> BPcont $ 4E40 BP w! patches_done ; : BPOFF BPcont BP w! patches_done ; :code TOPROG \ Returns to the user prog with tracing off. loc movem dic[progRegs],d0-d7/a0-a6 move.l rel[PC],-(a7) ; A5 won't be right for debugmod move.w 2(rel[status]),ccr rts ;code : UP \ End tracing current definition; resume next level up. PC# if cr ." *** going up ***" popPC BPon true -> getout? else cr ." *** at top already - maybe do a G instead? **** then ; : DOWN cr ." *** going down ***" location pushPC ; : X (lit-str) 99 ; \ A dummy definition - not executed : STEP_CASE true -> in_case? ; \ Inhibits display till we get into the stub : NXT_CASE \ ( -- b ) location w@ $ 4ED1 = if cr ." *** doing CASE[ selection:" false exit then location w@ $ 4EF0 = if cr ." *** doing SELECT{ selection:" false exit then true ; : STEP call? 0exit \ If not a call, continue normal trace that_cfa case[ ' @(ip) ]=> 4 ++> location true [ ' w@(ip) ]=> 2 ++> location true \ [ ' (case) ], [ ' (sel) ]=> step_case false default=> drop true ]case 0exit location BPon true -> getout? ; : .DEPTH ." (" depth 2 .r ." )" ; : .STK { \ svCurs -- } depth 0<= ?exit curs -> svCurs -curs 20 out - spaces 0 depth 4 min 2- do i pick 8 .r -1 +loop svCurs -> curs ; : .RG \ ( addr -- ) @ 0 <# # # # # # # # # #> type ; : .D&A { cnt -- } & D emit cnt . 3 spaces cnt 4* progRegs + dup .rg 10 spaces 32 + & A emit cnt . 3 spaces .rg ; : .REGS base hex 8 0 do cr i .d&a loop -> base ; false value RES? : *OK & * emit ok ; : DO_F { \ svState svCurs -- } cr OK state -> svState curs -> svCurs +curs begin 0 -> state false -> res? query interpret *OK res? until svState -> state svCurs -> curs ; : RESUME true -> res? ; : UNBUG initialized? 0exit notin cl BPoff TtrapVal if TtrapVal $ 24 ! then false -> initialized? drop: debugmod ; ' null vect SHOWME : SHOW \ ( cfa -- ) -> showme ; local DISPLAY { \ svBase svCurs svLoc next? reDisp? -- } : DISP1 setFwind cr 0 -> out -curs .locn 2 spaces identify? drop 40 out - dup 0< IF drop cr 0 -> out 40 then spaces .depth .stk BEGIN true -> next? false -> reDisp? key & a & z within? if bl - then case[ & N ]=> true -> done? BPoff iBP -> BP iBPcont -> BPcont [ & G ]=> true -> done? true -> getout? BPoff TtrapVal $ 24 ! cr decimal svCurs -> curs [ & Q ]=> cr decimal svCurs -> curs unbug quit [ & F ]=> do_F true -> reDisp? svLoc -> location [ & R ]=> .regs false -> next? [ & O ]=> last_obj ?dup if dump: ** then false -> next? [ & S ]=> showme false -> next? [ 13 ], [ & D ]=> down [ & U ]=> up [ $ 1E ]=> 1up false -> next? [ $ 1F ]=> 1dn false -> next? [ $ 1C ]=> 1Lft false -> next? [ $ 1D ]=> 1rt false -> next? [ $ 37 ]=> home false -> next? [ $ 31 ]=> end false -> next? [ $ 39 ]=> defnUp false -> next? [ $ 33 ]=> defnDn false -> next? default=> drop step ]case next? UNTIL ; :loc DISPLAY \ { \ svBase svCurs svLoc next? reDisp? -- } debug_started? NIF ( selectDW select: fWind ) true -> debug_started? THEN in_case? IF nxt_case dup -> in_case? EXIT THEN base -> svBase hex curs -> svCurs -curs false -> done? false -> getout? location -> svLoc location addr>curs drop BEGIN location @ -> this_cfa disp1 reDisp? NUNTIL ;loc :code FIXMODE move A5,dic[tempA5] move rel[currModbase],A5 movem d0-d7/a0-a6,dic[progRegs] move dic[tempA5],52(dic[progRegs]) move.l 6(a7),dic[PC] move.w 4(a7),2(dic[status]) move.l (a7)+,2(a7) bclr #7,(a7) rte ;code :code BPTLOC \ We come here on a breakpoint trap bsr rel[fixMode] subq #2,dic[PC] ; Replace instrn at bkpt and move dic[PC],a0 ; don't forget to execute it! move.w 2(dic[BPcont]),(a0) jsr dic[patches_done] move a0,dic[location] ; This is location for display bsr dic[display] ; display everything dc.w $4E42 ; TRAP 2 to set T bit & rtn ;code :code TRACELOC bsr rel[fixMode] tst dic[done?] bne.s done move dic[PC],dic[location] ; Next instrn is locn for displ bsr dic[display] tst dic[getout?] bne dic[toProg] dc.w $4E42 ; TRAP 2 to set T bit & rtn done jsr dic[cr] ; DONE? set - we're handling move.l #10,dic[base] ; it the next time in, so move dic[BP],a0 ; the BP gets replaced. move.w #$4E40,(a0) ; Replace BP for next time jsr dic[patches_done] bra dic[toProg] ;code :code TON \ Returns to user's prog with tracing on. \ We set the TRAP 2 vector pointing here, since \ we need to be in supervisor mode to set the T bit. movem dic[progRegs],d0-d7/a0-a6 move.l rel[PC],2(a7) move.w 2(rel[status]),(a7) bset #7,(a7) rte ;code : DEBUG \ Exported. 0 -> PC# false -> debug_started? get_cfa dup locate_src initialized? nif lock: debugMod \ We must be locked since we'll modbase -> currModbase \ be called from a trap ['] bptLoc $ 80 ! \ We use TRAP #0 as our debug brkpt ['] Ton $ 88 ! \ We use TRAP #2 to turn T bit on $ 24 @ -> TtrapVal \ Save T trap vector (-> Macsbug?) ['] traceLoc $ 24 ! \ and set it to our routine TraceLoc true -> initialized? then ( cfa ) BPon BP -> iBP BPcont -> iBPcont \ Save initial BP details ; \ ======== PROFILER ========= 0 value LINECNT 0 value PRFPTR 0 value LAST_PRFPTR 0 value SRC_POS 0 value SRC_LIM string+ $PRF string+ $SRC : ADDR>PRF { addr \ offs -- } addr filestart_dp - -> offs reset: $prf BEGIN len: $prf 0<= ?EXIT ^1st: $prf w@ offs = ?EXIT \ If found 14 skip: $prf 1 ++> lineCnt AGAIN ; : FIND_DEFN_START { addr -- } 0 -> lineCnt addr addr>prf <step: $prf delete: $prf addr addr>curs dup >pos: $src >lim: $src ; : FIND_DEFN_END { \ offs addr -- } reset: $prf len: $prf 0EXIT ^1st: $prf w@ -> offs \ Initial offset 14 skip: $prf \ Skip line where defn starts BEGIN len: $prf 0EXIT ^1st: $prf -> addr addr w@ offs > IF addr w@ -> offs ELSE true addr 5 + c! THEN addr 4+ c@ ?EXIT 14 skip: $prf AGAIN ; : COUNT_THIS { addr -- } addr addr>prf ^1st: $prf -> prfPtr len: $prf 0EXIT prfPtr 2+ w@ addr w! \ Replace instruction at breakpoint patches_done 1 prfPtr 6 + +! \ Increment execution count last_time \ Increment time IF now last_time - last_prfPtr 10 + +! THEN prfPtr -> last_prfPtr ; :code PRFLOC \ We come here on a profile trap push glob[ticks] move A5,dic[tempA5] move rel[currModbase],A5 pop dic[now] movem d0-d7/a0-a6,dic[progRegs] move dic[tempA5],52(dic[progRegs]) move.l 2(a7),dic[PC] move.w (a7),2(dic[status]) lea continue,a0 move.l a0,2(a7) bclr #7,(a7) rte continue subq #2,dic[PC] move dic[PC],a0 move a0,dic[this_BP] push a0 bsr dic[count_this] \ lea dic[prfloc],a0 \ move a0,$24 dc.w $4E42 ; TRAP 2 to set T bit & rtn ;code :code PRFTRACE ; Now we've executed the inst at bkpt bsr rel[fixMode] \ move dic[ttrapval],$24 \ call debugger move dic[this_BP],a0 move.w #$4E41,(a0) jsr dic[patches_done] movem dic[progRegs],D0-D7/A0-A6 move.l rel[PC],-(a7) ; Set up for RTS move.l glob[ticks],dic[last_time] move.w 2(rel[status]),ccr rts ;code : SET_BRKPTS { \ addr -- } reset: $prf BEGIN len: $prf NIF patches_done EXIT THEN ^1st: $prf 5 + c@ NIF ^1st: $prf w@ filestart_dp + -> addr addr w@ ^1st: $prf 2+ w! $ 4E41 addr w! THEN 14 skip: $prf AGAIN ; : PROFILE { \ cfa -- } lock: debugMod \ We'll be entering via traps! modbase -> currModbase ['] prfLoc $ 84 ! \ We use TRAP #1 as our profile brkpt $ 24 @ -> TtrapVal \ Save T-bit trap vector \ ['] prfTrace $ 24 ! \ and reset it to point to PrfTrace ['] Ton $ 88 ! \ We use TRAP #2 to turn T bit on true -> initialized? get_cfa -> cfa cfa locate_src prof_str ->: $src ->: $prf size: $prf 0= ?error 188 \ No log file found - needed for profile cfa find_defn_start find_defn_end delete: $prf set_brkpts reset: $prf lock: $prf ; : SHOWP { \ addr loc -- } reset: $prf cl ." exec ticks" cr 0 -> out BEGIN len: $prf WHILE ^1st: $prf -> addr addr 5 + c@ NIF addr w@ filestart_dp + -> loc addr 2+ w@ loc w! addr 6 + @ ?dup IF 6 .r addr 10 + @ 8 .r THEN THEN 18 out - spaces nextline?: $src IF get: $src type cr 0 -> out THEN 14 skip: $prf REPEAT unbug ; 
