;;;
;;; Assembler/disassembler between S-expressions and BPF bytecode
;;;
;;; Copyright (c) 2013 by Peter Bex, see file COPYING.BSD
;;;
(module bpf-assembler
        (exprs->bpf-bytecode bpf-bytecode->exprs)

(import chicken scheme)
(use srfi-1 bitstring matchable)

(define (uint? x) (and (integer? x) (positive? x)))
;; Is a jump of zero allowed?  It shouldn't be!
(define (label? x) (and (integer? x) (< 0 x 256)))

;; Basic idea stolen from sixtyfive-oh-two.  Thanks, Felix! ;)
(begin-for-syntax
 (import chicken)
 (use srfi-1 matchable)
 
 (define addrmodes '())
 (define opcodes   '())

 ;; This one is hairy and only semi-hygienic (or some such) due to the
 ;; construction of "quoted code", which is then picked apart by the ir macros
 (define-syntax defaddrmode
   (syntax-rules (=>)
     ((_ ?id ?code (?match-expr => ?k-expr) (?k-bit => ?disasm))
      (defaddrmode ?id ?code
        (?match-expr => 0 0 ?k-expr)
        (0 0 ?k-bit => ?disasm)))
     ((_ ?id ?code
         (?match-expr => ?jt ?jf ?k-expr)
         (?jt-bit ?jf-bit ?k-bit => ?disasm))
      (set! addrmodes
        (cons (cons '?id (list ?code
                               (list '?match-expr '?jt '?jf '?k-expr)
                               (list '((?jt-bit 8) (?jf-bit 8) (?k-bit 32 host))
                                     '?disasm)))
              addrmodes)))))

 ;; XXX TODO: Use the constants from net/bpf.h?
 
 ;; Ordered by complexity
 (defaddrmode no-operands #x80 (() => 0) (_ => ()))
 (defaddrmode packet-length #x80 (('len) => 0) (_ => (len)))
 (defaddrmode index-register #x08 (('x) => 0) (_ => (x)))
 (defaddrmode accumulator-register #x10 (('a) => 0) (_ => (a)))
 (defaddrmode immediate #x00       ; Also used for JA aka JMP w/ label
   (((and k (? uint?))) => k)
   (k => (,k)))
 (defaddrmode memory-ref #x60
   ((('mem (and k (? uint?)))) => k)
   (k => ((mem ,k))))
 (defaddrmode packet-ref #x20
   ((('pkt (and k (? uint?)))) => k)
   (k => ((pkt ,k))))
 (defaddrmode packet-ref/index-register #x40
   ((('pkt 'x (and k (? uint?)))) => k)
   (k => ((pkt x ,k))))
 (defaddrmode packet-ref/hack #xa0 ; BPF_MSH; an "efficiency hack", says bpf(4)
   ((('pkt '4* (and k (? uint?)))) => k)
   (k => ((pkt 4* ,k))))
 (defaddrmode conditional-jump-immediate #x00
   (((and k (? uint?)) (and jt (? label?)) (and jf (? label?))) => jt jf k)
   (jt jf k => (,k ,jt ,jf)))
 (defaddrmode conditional-jump-index-register #x08
   (('x (and jt (? label?)) (and jf (? label?))) => jt jf 0) ; zero?
   (jt jf _ => (x ,jt ,jf)))

 (define-syntax defop
   (syntax-rules ()
     ((_ ?mnemonic ?opcode ?addrmode0 ...)
      (set! opcodes (cons (cons '?mnemonic (list ?opcode '?addrmode0 ...))
                          opcodes)))))

 ;; Define mnemonic, basic opcode and addressing modes for each instruction.
 ;; The addressing mode is ORed into the basic opcode to get a full opcode.
 (defop ld   #x00
   packet-length immediate memory-ref packet-ref packet-ref/index-register)
 (defop ldh  #x08 packet-ref packet-ref/index-register)
 (defop ldb  #x10 packet-ref packet-ref/index-register)
 (defop ldx  #x01 packet-length immediate memory-ref packet-ref/hack)
 (defop st   #x02 memory-ref)
 (defop stx  #x03 memory-ref)
 (defop jmp  #x05 immediate)            ; aka JA
 (defop jeq  #x10 conditional-jump-immediate conditional-jump-index-register)
 (defop jgt  #x20 conditional-jump-immediate conditional-jump-index-register)
 (defop jge  #x30 conditional-jump-immediate conditional-jump-index-register)
 (defop jset #x40 conditional-jump-immediate conditional-jump-index-register)
 (defop add  #x04 index-register immediate)
 (defop sub  #x14 index-register immediate)
 (defop mul  #x24 index-register immediate)
 (defop div  #x34 index-register immediate)
 (defop or   #x44 index-register immediate)
 (defop and  #x54 index-register immediate)
 (defop lsh  #x64 index-register immediate)
 (defop rsh  #x74 index-register immediate)
 (defop neg  #x84 no-operands)
 ;; index-register is acceptable, according to comment in bpf.h
 (defop ret  #x06 accumulator-register immediate index-register)
 (defop tax  #x07 no-operands)
 (defop txa  #x87 no-operands))

;;;;;;;;;;;;;;;;
;;; Assembly ;;;
;;;;;;;;;;;;;;;;

;; XXX TODO: Use the structs from net/bpf.h?  bitstring can go, then.

(define-syntax assemble-instruction
  (ir-macro-transformer
   (lambda (e i c)
     `(let ((insn ,(cadr e)))
        (match insn
          ((opcode args ...)
           (case opcode
             ,@(map (match-lambda
                      ((mnemonic opcode modes ...)
                       `((,mnemonic)
                         (match args
                           ,@(map (lambda (mode)
                                    (match-let (((addrcode (match-expr jt jf k-expr) _)
                                                 (alist-ref mode addrmodes)))
                                      `(,match-expr
                                        (bitconstruct
                                         (,(+ opcode addrcode) 16 host)
                                         (,jt) (,jf) (,k-expr 32 host)))))
                                  modes)
                           (else (error "Unknown addressing mode" insn))))))
                    (reverse opcodes))
             (else (error "Unknown BPF opcode in expression" insn))))
          (else (error "Invalid BPF instruction" insn)))))))

(define (exprs->bpf-bytecode exprs)
  (if (null? exprs)
      (bitconstruct)
      (bitstring-append
       (assemble-instruction (car exprs))
       (exprs->bpf-bytecode (cdr exprs)))))

;;;;;;;;;;;;;;;;;;;
;;; Disassembly ;;;
;;;;;;;;;;;;;;;;;;;

(define-syntax disassemble-instruction
  (ir-macro-transformer
   (lambda (e i c)
     `(let ((insn ,(cadr e)))
        (bitmatch
         insn
         ,@(append-map
            (match-lambda
              ((mnemonic opcode modes ...)
               (map (lambda (mode)
                      (match-let (((addrcode _ (bitmatch-expr disasm-expr))
                                   (alist-ref mode addrmodes)))
                        `(((,(+ opcode addrcode) 16 host) . ,bitmatch-expr)
                          ,(list 'quasiquote (cons mnemonic disasm-expr)))))
                    modes)))
                (reverse opcodes))
         (else "Unrecognised instruction" insn))))))

(define (bpf-bytecode->exprs bytecode)
  (let lp ((bytecode bytecode)
           (exprs '()))
    (bitmatch bytecode
              (((insn 64 bitstring) (rest bitstring))
               (lp rest (cons (disassemble-instruction insn) exprs)))
              (() (reverse exprs)))))

)