├── doc └── api.odocl ├── src ├── bpf.mllib ├── test.ml ├── eBPF.mli └── eBPF.ml ├── .gitignore ├── .merlin ├── _tags ├── CHANGES.md ├── pkg ├── META └── pkg.ml ├── Makefile ├── README.md └── opam /doc/api.odocl: -------------------------------------------------------------------------------- 1 | EBPF 2 | -------------------------------------------------------------------------------- /src/bpf.mllib: -------------------------------------------------------------------------------- 1 | EBPF 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.byte 3 | *.native 4 | *.install 5 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S src 2 | B _build/** 3 | PKG ppx_deriving.enum 4 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | "src/eBPF.ml": warn(-32), package(ppx_deriving.enum) 2 | true: bin_annot, safe_string, debug, warn(+a-4) 3 | : include 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.2 2017-09-30 2 | -------------- 3 | - optionally allow jump backwards 4 | 5 | 0.1 2017-06-04 6 | -------------- 7 | - initial 8 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "Embedded eBPF assembler" 2 | version = "%%VERSION_NUM%%" 3 | requires = "ppx_deriving" 4 | archive(byte) = "bpf.cma" 5 | archive(native) = "bpf.cmxa" 6 | plugin(byte) = "bpf.cma" 7 | plugin(native) = "bpf.cmxs" 8 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind";; 3 | #require "topkg";; 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "bpf" ~licenses:[] begin fun c -> 8 | Ok [ 9 | Pkg.mllib "src/bpf.mllib"; 10 | Pkg.test "src/test"; 11 | ] 12 | end 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .SUFFIXES: 2 | .PHONY: build doc clean 3 | 4 | build: 5 | ocaml pkg/pkg.ml build 6 | 7 | clean: 8 | ocaml pkg/pkg.ml clean 9 | 10 | doc: 11 | topkg doc 12 | 13 | %.bpf: %.o 14 | objcopy -F elf64-little --dump-section .text=$@ $< 15 | 16 | %.o: %.c 17 | clang -c -O2 -target bpf $< -o $@ 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml embedded [eBPF](https://qmonnet.github.io/whirl-offload/2016/09/01/dive-into-bpf/) assembler. 2 | 3 | [eBPF.mli](src/eBPF.mli) 4 | 5 | Assuming `R1` points to packet data - check if it is an ARP packet : 6 | 7 | ``` 8 | let arp = 9 | [ 10 | ldx H R2 (R1,12); 11 | movi R0 1; 12 | jmpi `Exit R2 `EQ 0x806; 13 | movi R0 0; 14 | label `Exit; 15 | ret 16 | ] 17 | ``` 18 | 19 | See [src/test.ml](src/test.ml) for more examples. 20 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "ygrek " 3 | authors: ["ygrek "] 4 | homepage: "https://github.com/ygrek/ocaml-bpf" 5 | doc: "http://ygrek.org.ua/p/ocaml-bpf/api/" 6 | license: "BSD3" 7 | dev-repo: "https://github.com/ygrek/ocaml-bpf.git" 8 | bug-reports: "https://github.com/ygrek/ocaml-bpf/issues" 9 | tags: ["org:ygrek"] 10 | available: [ ocaml-version >= "4.02.0"] 11 | depends: [ 12 | "ocamlfind" {build} 13 | "ocamlbuild" {build} 14 | "topkg" {build} 15 | "ppx_deriving" 16 | ] 17 | depopts: [ ] 18 | build: [ 19 | [ "ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{pinned}%" ] 20 | ] 21 | build-test: [ 22 | [ "ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{pinned}%" "--tests" "true" ] 23 | [ "ocaml" "pkg/pkg.ml" "test" ] 24 | ] 25 | -------------------------------------------------------------------------------- /src/test.ml: -------------------------------------------------------------------------------- 1 | open EBPF 2 | 3 | (* check if data starts with the (4-byte) answer to life and everything *) 4 | let life = 5 | [ 6 | ldx W R1 (R1,0); 7 | movi R0 1; 8 | movi R2 42; 9 | jmp `Exit R1 `EQ R2; 10 | movi R0 0; 11 | label `Exit; 12 | ret 13 | ] 14 | 15 | (* check if R1 points to an ARP packet *) 16 | let arp = 17 | [ 18 | ldx H R2 (R1,12); 19 | movi R0 1; 20 | jmpi_ 1 R2 `EQ 0x806; (* laborious way to say jmpi `Exit *) 21 | movi R0 0; 22 | label `Exit; 23 | ret 24 | ] 25 | 26 | (* check for IPv4 TCP packet *) 27 | let tcp_ipv4 = 28 | [ 29 | movi R0 0; 30 | ldx H R2 (R1,12); 31 | jmpi `Drop R2 `NE 0x800; 32 | ldx B R2 (R1,23); 33 | jmpi `Drop R2 `NE 6; 34 | movi R0 1; 35 | label `Drop; 36 | ret; 37 | ] 38 | 39 | let test_lddw = 40 | [ 41 | ldx DW R2 (R1,0); 42 | lddw R3 0xDEADBEEF01020304L; 43 | xor R2 R3; 44 | ldx DW R1 (R1,8); 45 | movi R0 1; 46 | jmp `Exit R2 `EQ R1; 47 | movi R0 0; 48 | label `Exit; 49 | ret 50 | ] 51 | 52 | (** check that i-th element of the array is not equal to [value] *) 53 | let not_array i value = 54 | [ 55 | ldx DW R2 (R1,i*8); 56 | movi R0 0; 57 | jmpi `Exit R2 `EQ value; 58 | movi R0 1; 59 | label `Exit; 60 | ret 61 | ] 62 | 63 | let () = not_array 2 0 |> assemble |> print_string 64 | -------------------------------------------------------------------------------- /src/eBPF.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Embedded {{:https://qmonnet.github.io/whirl-offload/2016/09/01/dive-into-bpf/}eBPF} assembler 3 | *) 4 | 5 | (** {2 Types} *) 6 | 7 | type size = 8 | | W (** word = 32 bit *) 9 | | H (** half-word = 16 bit *) 10 | | B (** byte *) 11 | | DW (** double word = 64 bit *) 12 | 13 | type reg = R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 14 | type int16 = int 15 | type cond = [ 16 | | `EQ (** equal *) 17 | | `GE (** greater or equal *) 18 | | `GT (** greater than *) 19 | | `NE (** not equal *) 20 | | `SET (** bitwise AND *) 21 | | `SGE (** signed greater or equal *) 22 | | `SGT (** signed greater than *) 23 | | `LE (** less or equal *) 24 | | `LT (** less than *) 25 | | `SLE (** signed less or equal *) 26 | | `SLT (** signed less than *) 27 | ] 28 | 29 | (** Single eBPF instruction. ['label] is type of labels, can be any hashable type, e.g. [string], [int], open variant, etc *) 30 | type +'label insn 31 | 32 | (** {2 Memory instructions} *) 33 | 34 | val ldx : size -> reg -> reg * int16 -> 'a insn 35 | val lddw : reg -> int64 -> 'a insn 36 | val stx : size -> reg * int16 -> reg -> 'a insn 37 | val st : size -> reg * int16 -> int -> 'a insn 38 | 39 | (** {2 Branch instructions} *) 40 | 41 | (** mark label position, each label should be unique *) 42 | val label : 'label -> 'label insn 43 | 44 | val ret : 'a insn 45 | val call : int -> 'a insn 46 | 47 | val jump : 'label -> 'label insn 48 | val jmpi : 'label -> reg -> cond -> int -> 'label insn 49 | val jmp : 'label -> reg -> cond -> reg -> 'label insn 50 | 51 | (** same as [jump] but with 32-bit wide operands *) 52 | val jump32 : 'label -> 'label insn 53 | val jmp32i : 'label -> reg -> cond -> int -> 'label insn 54 | val jmp32 : 'label -> reg -> cond -> reg -> 'label insn 55 | 56 | (** {3 raw jump instructions with manually-computed offset} 57 | 58 | you probably want to use functions above which take labels 59 | *) 60 | 61 | val jump_ : int16 -> 'a insn 62 | val jmpi_ : int16 -> reg -> cond -> int -> 'a insn 63 | val jmp_ : int16 -> reg -> cond -> reg -> 'a insn 64 | 65 | val jump32_ : int16 -> 'a insn 66 | val jmp32i_ : int16 -> reg -> cond -> int -> 'a insn 67 | val jmp32_ : int16 -> reg -> cond -> reg -> 'a insn 68 | 69 | (** {2 ALU (arithmetic/logic) instructions} *) 70 | 71 | module type ALU = 72 | sig 73 | val add : reg -> reg -> 'a insn 74 | val addi : reg -> int -> 'a insn 75 | val sub : reg -> reg -> 'a insn 76 | val subi : reg -> int -> 'a insn 77 | val mul : reg -> reg -> 'a insn 78 | val muli : reg -> int -> 'a insn 79 | val div : reg -> reg -> 'a insn 80 | val divi : reg -> int -> 'a insn 81 | val or_ : reg -> reg -> 'a insn 82 | val ori : reg -> int -> 'a insn 83 | val and_ : reg -> reg -> 'a insn 84 | val andi : reg -> int -> 'a insn 85 | val lsh : reg -> reg -> 'a insn 86 | val lshi : reg -> int -> 'a insn 87 | val rsh : reg -> reg -> 'a insn 88 | val rshi : reg -> int -> 'a insn 89 | val neg : reg -> reg -> 'a insn 90 | val negi : reg -> int -> 'a insn 91 | val mod_ : reg -> reg -> 'a insn 92 | val modi : reg -> int -> 'a insn 93 | val xor : reg -> reg -> 'a insn 94 | val xori : reg -> int -> 'a insn 95 | val mov : reg -> reg -> 'a insn 96 | val movi : reg -> int -> 'a insn 97 | val arsh : reg -> reg -> 'a insn 98 | val arshi : reg -> int -> 'a insn 99 | end 100 | 101 | module I32 : ALU 102 | 103 | (** 64-bit instructions, for 32-bit instructions use {!I32} *) 104 | include ALU 105 | 106 | (** {2 Byteswap instructions} *) 107 | 108 | val le16 : reg -> 'a insn 109 | val be16 : reg -> 'a insn 110 | val le32 : reg -> 'a insn 111 | val be32 : reg -> 'a insn 112 | val le64 : reg -> 'a insn 113 | val be64 : reg -> 'a insn 114 | 115 | (** {2 Assembler} *) 116 | 117 | type options = { 118 | disable_all_checks : bool; (** disable all checks, may generate invalid code *) 119 | jump_back : bool; (** allow jump backwards, may result in infinite loop *) 120 | jump_self : bool; (** allow jump to self, guaranteed infinite loop *) 121 | } 122 | 123 | val default : options 124 | 125 | val assemble : ?options:options -> 'a insn list -> string 126 | -------------------------------------------------------------------------------- /src/eBPF.ml: -------------------------------------------------------------------------------- 1 | (* 2 | https://www.kernel.org/doc/Documentation/networking/filter.txt 3 | https://github.com/iovisor/bpf-docs/blob/master/eBPF.md 4 | *) 5 | 6 | let fail fmt = Printf.ksprintf failwith fmt 7 | 8 | type size = 9 | | W (** word = 4B *) 10 | | H (** half word = 2B *) 11 | | B (** byte *) 12 | | DW (* double word = 8B *) 13 | [@@deriving enum] 14 | 15 | type reg = R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 [@@deriving enum] 16 | 17 | type op_alu = 18 | | ADD 19 | | SUB 20 | | MUL 21 | | DIV 22 | | OR 23 | | AND 24 | | LSH 25 | | RSH 26 | | NEG 27 | | MOD 28 | | XOR 29 | | MOV (* eBPF only: mov reg to reg *) 30 | | ARSH (* eBPF only: sign extending shift right *) 31 | | END (* eBPF only: endianness conversion *) 32 | [@@deriving enum] 33 | 34 | type op_jmp = 35 | | JA 36 | | JEQ 37 | | JGT 38 | | JGE 39 | | JSET 40 | | JNE 41 | | JSGT (* eBPF only: signed '>' *) 42 | | JSGE (* eBPF only: signed '>=' *) 43 | | CALL (* eBPF only: function call *) 44 | | EXIT (* eBPF only: function return *) 45 | | JLT (* eBPF only: unsigned '<' *) 46 | | JLE (* eBPF only: unsigned '<=' *) 47 | | JSLT (* eBPF only: signed '<' *) 48 | | JSLE (* eBPF only: signed '<=' *) 49 | [@@deriving enum] 50 | 51 | type source = SRC_IMM | SRC_REG [@@deriving enum] 52 | 53 | type mode = 54 | | IMM (* used for 32-bit mov in classic BPF and 64-bit in eBPF *) 55 | | ABS_todo 56 | | IND_todo 57 | | MEM 58 | | LEN_reserved (* classic BPF only, reserved in eBPF *) 59 | | MSH_reserved (* classic BPF only, reserved in eBPF *) 60 | | XADD_todo (* eBPF only, exclusive add *) 61 | [@@deriving enum] 62 | 63 | type op = 64 | | LD of size * mode | LDX of size * mode | ST of size * mode | STX of size * mode 65 | | ALU of source * op_alu 66 | | ALU64 of source * op_alu 67 | | JMP of source * op_jmp 68 | | JMP32 of source * op_jmp 69 | 70 | type int16 = int (* FIXME *) 71 | 72 | (** represents any 64-bit value, i.e. also invalid instructions *) 73 | type ('op, 'reg) insn_t = { op : 'op; dst : 'reg; src : 'reg; off : int16; imm : int32; } 74 | type prim = (op, reg) insn_t 75 | 76 | let make ?(dst=R0) ?(src=R0) ?(off=0) ?(imm=0) op = 77 | (* sanity checks *) 78 | if not (0 <= imm && imm < 4_294_967_296) then fail "Bad immediate : %d" imm; 79 | { op; dst; src; off; imm = Int32.of_int imm; } 80 | 81 | type cond = [ `EQ | `GT | `GE | `SET | `NE | `SGT | `SGE | `LT | `LE | `SLT | `SLE ] 82 | let op_of_cond = function 83 | | `EQ -> JEQ 84 | | `GT -> JGT 85 | | `GE -> JGE 86 | | `SET -> JSET 87 | | `NE -> JNE 88 | | `SGT -> JSGT 89 | | `SGE -> JSGE 90 | | `LT -> JLT 91 | | `LE -> JLE 92 | | `SLT -> JSLT 93 | | `SLE -> JSLE 94 | 95 | type 'label insn = 96 | | Prim of prim (* valid instruction *) 97 | | Label of 'label (* marker, no instruction *) 98 | | Jump of 'label * prim (* to patch offset field *) 99 | | Double of prim * prim (* eBPF has one 16-byte instruction: BPF_LD | BPF_DW | BPF_IMM *) 100 | 101 | let label x = Label x 102 | let prim ?dst ?src ?off ?imm op = Prim (make ?dst ?src ?off ?imm op) 103 | let unprim = function Prim x -> x | _ -> assert false 104 | 105 | let ldx size dst (src,off) = prim (LDX (size, MEM)) ~dst ~src ~off 106 | let lddw dst imm = Double ( 107 | make (LD (DW, IMM)) ~dst ~imm:(Int64.to_int @@ Int64.logand imm 0xFFFFFFFFL), 108 | make (LD (W, IMM)) ~imm:(Int64.to_int @@ Int64.shift_right_logical imm 32)) (* pseudo-insn *) 109 | let stx size (dst,off) src = prim (STX (size, MEM)) ~dst ~src ~off 110 | let st size (dst,off) imm = prim (ST (size, IMM)) ~dst ~off ~imm 111 | let jump_ off = prim (JMP (SRC_IMM, JA)) ~off 112 | let jmpi_ off reg cond imm = prim (JMP (SRC_IMM, op_of_cond cond)) ~dst:reg ~off ~imm 113 | let jmp_ off a cond b = prim (JMP (SRC_REG, op_of_cond cond)) ~dst:a ~src:b ~off 114 | let jump32_ off = prim (JMP32 (SRC_IMM, JA)) ~off 115 | let jmp32i_ off reg cond imm = prim (JMP32 (SRC_IMM, op_of_cond cond)) ~dst:reg ~off ~imm 116 | let jmp32_ off a cond b = prim (JMP32 (SRC_REG, op_of_cond cond)) ~dst:a ~src:b ~off 117 | let ret = prim (JMP (SRC_IMM, EXIT)) 118 | let call imm = prim (JMP (SRC_IMM, CALL)) ~imm 119 | 120 | let jump label = Jump (label, unprim @@ jump_ 0) 121 | let jmpi label reg cond imm = Jump (label, unprim @@ jmpi_ 0 reg cond imm) 122 | let jmp label a cond b = Jump (label, unprim @@ jmp_ 0 a cond b) 123 | let jump32 label = Jump (label, unprim @@ jump32_ 0) 124 | let jmp32i label reg cond imm = Jump (label, unprim @@ jmp32i_ 0 reg cond imm) 125 | let jmp32 label a cond b = Jump (label, unprim @@ jmp32_ 0 a cond b) 126 | 127 | module type ALU = 128 | sig 129 | val add : reg -> reg -> 'a insn 130 | val addi : reg -> int -> 'a insn 131 | val sub : reg -> reg -> 'a insn 132 | val subi : reg -> int -> 'a insn 133 | val mul : reg -> reg -> 'a insn 134 | val muli : reg -> int -> 'a insn 135 | val div : reg -> reg -> 'a insn 136 | val divi : reg -> int -> 'a insn 137 | val or_ : reg -> reg -> 'a insn 138 | val ori : reg -> int -> 'a insn 139 | val and_ : reg -> reg -> 'a insn 140 | val andi : reg -> int -> 'a insn 141 | val lsh : reg -> reg -> 'a insn 142 | val lshi : reg -> int -> 'a insn 143 | val rsh : reg -> reg -> 'a insn 144 | val rshi : reg -> int -> 'a insn 145 | val neg : reg -> reg -> 'a insn 146 | val negi : reg -> int -> 'a insn 147 | val mod_ : reg -> reg -> 'a insn 148 | val modi : reg -> int -> 'a insn 149 | val xor : reg -> reg -> 'a insn 150 | val xori : reg -> int -> 'a insn 151 | val mov : reg -> reg -> 'a insn 152 | val movi : reg -> int -> 'a insn 153 | val arsh : reg -> reg -> 'a insn 154 | val arshi : reg -> int -> 'a insn 155 | end 156 | 157 | module ALU(T : sig val alu_op : source -> op_alu -> op end) : ALU = struct 158 | 159 | let alu_r op dst src = prim (T.alu_op SRC_REG op) ~dst ~src 160 | let alu_i op dst imm = prim (T.alu_op SRC_IMM op) ~dst ~imm 161 | let alu op = (alu_r op, alu_i op) 162 | 163 | let add, addi = alu ADD 164 | let sub, subi = alu SUB 165 | let mul, muli = alu MUL 166 | let div, divi = alu DIV 167 | let or_, ori = alu OR 168 | let and_, andi = alu AND 169 | let lsh, lshi = alu LSH 170 | let rsh, rshi = alu RSH 171 | let neg, negi = alu NEG 172 | let mod_, modi = alu MOD 173 | let xor, xori = alu XOR 174 | let mov, movi = alu MOV 175 | let arsh, arshi = alu ARSH 176 | 177 | end 178 | 179 | module I64 = ALU(struct let alu_op s op = ALU64 (s,op) end) 180 | module I32 = ALU(struct let alu_op s op = ALU (s,op) end) 181 | 182 | include I64 183 | 184 | let endian_ source imm dst = prim (ALU (source, END)) ~dst ~imm 185 | let endian imm = (endian_ SRC_IMM imm, endian_ SRC_REG imm) 186 | 187 | let le16, be16 = endian 16 188 | let le32, be32 = endian 32 189 | let le64, be64 = endian 64 190 | 191 | module Bits = struct 192 | 193 | let bpf_ld = 0x00 194 | let bpf_ldx = 0x01 195 | let bpf_st = 0x02 196 | let bpf_stx = 0x03 197 | let bpf_alu = 0x04 198 | let bpf_jmp = 0x05 199 | let bpf_jmp32 = 0x06 200 | let bpf_alu64 = 0x07 201 | 202 | let mode x = mode_to_enum x lsl 5 203 | let size x = size_to_enum x lsl 3 204 | let op_alu x = op_alu_to_enum x lsl 4 205 | let op_jmp x = op_jmp_to_enum x lsl 4 206 | let source x = source_to_enum x lsl 3 207 | let reg = reg_to_enum 208 | 209 | end 210 | 211 | let encode { op; dst; src; off; imm } = 212 | let open Bits in 213 | let op = 214 | let stld opc sz md = opc + size sz + mode md in 215 | match op with 216 | | LD (sz, md) -> stld bpf_ld sz md 217 | | LDX (sz, md) -> stld bpf_ldx sz md 218 | | ST (sz, md) -> stld bpf_st sz md 219 | | STX (sz, md) -> stld bpf_stx sz md 220 | | ALU (s, op) -> bpf_alu + op_alu op + source s 221 | | JMP (s, op) -> bpf_jmp + op_jmp op + source s 222 | | JMP32 (s, op) -> bpf_jmp32 + op_jmp op + source s 223 | | ALU64 (s, op) -> bpf_alu64 + op_alu op + source s 224 | in 225 | { op; dst = reg dst; src = reg src; off; imm } 226 | 227 | (* TODO host endian? *) 228 | external set_16 : Bytes.t -> int -> int -> unit = "%caml_string_set16" 229 | external set_32 : Bytes.t -> int -> int32 -> unit = "%caml_string_set32" 230 | 231 | let blit buf pos { op; dst; src; off; imm } = 232 | Bytes.set buf (pos+0) (Char.chr op); 233 | Bytes.set buf (pos+1) (Char.chr @@ src lsl 4 + dst); 234 | set_16 buf (pos+2) off; 235 | set_32 buf (pos+4) imm 236 | 237 | let emit insns = 238 | let b = Bytes.create (8 * List.length insns) in 239 | List.iteri (fun i insn -> blit b (8*i) insn) insns; 240 | Bytes.unsafe_to_string b 241 | 242 | let resolve l = 243 | let labels = Hashtbl.create 7 in 244 | (* collect *) 245 | let (_:int) = List.fold_left begin fun pc x -> 246 | match x with 247 | | Prim _ | Jump _ -> pc + 1 248 | | Double _ -> pc + 2 249 | | Label x -> 250 | match Hashtbl.find labels x with 251 | | prev -> fail "Duplicate label at PC %d (previous at %d)" pc prev 252 | | exception Not_found -> Hashtbl.add labels x pc; pc 253 | end 0 l 254 | in 255 | (* resolve *) 256 | List.rev @@ snd @@ List.fold_left begin fun (pc,prog) x -> 257 | match x with 258 | | Prim insn -> (pc + 1, insn :: prog) 259 | | Label _ -> (pc,prog) 260 | | Double (i1, i2) -> (pc + 2, i2 :: i1 :: prog) 261 | | Jump (label,insn) -> 262 | match Hashtbl.find labels label with 263 | | exception Not_found -> fail "Target label at PC %d not found" pc 264 | | target -> (pc + 1, { insn with off = target - (pc + 1) } :: prog) 265 | end (0,[]) l 266 | 267 | type options = { 268 | disable_all_checks : bool; 269 | jump_back : bool; 270 | jump_self : bool; 271 | } 272 | 273 | let default = { 274 | disable_all_checks = false; 275 | jump_back = false; 276 | jump_self = false; 277 | } 278 | 279 | let check options l = 280 | let len = List.length l in 281 | match options.disable_all_checks with 282 | | true -> () 283 | | false -> 284 | l |> List.iteri begin fun pc x -> 285 | try 286 | if not options.jump_self && x.off = (-1) then fail "jump to self (options.jump_self)"; 287 | if not options.jump_back && x.off < 0 then fail "jump backwards (options.jump_back)"; 288 | if not (x.off + pc + 1 >= 0 || x.off + pc + 1 < len) then fail "jump out of bounds : offset %d length %d" x.off len; 289 | with 290 | Failure s -> fail "Error detected at PC %d : %s" pc s 291 | end 292 | 293 | let assemble ?(options=default) l = 294 | let l = resolve l in 295 | check options l; 296 | emit @@ List.map encode l 297 | --------------------------------------------------------------------------------