ocaml encoder POC

bin/bctest.ml

@@ -0,0 +1,123 @@
+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 write_16 t x =
+    assert (Int64.to_int x land 3 = 1);
+    Buffer.add_int16_le t.buf (Int64.to_int x)
+
+  let write_32 t x =
+    assert (Int64.to_int x land 3 = 2);
+    Buffer.add_int32_le t.buf (Int64.to_int32 x)
+
+  let write_48 _t x =
+    assert (x land 3 = 3);
+    failwith "..."
+
+  let ( << ) = Int64.shift_left
+  let ( |+ ) = Int64.logor
+  let _0 = Int64.zero
+  let _1 = Int64.one
+
+  let rep_uint i =
+    assert (0 <= i && i < 0x400);
+    Int64.of_int i
+
+  let rep_sint i =
+    assert (-0x200 <= i && i < 0x200);
+    Int64.of_int (i land 0x3ff)
+
+  let rep_s24 i =
+    assert (-0x800000 <= i && i < 0x800000);
+    Int64.of_int (i land 0xffffff)
+
+  type r = [`R of int]
+  type v = [r | `K of int]
+  type l = [`SubI of r * int | `SubR of r * r]
+
+  let rep_v : [< v] -> int64 = function
+    | `R i -> (rep_uint i) |+ (_0 << 10)
+    | `K i -> (rep_uint i) |+ (_1 << 10)
+
+  let rep_r : [< r] -> int64 =
+    rep_v
+
+  let rep_l : l -> int64 = function
+    | `SubI (a, i) -> (rep_r a) |+ (rep_sint i << 10) |+ (_0 << 20)
+    | `SubR (a, i) -> (rep_r a) |+ (rep_r i    << 10) |+ (_1 << 20)
+
+  let write_v i t a =
+    assert (i >= 0 && i <= 32 && (i land 7 = 5));
+    write_16 t (Int64.of_int i |+ (rep_v a << 5))
+
+  let write_rv i t a b =
+    assert (i >= 0 && i <= 255 && (i land 7 = 2));
+    write_32 t (Int64.of_int i |+ (rep_r a << 8) |+ (rep_v b << 18))
+
+  let write_o i t o =
+    write_32 t (Int64.of_int i |+ (rep_s24 o << 8))
+
+  let write_opr i t a b =
+    match a, b with
+    | (#r as a), (#v as b) -> write_rv i t a b
+    | (#r as a), (#l as b) -> let _ = (a,b) in failwith "..."
+
+  let write_cbr i t a b =
+    write_rv (i lor 8) t a b
+
+  let ret = write_v 0x05
+  let btr = write_v 0x0d
+  let jmp = write_o 0x06
+  let mov = write_opr 0x02
+  let con = write_opr 0x12
+  let add = write_opr 0x22
+  let sub = write_opr 0x32
+  let mul = write_opr 0x42
+  let div = write_opr 0x52
+  let mod_= write_opr 0x62
+  let neg_= write_opr 0x72
+  let not_= write_opr 0x82
+  (* let ? = write_opr 0x92 *)
+  let ceq = write_opr 0xa2
+  let beq = write_cbr 0xa2
+  let cne = write_opr 0xb2
+  let bne = write_cbr 0xb2
+  let clt = write_opr 0xc2
+  let blt = write_cbr 0xc2
+  let cge = write_opr 0xd2
+  let bge = write_cbr 0xd2
+  let cgt = write_opr 0xe2
+  let bgt = write_cbr 0xe2
+  let cle = write_opr 0xf2
+  let ble = write_cbr 0xf2
+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 0);        (* L1: 10 *)
+    Bc.mov bc (`R 0) (`K 2); (* L2: 11 *)
+    Bc.jmp bc (-3 (* L1 *)); (*     13 *)
+    Bc.mov bc (`R 0) (`K 3); (* L3: 15 *)
+    Bc.jmp bc (-7 (* L1 *)); (*     17 *)
+  end
+
+let () =
+  Bc.flush bc
+

bin/dune

@@ -1,4 +1,11 @@
 (executable
  (public_name spicec)
  (name main)
+ (modules main)
  (libraries spice fmt logs))
+
+(executable
+ (public_name spice_bctest)
+ (name bctest)
+ (modules bctest)
+ (libraries fmt logs))