1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
(module bpf-assembler ; Maybe I should call this "bassie" ;)
(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)))))
;; 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 ;;;
;;;;;;;;;;;;;;;;
(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)))))
)
|
