#lang scheme/base

(require
 (lib "match.ss")
 (lib "pretty.ss")
 "../live.ss"  ;; reflection
 "../asm.ss"
 "../tools.ss")


(provide (all-defined-out))


;; PIC18 ASSEMBLER

;; the instruction set is stored in the way it appears in the data
;; sheet: the 'instruction-set' macro will map it to a more readable
;; prototype and onwards to assembler and disassembler code for every
;; opcode.

;; f = file register
;; d = 0 for result destination to be WREG register
;; d = 1 for result destination to be file register (f)
;; a = 0 to force Access Bank
;; a = 1 for BSR to select bank

;; lower case letters signify unsigned values, while capital names are
;; interpreted as signed values (by disassembler)

;; R = relative jump address, in words relative to next
;; instruction. these are also checked for overflow.

(instruction-set

 ;; byte-oriented file register operations
 (addwf   (f d a) "0010 01da ffff ffff")
 (addwfc  (f d a) "0010 00da ffff ffff")
 (andwf   (f d a) "0001 01da ffff ffff")
 (clrf    (f a)   "0110 101a ffff ffff")
 (comf    (f d a) "0001 11da ffff ffff")
 (cpfseq  (f a)   "0110 001a ffff ffff")
 (cpfsgt  (f a)   "0110 010a ffff ffff")
 (cpfslt  (f a)   "0110 000a ffff ffff")
 (decf    (f d a) "0000 01da ffff ffff")
 (decfsz  (f d a) "0010 11da ffff ffff")
 (dcfsnz  (f d a) "0100 11da ffff ffff")
 (incf    (f d a) "0010 10da ffff ffff")
 (incfsz  (f d a) "0011 11da ffff ffff")
 (infsnz  (f d a) "0100 10da ffff ffff")
 (iorwf   (f d a) "0001 00da ffff ffff")
 (movf    (f d a) "0101 00da ffff ffff")
 (~movff  (s)	    "1100 ssss ssss ssss") ; (~nop d)
 (movwf   (f a)   "0110 111a ffff ffff") 
 (mulwf   (f a)   "0000 001a ffff ffff")
 (negf    (f a)   "0110 110a ffff ffff")
 (rlcf    (f d a) "0011 01da ffff ffff")
 (rlncf   (f d a) "0100 01da ffff ffff")
 (rrcf    (f d a) "0011 00da ffff ffff")
 (rrncf   (f d a) "0100 00da ffff ffff")
 (setf    (f a)   "0110 100a ffff ffff")
 (subfwb  (f d a) "0101 01da ffff ffff")
 (subwf   (f d a) "0101 11da ffff ffff")
 (subwfb  (f d a) "0101 10da ffff ffff")

 
 (swapf   (f d a) "0011 10da ffff ffff")
 (tstfsz  (f a)   "0110 011a ffff ffff")
 (xorwf   (f d a) "0001 10da ffff ffff")

 ;; ORIGINAL
 ;; bit-oriented file register operations
 ;;(bcf     (f b a) "1001 bbba ffff ffff")
 ;;(bsf     (f b a) "1000 bbba ffff ffff")
 ;;(btfsc   (f b a) "1011 bbba ffff ffff")
 ;;(btfss   (f b a) "1010 bbba ffff ffff")
 ;;(btg     (f b a) "0111 bbba ffff ffff")

 ;; POLARIZED
 ;; p = INVERTED bit value : clear = 1, set = 0
 (bpf    (p f b a) "100p bbba ffff ffff")
 (btfsp  (p f b a) "101p bbba ffff ffff")
 (btg    (f b a)   "0111 bbba ffff ffff")

 ;; ORIGINAL
 ;; control operations
 ;;(bc      (n)     "1110 0010 nnnn nnnn")
 ;;(bnc     (n)     "1110 0011 nnnn nnnn")
 ;;(bn      (n)     "1110 0110 nnnn nnnn")
 ;;(bnn     (n)     "1110 0111 nnnn nnnn")
 ;;(bov     (n)     "1110 0100 nnnn nnnn")
 ;;(bnov    (n)     "1110 0101 nnnn nnnn")
 ;;(bz      (n)     "1110 0000 nnnn nnnn")
 ;;(bnz     (n)     "1110 0001 nnnn nnnn")
 
 ;; POLARIZED
 ;; conditionals
 ;; p = polarity   1 : inverted   0 : normal
 (bpc      (p R)     "1110 001p RRRR RRRR")
 (bpn      (p R)     "1110 011p RRRR RRRR")
 (bpov     (p R)     "1110 010p RRRR RRRR")
 (bpz      (p R)     "1110 000p RRRR RRRR")
 
 (bra     (R)     "1101 0RRR RRRR RRRR")
 (~call   (l s)   "1110 110s llll llll") ;; h = high, l = low  (~nop h)
 (clrwdt  ()      "0000 0000 0000 0100")
 (daw     ()      "0000 0000 0000 0111")
 (~goto   (l)     "1110 1111 llll llll") ; (~nop h)
 (nop     ()      "0000 0000 0000 0000")
 (~nop    (d)     "1111 dddd dddd dddd") ; used for extra argument
 (pop     ()      "0000 0000 0000 0110")
 (push    ()      "0000 0000 0000 0101")
 (reset   ()      "0000 0000 1111 1111")
 (rcall   (R)     "1101 1RRR RRRR RRRR")
 (retfie  (s)     "0000 0000 0001 000s")
 (retlw   (k)     "0000 1100 kkkk kkkk")
 (return  (s)     "0000 0000 0001 001s")
 (sleep   ()      "0000 0000 0000 0011")

 ;; literal operations
 (addlw   (k)     "0000 1111 kkkk kkkk")
 (andlw   (k)     "0000 1011 kkkk kkkk")
 (iorlw   (k)     "0000 1001 kkkk kkkk")
 (~lfsr   (f h)   "1110 1110 00ff hhhh")  ; (~nop l)
 (movlb   (k)     "0000 0001 0000 kkkk")
 (movlw   (k)     "0000 1110 kkkk kkkk")
 (mullw   (k)     "0000 1101 kkkk kkkk")
 (retlw   (k)     "0000 1100 kkkk kkkk")
 (sublw   (k)     "0000 1000 kkkk kkkk")
 (xorlw   (k)     "0000 1010 kkkk kkkk")

 ;; data memory <-> program memory operations
 (tblrd*  ()      "0000 0000 0000 1000")
 (tblrd*+ ()      "0000 0000 0000 1001")
 (tblrd*- ()      "0000 0000 0000 1010")
 (tblrd+* ()      "0000 0000 0000 1011")
 (tblwt*  ()      "0000 0000 0000 1100")
 (tblwt*+ ()      "0000 0000 0000 1101")
 (tblwt*- ()      "0000 0000 0000 1110")
 (tblwt+* ()      "0000 0000 0000 1111")

 )

