128 lines
3.0 KiB
OCaml
128 lines
3.0 KiB
OCaml
module Bc = struct
|
|
[@@@warning "-32"]
|
|
type t = {
|
|
buf : Buffer.t;
|
|
out : out_channel;
|
|
}
|
|
|
|
let make out =
|
|
{ buf = Buffer.create 256; out }
|
|
|
|
let flush t =
|
|
output_string t.out (Buffer.contents t.buf);
|
|
Buffer.clear t.buf
|
|
|
|
let wr_u8 t xs =
|
|
List.iter (Buffer.add_uint8 t.buf) xs
|
|
|
|
let wr_u16 t xs =
|
|
List.iter (Buffer.add_uint16_le t.buf) xs
|
|
|
|
let wr_i32 t xs =
|
|
List.iter (Buffer.add_int32_le t.buf)
|
|
(List.map Int32.of_int xs)
|
|
|
|
type r = [`R of int]
|
|
type v = [r | `K of int]
|
|
type i = [r | `O of int]
|
|
type l = [`L of r * i]
|
|
|
|
let reg v =
|
|
match v with
|
|
| `R i -> assert (0 <= i && i <= 0xff); i
|
|
|
|
let cst i =
|
|
assert (0 <= i && i <= 0xff); i
|
|
|
|
let arg v b0 =
|
|
match v with
|
|
| #r as v -> b0, reg v
|
|
| `K i -> (b0 lor 0x80), cst i
|
|
|
|
let ofs v =
|
|
assert ((-0x80) <= v && v <= 0x7f);
|
|
v land 0xff
|
|
|
|
let loc v b0 =
|
|
match v with
|
|
| `L (r, (#r as i)) -> b0, reg r lor (reg i lsl 8)
|
|
| `L (r, `O i) -> (b0 lor 0x40), reg r lor (ofs i lsl 8)
|
|
|
|
let wr_ins_v b0 t (a : v) =
|
|
let b0, b1 = arg a b0 in
|
|
wr_u8 t [b0; b1]
|
|
|
|
let wr_ins_rv b0 b1 t (a : r) (b : v) =
|
|
let b2 = reg a in
|
|
let b0, b3 = arg b b0 in
|
|
wr_u8 t [b0; b1; b2; b3]
|
|
|
|
let wr_ins_rl b0 t (a : r) (b : l) =
|
|
let b1 = reg a in
|
|
let b0, s2 = loc b b0 in
|
|
wr_u8 t [b0; b1]; wr_u16 t [s2]
|
|
|
|
let wr_ins_lv b0 t (b : l) (a : v) =
|
|
let b0, b1 = arg a b0 in
|
|
let b0, s2 = loc b b0 in
|
|
wr_u8 t [b0; b1]; wr_u16 t [s2]
|
|
|
|
let wr_op o t a b =
|
|
assert (o >= 0x0 && o <= 0xf);
|
|
wr_ins_rv 0x07 o t a b
|
|
|
|
let wr_cb c t a b =
|
|
assert (c >= 0xa && c <= 0xf);
|
|
wr_ins_rv 0x17 c t a b
|
|
|
|
let mov t a b =
|
|
match a, b with
|
|
| (#r as a), (#v as b) -> wr_ins_rv 0x01 0x00 t a b
|
|
| (#r as a), (#l as b) -> wr_ins_rl 0x03 t a b
|
|
| (#l as a), (#v as b) -> wr_ins_lv 0x05 t a b
|
|
| #l, #l -> failwith "'mov L, L' mode unsupported"
|
|
|
|
let jmp t d =
|
|
let b0 = 0xff in
|
|
let w0 = b0 lor (d lsl 8) in
|
|
wr_i32 t [w0]
|
|
|
|
let ret = wr_ins_v 0x00
|
|
let btr = wr_ins_v 0x04
|
|
let bfl = wr_ins_v 0x14
|
|
let con = wr_op 0x0
|
|
let not_= wr_op 0x1
|
|
let neg = wr_op 0x2
|
|
let add = wr_op 0x3
|
|
let sub = wr_op 0x4
|
|
let mul = wr_op 0x5
|
|
let div = wr_op 0x6
|
|
let mod_= wr_op 0x7
|
|
let ceq = wr_op 0xa let beq = wr_cb 0xa
|
|
let cne = wr_op 0xb let bne = wr_cb 0xb
|
|
let clt = wr_op 0xc let blt = wr_cb 0xc
|
|
let cge = wr_op 0xd let bge = wr_cb 0xd
|
|
let cgt = wr_op 0xe let bgt = wr_cb 0xe
|
|
let cle = wr_op 0xf let ble = wr_cb 0xf
|
|
end
|
|
|
|
let bc = Bc.make stdout
|
|
|
|
let () =
|
|
begin
|
|
Bc.mov bc (`R 0) (`K 0); (* 0 *)
|
|
Bc.mov bc (`R 1) (`K 1); (* 2 *)
|
|
Bc.bgt bc (`R 0) (`R 1); (* 4 *)
|
|
Bc.jmp bc (+9 (* L3 *)); (* 6 *)
|
|
Bc.jmp bc (+3 (* L2 *)); (* 8 *)
|
|
Bc.ret bc (`R 1); (* L1: 10 *)
|
|
Bc.add bc (`R 1) (`K 2); (* L2: 11 *)
|
|
Bc.jmp bc (-3 (* L1 *)); (* 13 *)
|
|
Bc.mul bc (`R 1) (`R 1); (* L3: 15 *)
|
|
Bc.jmp bc (-7 (* L1 *)); (* 17 *)
|
|
end
|
|
|
|
let () =
|
|
Bc.flush bc
|
|
|