disasm.mu4

| This file is part of muforth: https://muforth.dev/
|
| Copyright 2002-2025 David Frech. (Read the LICENSE for details.)

loading PIC18 disassembler

( Disassembler for PIC18 CPU instructions.)

hex

| Words to compile the instruction table.
| ..  acts like 'then'
| match and exact compile a test and a zbranch, followed by code to print
| the opcode name

: (match)   ( op mask match - op f)  push  over and  pop = ;
: (exact)   ( op      match - op f)        over          = ;

( In the disassembler, use .op to print the following opcode name.)
: (.op)  pop @+ push  ( fetch following cfa)  >name type  space ;

compiler
: ..    compile ^  \ then ;
: .op   compile (.op)  .assembler. \chain ;
: match  ( - src)  compile (match)  \ if  \ .op ;
: exact  ( - src)  compile (exact)  \ if  \ .op ;
: multi  ( - src)  compile (match)  \ if        ;  ( doesn't print op)
forth

: label?   ( addr - 0 | 'link -1)  .labels.         find-constant ;
: sfr?     ( addr - 0 | 'link -1)  .equates.        find-constant ;
: target?  ( addr - 0 | 'link -1)  .target-runtime. find-constant-chained ;


: .name   ( 'link)  link>name type ;

( Sign-extend 16-bit word to host number)
: sext  ( w - n)   dup 8000 and if -1_0000 + then ;

( Standard ways of printing different "types".)
: .udec   radix preserve  decimal  (u.) type ;
: .hex    radix preserve  hex       (.) type ;
: .h12    dup 0fff and  .hex ;

( Set and print the current bank address.)
: .bank   ( op - op)  dup [ #bsr-bits ones #] and  8 <<
   dup current-bank !  .hex ;

( Print a data address. Should really be .hex or .h16.)
: .da     dup sfr? if  nip .name ^  then  .hex ;

: .imm6   ( op - op)  dup  03f and  .hex ;
: .imm8   ( op - op)  dup  0ff and  .hex ;
: .nop    ( op - op)  .h12 ;

here  \eq FSR0 ,  \eq FSR1 ,  \eq FSR2 ,
: >fsr  ( index)  cells [ #] + @ ;

: ?fsr  ( da)
   sfr? if  .name ^  then
   error" Weird. FSR not found in equates." ;

: .fsr  ( index)  >fsr ?fsr ;

: .adda   ( op - op)  dup 6 u>> 3 and  .fsr space  .imm6 ;

| This is a defer'd word so that we can change how the stack offset is
| displayed. Since FSRs can only be used to implement an empty descending
| stack - where the FSR points to the byte *below* the last byte pushed -
| it can be helpful to adjust the offset here and in the assembler so that
| it's easier to think about.
|
| However, by default we simply show the offset that's encoded in the
| instruction. The Microchip datasheet suggests showing this as "[n]".

defer .sp-off
-: ( sp-off)  07f and  ." ["  .hex  ." ]" ;  is .sp-off  ( default)

: .access-ram  .ifdef xinst  .sp-off  .else  @ram +  .da  .then ;
: .access-io   [ \eq STATUS >bank #] +  .da ;

( Print f8 as "access bank" address.)
: .access  ( f8)  dup 60 u< if  .access-ram ^  then  .access-io ;

( Print a guess of the address, based on current bank setting)
( XXX Use slashes /addr/ to suggest "banked"?)
: .banked  ( f8)
   current-bank @  +  ." /" .da  ." /" ;

: .af  dup >f8  over 100 and if  .banked  ^ then  .access ;
: .d   dup 200 and 0= if  ." w " then ;

: .afop   ( op - op)      .af ;
: .dafop  ( op - op)  .d  .af ;

( Special-purpose matchers for the most common instructions.)
: (afop)    ( op      match - op f)        over fe00 and = ;
: (dafop)   ( op      match - op f)        over fc00 and = ;

compiler
:  afop  ( - src)  compile  (afop)  \ if  \ .op  compile .afop ;
: dafop  ( - src)  compile (dafop)  \ if  \ .op  compile .dafop ;
forth

: .bitop   dup  9 >>  7 and  ( bit#)  u.  .af ;

: .movff   dup .h12 space  cell* .h12 ;

( Extended instructions; "s" is 7 bit offset from fsr2, aka sp)
: .movsf   dup .sp-off  cell* .h12 ;
: .movss   dup .sp-off  cell* .sp-off ;

: >offset  ( op #bits - op offset)
   1- push  dup  r@ ones and  ( op unsigned-bits)
           over pop mask and  ( op unsigned-bits sign-bit)  -  2* ;

( XXX .haddr might print too many digits!)
: .dest  ( op #bits - op)
   >offset  p @ +  dup ea !
   dup label?  if  nip .name ^  then
   dup target? if  nip .name ^  then
   .haddr ;

: .rjmp   #11 .dest ;

( Print jmp opcode, including a _single_ trailing space.)
( Order is ZCVN, bit set, then bit clear.)
: .jop  ( op - op)
   z" bz  bnz bc  bnc bv  bnv bn  bnn "  over 8 >>  7 and  2* 2*  +
   4 -trailing  1+ type ;

( NOTE: shred hasn't printed the opcode; we have to do that.)
: .cond  ( op - op)   .jop  8 .dest ;

: .ljmp  ( op - op)   dup 0ff and  ( low)  cell* 0fff and  8 << +  2*  .dest ;

: .lda  ( op - op)
   dup 4 u>> 3 and  .fsr space
   dup 0f and  ( high)  [ #bsr-bits 4 + #] <<
   cell* [ #bsr-bits 4 + ones #] and  +  .da ;

: shred  ( op - op)
( All the instructions!)

        0000 exact nop

..      0003 exact sleep
..      0004 exact clrwdt
..      0005 exact push
..      0006 exact pop
..      0007 exact daw

..      0008 exact prog@   ( tblrd*)    ( read program memory)
..      0009 exact prog@+  ( tblrd*+)   ( read program memory, post incr)
..      000a exact prog@-  ( tblrd*-)   ( read program memory, post decr)
..      000b exact prog+@  ( tblrd+*)   ( read program memory, pre incr)

..      000c exact prog!   ( tblwt*)    ( write program memory)
..      000d exact prog!+  ( tblwt*+)   ( write program memory, post incr)
..      000e exact prog!-  ( tblwt*-)   ( write program memory, post decr)
..      000f exact prog+!  ( tblwt+*)   ( write program memory, pre incr)

..      0010 exact iret       ( return from interrupt; restore from stack)
..      0011 exact iret.s     ( return from interrupt; restore from shadow regs)

..      0012 exact ret        ( return from subroutine; restore from stack)
..      0013 exact ret.s      ( return from subroutine; restore from shadow regs)

..      00ff exact reset

.. ff00 0100 match bank   .bank

..      0200 afop  mul
..      0400 dafop dec

( XXX create a special category for these? like afop and dafop?)
.. ff00 0800 match negi   .imm8
.. ff00 0900 match ori    .imm8
.. ff00 0a00 match xori   .imm8
.. ff00 0b00 match andi   .imm8
.. ff00 0c00 match reti   .imm8
.. ff00 0d00 match muli   .imm8
.. ff00 0e00 match ldi    .imm8
.. ff00 0f00 match addi   .imm8

..      1000 dafop or
..      1400 dafop and
..      1800 dafop xor

..      1c00 dafop com

..      2000 dafop adc
..      2400 dafop add
..      2800 dafop inc
..      2c00 dafop decsz

..      3000 dafop rrc
..      3400 dafop rlc
..      3800 dafop rot4
..      3c00 dafop incsz

..      4000 dafop ror
..      4400 dafop rol

..      4800 dafop incsnz
..      4c00 dafop decsnz

..      5000 afop ld
..      5200 afop tst

..      5400 dafop rsbb
..      5800 dafop sbb
..      5c00 dafop sub

..      6000 afop cmpslt
..      6200 afop cmpseq
..      6400 afop cmpsgt
..      6600 afop tstsz

..      6800 afop set
..      6a00 afop clr
..      6c00 afop neg
..      6e00 afop st

.. f000 7000 match btog     .bitop
.. f000 8000 match bset     .bitop
.. f000 9000 match bclr     .bitop
.. f000 a000 match btstss   .bitop
.. f000 b000 match btstsc   .bitop

.. f000 c000 match movff    .movff

.. f800 d000 match rjmp     .rjmp
.. f800 d800 match rcall    .rjmp

.. f800 e000 multi          .cond

| --------------------------------------------------------------------------
| Extended instructions: e800 to ebff, plus 0014 (callw)
| --------------------------------------------------------------------------
.ifdef xinst

..      0014 exact callw

.. ff00 e800 match adda     .adda
.. ffc0 e8c0 match addulnk  .imm6

.. ff00 e900 match suba     .adda
.. ffc0 e9c0 match subulnk  .imm6

.. ff00 ea00 match pushi   .imm8

.. ff80 eb00 match movsf   .movsf
.. ff80 eb80 match movss   .movss

.then  ( ifdef xinst)
| --------------------------------------------------------------------------
| End of extended instructions
| --------------------------------------------------------------------------

.. ff00 ec00 match call     .ljmp
.. ff00 ed00 match call.s   .ljmp

.. ffc0 ee00 match lda   .lda

.. ff00 ef00 match jmp   .ljmp

.. f000 f000 match nop   .nop    ( this is an extension word; show its contents)

.. ." *unimplemented*"

( That's all folks!)
;

( Support for interactive disassembly.)
: dis+  ( a - a' 0)  drop  p @  0 advance  0 ;
: dis-  ( a - a' 0)            -4 advance  0 ;  ( back up a bit)

( The workhorse.)
: 1dis  ( a)
   dup target? if
      over _addr .nesting space  ." target " .name
   then
   dup label? if
      over _addr .nesting space  ." label " .name
   then
   dup .addr  .nesting space
   dup ea !  ( jump to self)
   p !  cell*  ( op)  dup .hcell_  space
   shred  drop ;