;; PIC18 code generator

(module pic18-compiler mzscheme

  (require-for-syntax
   "pattern-utils.ss")
  
  (require
   (lib "match.ss")
   "composite.ss"
   "compiler.ss"
   "macro.ss"
   "cat.ss"
   
   "comp-utils.ss"
   "state.ss"
   "assembler.ss"

   "binary-utils.ss"
   "list-utils.ss"
   
   "pattern.ss"
   "pattern-meta.ss"

   "badnop.ss"
   "meta.ss"
   )


  ;; Let's start with some minor extensions to compiler.ss
  


  ;; Extensions to the base word set.
  
  (compositions
   (badnop) badnop:

   ;; Run post processing optimizations. this converts intermediate
   ;; assembler representation to something the assembler understands.
 
   (post        '(pseudo      ;; compile pseudo ops
                  opti-save)  ;; dup save elimination
                opti-passes))
 


  ;; Simulation.

  (compositions
   (badnop) base:

   (truncate #xFF and) ;; truncate data word

   ;; these are infinite precision
   (>>        1 >>>)  
   (<<        1 <<<)
   (2/        1 >>>)
   
   ;; these make no sense in infinite precision so are truncated
   (rot<<     truncate dup 7 >>> swap 1 <<< or truncate)
   (rot>>     truncate dup 7 <<< swap 1 >>> or truncate)


   )



  ;; *** CODE GENERATOR ***

  ;; These are asm-transforms generators, applied to regular classes
  ;; of instructions and optimisations.

  ;; UNARY
           
  ;; Unary operations can be combined with memory fetch.
  (asm-meta-pattern  unary (word opcode)
                     (([movf f 0 0] word) ([opcode f 0 0]))
                     ((word)              ([opcode 'WREG 0 0])))

  ;; Unary operations storing result in variable.
  (asm-meta-pattern  unary->mem (word opcode)
                     (([qw f] word)       ([opcode f 1 0])))
  
  (unary (macro)
         (1+     incf)
         (1-     decf)
         (rot<<c rlcf)
         (rot>>c rrcf)
         (rot<<  rlncf)
         (rot>>  rrncf)
         (swap-nibble
                 swapf))
  
  (unary->mem (macro)
              (1-! decf)
              (1+! incf))

  ;; BINARY

  (define (wrap: . args)
    (apply append (map wrap args)))

  (define (numbers? . args)
    (if (null? args #t)
        (and (number? (car args))
             (apply numbers? (cdr args)))))
            
  ;; (1) binary ops combine with memory fetch: "123 @ +". only for commutative ops!
  (asm-meta-pattern binary (word metafn l-opcode s-opcode)
    (([qw a ] [qw b] word)         ([qw (wrap: a b 'metafn)]))
    (([l-opcode a] [qw b] word)    ([l-opcode (wrap: a b 'metafn)]))
    (([qw a] word)                 ([l-opcode a]))
    (([save] [movf a 0 0] word)    ([s-opcode a 0 0])) ;; (1)
    ((word)                        ([s-opcode 'POSTDEC0 0 0])))

  (asm-meta-pattern binaryc (word s-opcode)
    (([save] [movf a 0 0] word)    ([s-opcode a 0 0])) ;; (1)
    ((word)                        ([s-opcode 'POSTDEC0 0 0])))

  ;; (1) like "dup 123 +!"
  (asm-meta-pattern binary->mem (word opcode)
    (([dup] [qw f] word)  ([opcode f 1 0]))  ;; (1)
    (([qw f] word)        ([opcode f 1 0] [drop])))

  (binaryc (macro)
           (++ addwfc))
  
  ;; FIXME: add error handling for the patterns that are not defined:
  (binary (macro)
          
          (+    +    addlw  addwf)
;;          (++   #f   #f     addwfc)   ;; no carry flag emulated, and no literal version
          (and  and  andlw  andwf)
          (or   or   iorlw  iorwf)
          (xor  xor  xorlw  xorwf)
          
          ;; These have compile time eval only, currently no
          ;; target equivalents defined.

          (pow pow   #f     #f)
          (>>> >>>   #f     #f)
          (<<< <<<   #f     #f)
          (/   /     #f     #f)
          (*   *     #f     #f))


   ;; Binary operations storing result in variable.
   (binary->mem  (macro)
                 (--!  subwfb)
                 (-!   subwf)
                 (++!  addwfc)
                 (+!   addwf)
                 (and! andwf)
                 (or!  iorwf)
                 (xor! xorwf))

  
  ;; RPN ASSEMBLER    
  (asm-meta-pattern  asm-f00 opcode (([qw f] opcode) ([opcode f 0 0])))
  (asm-meta-pattern  asm-f0  opcode (([qw f] opcode) ([opcode f 0])))
  (asm-meta-pattern  asm-    opcode ((opcode) ([opcode])))
  

  (asm-f00  (macro)
            movf xorwf andwf iorwf
            subwf subfwb addwf addwfc
            comf rrcf rlcf rrncf rlncf
            )

  (asm-     (macro)
            push pop sleep reset nop clrwdt daw
            tblrd* tblrd*- tblrd*+
            tblwt* tblwt*- tblwt*+)
  
  (asm-f0   (macro)
            cpfseq cpfsgt cpfslt
            clrf setf
            movwf mulwf)

  (asm-     (macro)
            mark org-pop)

  
  

  ;; This is the bulk of the PIC18 peephole optimizing code
  ;; generator. Each line is a list (pattern expr), expressed in
  ;; RPN. The function name is at the end of the pattern. The
  ;; expression is a sequence of assembler instruction.

  ;; Note that this only 'emulates' algebraic types. You can't use
  ;; scheme functions to generate the assembler instructions, only to
  ;; generate the arguments to the 'type constructors'.

  ;; The syntax ",xxx" in type position means: match any instruction
  ;; type, and bind the variable xxx to the type name. The syntax
  ;; ",xxx" in expression position means: create a type represented by
  ;; the symbol bound to variable xxx.
  
  (asm-transforms (macro)

   ;; DEBUG
   ((,word backspace) ())                  

   ;; POST PROCESSING
                  
   
   ;; Convert pseudo asm -> real asm
   (([qw a] pseudo)   ([save] [movlw a]))
   
   ;; (([cw a] pseudo)   ([r 'rcall a]))
   ;; (([jw a] pseudo)   ([r 'bra a]))
   (([cw a] pseudo)   ([jsr 0 a]))
   (([jw a] pseudo)   ([jsr 1 a]))
   
   ((pseudo)          ())

   ;; 'save' elimination
   (([drop] [save] opti-save)              ())
   (([,op 'POSTDEC0 0 0] [save] opti-save) ([,op 'INDF0 1 0]))  ;; NEED SYNTAX
   (([save] opti-save)                     ([dup]))
   ((opti-save)                            ())


   ;; SUBTRACT
   ;; special because it's not commutative + sublw has arguments swapped!
   ;;   (-    -    sublw  subwf)
   ;;   (--   #f   #f     subfwb)

   (([qw a ] [qw b] -)             ([qw (wrap: a b '-)]))
   (([addlw a] [qw b] -)           ([addlw (wrap: a b '-)]))
   (([qw a] -)                     ([addlw (wrap: a -1 '*)]))
   (([save] [movf a 0 0] -)        ([bpf 0 'STATUS 0 0] [subfwb a 0 0])) ;; there's no subfw
   ((-)                            ([subwf 'POSTDEC0 0 0]))

   (([save] [movf a 0 0] --)       ([subfwb a 0 0])) ;; (1)
   ((--)                           ([subwfb 'POSTDEC0 0 0]))
   

   ;; FETCH
   (([movlw a] @)  ([movf a 0 0]))  ;; register fetch
   (([qw a] @)     ([save] [movf a 0 0]))
   ((@)            ([cw '@]))


   ;; STORE
   (([qw 0]  [qw a] !) ([clrf a 0]))          ;; these 2 better done after assembly..
   (([qw -1] [qw a] !) ([setf a 0]))
   (([dup] [qw a] !)   ([movwf a 0]))         ;; dup a !


   (([qw x] [qw y] [qw a] !)
    ((insert
      (if (eq? x y)
          (asm [qw x] [movwf a 0])                    ;; literal DUP artifact
          (asm [qw y] [movwf a 0] [drop] [qw x])))))  ;; literal commutes (FIXME: commute rules)
   
   (([qw a] !)          ([movwf a 0] [drop]))  ;; simple literal op

   ((!)                 ([cw '!]))       ;; call to non-bound store

   
   ;; the a reg
   (([qw lo] [qw hi] a!!) ([~lfsr 2 hi] [~nop lo]))
   ((a!!)                 ((insert (list (macro: ~a!!))))) ;;(macro-egg '~a!!))


   

   ;; STACK

   (([qw a] dup)  ([qw a] [qw a]))
   (([drop] dup)  ([movf 'INDF0 0 0]))
   ((dup)         ([dup]))

   (([qw a] drop) ())
   ((drop )       ([drop]))


   (([qw a] [qw b] swap)  ([qw b] [qw a]))
   ((swap)                ([xorwf 'INDF0 0 0]   ;; swap using the 3 xor trick
                           [xorwf 'INDF0 1 0]
                           [xorwf 'INDF0 0 0]))

   (([qw r] swap!)   ([xorwf r 0 0]   ;; swap using the 3 xor trick
                      [xorwf r 1 0]
                      [xorwf r 0 0]))


   ;; RPN ASSEMBER

   (([,opc f d a] d=reg)  ([,opc f 1 a]))
   (([,opc f d a] d=w)    ([,opc f 0 a]))
   ((return)              ([return 0]))


   ;; The 'org' macro in forth requires byte addresses, while the
   ;; 'org' opcode in the assember requires word addresses as internal
   ;; representation. This is where we convert.
 
   (([qw addr] org)      ([org (wrap: addr '2/)])) 
   (([qw addr] org-push) ([org-push (wrap: addr '2/)]))
   
   (([qw a] movlw)         ([movlw a]))
   (([qw a] retlw)         ([retlw a]))
   (([qw a] sublw)         ([sublw a]))  ;; subtract W from F

   
   (([qw s] [qw d] movff)  ([~movff s] [~nop d]))
   (([qw s] retfie)        ([retfie s]))

   (([qw addr] [qw reg] lfsr)
    ([~lfsr reg (wrap: addr 8 '>>>)]
     [~nop addr])) ;; macro only
   
   ;; TABLES
 
   (([db lo] [qw hi] |,|)  ([d2 lo hi]))
   (([qw lo] |,|)          ([db lo]))
   (([qw w]  |,,|)         ([dw w]))


   ;; CONCATENATION
   ;; Run-time macro code generation.

   (([qw a ] [qw b] cat)   ([qw (wrap: a b)]))
      
   
   ;; TABLES
   (([qw start] [qw endx] [qw n] |,,geo-seq|)
    ((insert (geometric-sequence start endx n))))


   ;; CONDITIONALS

   ;; There is a lot of machine support for conditional branching, but
   ;; it is a bit non-orthogonal: there are 2 types of conditionals:

   ;; * btfsc and btfss instructions skip the next instruction based on any bit
   ;; * conditional jumps take the condition from the STATUS register directly

   ;; generic bit -> arguments for btfsp 
   (([qw f] [qw b] [qw p] bit?) ([bit? f b p]))
   ((bit?)                      ([cw 'bit?]))

   ;; STATUS flag -> conditional jump opcode
   (([qw p] pz?)      ([flag? 'bpz p]))    
   (([qw p] pc?)      ([flag? 'bpc p]))
   (([qw p] pn?)      ([flag? 'bpn p]))


   ;; The 'or-jump' macro recombines the pseudo ops from above into
   ;; jump constructs. These use 'r' instructions. (see assembler.ss)
   (([bit?  f b p] [qw l] or-jump)     ([btfsp (flip p) f b 0] [r 'bra l]))
   (([flag? opc p] [qw l] or-jump)     ([r opc (flip p) l]))
   
   (([cmp? opc f a 0] [qw l] or-jump)  ([,opc f a] [bra 1] [r 'bra l]))
   (([cmp? opc f a 1] [qw l] or-jump)  ([,opc f a] [r 'bra l]))

   ;; FIXME: using carry is simpler, since it's not affected by 'drop'
   (([qw l] or-jump)                   ([cw '>z] [r 'bpz 0 l]))


   (([qw l] nzjump)  ([r 'bpz 1 l])) ;; ( label -- )   

   ;; The 'not' macro is useful as predicate negation. Note that it's not the
   ;; same as "FF XOR" !
   (([bit?  f b p] not)     ([bit? f b (flip p)]))
   (([flag? opc p] not)     ([flag? opc (flip p)]))
   (([cmp?  opc f a p] not) ([cmp?  opc f a (flip p)]))

   ;; I had to put this back for some reason.. Don't remember.
   ;; ((['qw a] not)            `([qw (,@(wrap a) -1 xor)]))


   (([qw a] neg) ([qw (wrap: a -1 '*)]))
   ((neg)        ([negf 'WREG 0]))

   
   ;; Conditional skip optimisation for 'then'.
   (([btfsp  p f b a] [r 'bra l1] ,ins [label l2] swapbra)
    ((insert
      (if (eq? l1 l2)
          `([btfsp ,(flip p) ,f ,b ,a] ,ins)
          (error 'then-opti-error)))))

   ((swapbra) ()) ;; FIXME: skip/jump optimization




   
 
   ;; NOTE; propagating drop is not always possible due to flag effect.
   ;; it might be interesting to think about this a bit
   ;; ((['movlw f] 1-!) `([drop] [decf ,f 0 1])) ;; doesn't mess up flags
   ;; ((['movlw f] 1-!) `([decf ,f 0 1] [drop])) ;; propagate drop -> messes up flags


   ;; return optimization
   (([cw word] exit)        ([jw word])) 
   (([qw a] exit)           ([save] [retlw a]))
   ((exit)                  ([return 0]))


;;   (([cw word] jump)       ([jw word])) 
;;   (([r 'rcall word] jump) ([r 'bra word])) ;; FIXME: probably not necessary
 

   ;; Tests that do not consume their arguments: ( a b -- a b ? )

   ;; The polarity bit in the opcode is chosen such that the 'or-jump'
   ;; macro has a simple 'zero?' comparison for inserting the [bra 1] =
   ;; skip instruction.
 
   ((=?) ([cmp? 'cpfseq 'INDF0 0 1]))
   ((>?) ([cmp? 'cpfsgt 'INDF0 0 1]))
   ((<?) ([cmp? 'cpfslt 'INDF0 0 1]))

   ;; FIXME: single instruction then opti doesnt work here.

   ;; Direct bit operations. These to not modify top, so swap
   ;; instructions if there's a drop.
 
   ;; Doesn't work if f is WREG!!!
   
   ;; It is possible to use literal and/or to operate on WREG though, so
   ;; as a general rule, you are not allowed to touch WREG in forth!

   ;; FIXME: use permutation macro
   (([drop] [qw f] [qw b] [qw c] bit!) ([bpf (flip c) f b 0] [drop]))
   (([qw f] [qw b] [qw c] bit!)        ([bpf (flip c) f b 0]))
   ((bit!)                             ([cw 'bit!]))
 
   (([qw f] [qw b] toggle) ([btg f b 0]))
   ((toggle)               ([cw 'toggle]))
   




   ;; pre/postincrement variable fetch
   (([movf f 0 0] preinc)  ([incf f 1 0] [movf f 0 0]))
   (([movf f 0 0] postinc) ([movf f 0 0] [incf f 1 0]))
 
   ((umul>PROD) ([mulwf 'POSTDEC0 0] [drop]))
   ((xdrop)     ([movf 'POSTDEC1 1 0]))

   ;; unsigned min/max
   ((max)    ([cpfsgt 'INDF0 0] [movwf 'INDF0 0] [drop]))
   ((min)    ([cpfslt 'INDF0 0] [movwf 'INDF0 0] [drop]))



   ;; the name BADNOP comes from a very early implementation of the
   ;; compiler, which encoded error conditions in #xF000 NOP
   ;; instructions. the generic error was #xFBAD.
 
   ((badnop)  ([~nop #xBAD]))
   

   
   )
  


  ;; *** RECURSIVE MACROS ***


  (compositions (macro) macro:

   ;; control flow
   ;; simple for..next
   (for0  >x begin)
   (next0 x1- m> nzjump xdrop)

   ;; then has opti, so we overwrite the previous one
   (then    m> label swapbra)  ;; swapbra is an optimization hook for PIC18   

   ;; control stack
   (+x    PREINC1)
   (x-    POSTDEC1)
   (xtop  INDF1)
   
   (>x    +x !)
   (x     xtop @)
   (x>    x- @)

   ;; target is register, not wreg
   (x1-   xtop 1-!)

   ;; data stack registers
   (1st   WREG)
   (2nd   INDF0)
   (2nd-  POSTDEC0)

   ;; misc data stack ops
   (@!       movff)
   (nfdrop   2nd- 1st @!)  ;; drop without affecting flags
   (test     #xff and)
   (>flags   test nfdrop)

   (even?  1st 0 low?)
   (odd?   1st 0 high?)

   ;; the other conditions are defined as cmpf macros
   (>=?   <? not)
   (<=?   >? not)
 
   
   ;; the control stack is used to help with other data stack jugglings
   (swap>x  2nd- +x movff)
   (over>x  2nd  +x movff)
   
   ;; (over    over>x x>)

   ;; i completely forgot about this one, till i looked at brood 1 source.
   (pick  neg PLUSW0 movf)
   (over  1 pick)
   (nip   POSTDEC0 movwf)  ;; stores wreg in 2nd as side effect

   ;; bit ops
   (high   1 bit!)
   (low    0 bit!)

   ;; flags
   (clc    STATUS C low)
   (stc    STATUS C high)
   (c@     0 rot<<c)
   (c!     STATUS !)  ;; kills other flags
   (sign>c STATUS movwf STATUS rot<<!)

   (high? 1 bit?)
   (low?  0 bit?)

   (z?  0 pz?)
   (nz? 1 pz?)
   (c?  0 pc?)
   (nc? 1 pc?)
   (n?  0 pn?)
   (nn? 1 pn?)
   

   
   ;; shift
   (<< clc rot<<c)
   (2/ #x80 + rot>>c #x40 xor)
   (>> clc rot>>c)

   (rot<<c! rlcf  d=reg)
   (rot>>c! rrcf  d=reg)
   (rot<<!  rlncf d=reg)
   (rot>>!  rrncf d=reg)
   
   ;; multiply
   (u*   umul>PROD PRODL @)
   (u**  u* PRODH @)

   ;; return stack. it is 2 byte wide.
   
   (rl    TOSL)
   (rh    TOSH)
   (rdrop pop)
   (>r    push rl !)	   ;; these are inefficient
   (r>    rl @ pop)
   ;;(_>r   push rh ! rl !)   ;; these operate on 2 bytes at a time
   ;;(_r>   rl @ rh @ pop) 

   ;; indirect memory access
   
   ;; second register is 'a'
   (ah FSR2H)
   (al FSR2L)

   ;; the 'f' register is similar but for flash program memory access
   (fh TBLPTRH)
   (fl TBLPTRL)
   
   ;; using double '!' and '@' to indicate a and p are 2-byte regs
   (a@@   al @ ah @)  ;; ( -- lo hi )
   (f@@   fl @ fh @)  ;; ( -- lo hi )

   (~a!!  ah ! al !)  ;; ( lo hi -- )

   
   (f!!   fh ! fl !)  ;; ( lo hi -- )
   
   (@a+  POSTINC2 @)
   (!a+  POSTINC2 !)
   
   (@a-  POSTDEC2 @)
   (!a-  POSTDEC2 !)

   (!+a  PREINC2 !)
   (@+a  PREINC2 @)
    
   (@a   INDF2 @)
   (!a   INDF2 !)

   ;; indirect addressing using FSR2 + WREG
   (@i   PLUSW2 movf)
   (!i   POSTDEC0 PLUSW2 movff drop)


   ;; save/drop at beginning/end to enable opti
   (@f+   save tblrd*+ TABLAT movf)
   (@f    save tblrd*  TABLAT movf)
   (!f+   TABLAT movwf tblwt*+ drop)

   ;; conditional branching
   (abs      1st 7 high? if neg then)

   ;; standard forth meaning: ( a b -- ? )
;   (=    xor nfdrop z?)
;   (>=   - nfdrop c?)
;   (<    - nfdrop nc?)

   (~not   z? if -1 else 0 then) ;; FIXME: do this better

   
   )


)