(check-set-mode! 'report-failed)
(check ((asm-find 'movlw) 123) => '(3707))
(check ((dasm-find 14 8) 3707) => '(movlw (k . 123)))
           


;; multi-word instructions:

;; to keep things simple, multiword instructions are handled explictly
;; in the compiler instead of the assembler. for PIC, the 2-word
;; instructions all have a second word encoded as a special nop
;; which carries a payload. this is represented by the '~nop'
;; instruction.

;; use the ~nop instruction to create the 2nd argument for goto/call,
;; which is the high part of the address.

(pseudo-ops
 (assemblers: ~nop)
              
 (~page (addr)  (~nop  (>>> addr 8)))
 (dup   ()      `(#x6EEC))
 (drop  ()      `(#x50ED))
 (db    (x)     `(,(int x)))
 (dw    (x)     `(,(int x)))
 (d2    (lo hi) `(,(bior (int8 lo)
                         (<<< (int8 hi) 8))))

 (jsr   (exit address) (assemble-jsr exit address))
 
 )

;; Again because defined in terms of the above
;; NOTE: binary code is stored in reverse.

(pseudo-ops
 (assemblers:  ~goto ~call ~page)
             
 (goto  (addr)   (append (~page addr) (~goto addr))) 
 (call  (addr s) (append (~page addr) (~call addr s))) ;; not using shadow
 (call0 (addr)   (append (~page addr) (~call addr 0))) ;; not using shadow

 )

(define-syntax-rule (let-assemblers (name ...) body ...)
  (let ((name (asm-find 'name)) ...) body ...))

;; The smart unconditional jump / call.
(define assemble-jsr
  (let-assemblers
   (bra rcall goto call) ;; resolve to lexical names
   (lambda (exit address)
     (let-values
         (((short long)
           (if (zero? exit)
               (values rcall call)
               (values bra goto)))
          ((relative-address)
           (- address (+ (pointer-get 'code) 1))))
       ((if (asm-fits? relative-address
                       11 operand:signed)
            short long)
        address)))))



;; asm pretty printer: convert internal asm representation to the
;; canonical one.

(define (lfsr reg base bank)
  `(lfsr ,reg ,(bior base (<<< bank 8))))


(define (pretty-asm lst)
  (foldr
   (match-lambda*

    ((('~lfsr reg (and bank (= number? #t)))
      (('~nop (and base (= number? #t))) . r))
     (cons (lfsr reg base bank) r))
    
    ((('~lfsr reg (and bank (= number? #t)))
      (('label . l) ;; HACK
       ('~nop (and base (= number? #t))) . r))
     (cons (lfsr reg base bank) r))
    
    ((('bpf p x y z) r)
     (cons `(,(if (= p 0) 'bsf 'bcf) ,x ,y ,z) r))

    ((('btfsp p x y z) r)
     (cons `(,(if (= p 0) 'btfss 'btfsc) ,x ,y ,z) r))

    ((('r 'bpz p addr) r)
     (cons `(,(if (= p 0) 'bz 'bnz) ,addr) r))
    ((('bpz p addr) r)
     (cons `(,(if (= p 0) 'bz 'bnz) ,addr) r))

    ((('r 'bpc p addr) r)
     (cons `(,(if (= p 0) 'bc 'bnc) ,addr) r))
    ((('bpc p addr) r)
     (cons `(,(if (= p 0) 'bc 'bnc) ,addr) r))

    ((('~movff s) (('~nop d) . r))
     (cons `(movff ,s ,d) r))

    ((('~nop 'TOSU) r)
     (cons '(_) r))
    
    ((head tail)
     (cons head tail)))
   
   '() lst))

;; (pretty-asm '((~lfsr 0 1) (~nop 2) (bpf 0 a b c)))