A couple of simple 0xc binary changes

ml-proto/given/lib.ml

@@ -19,6 +19,14 @@ struct
     | n, _::xs' when n > 0 -> drop (n - 1) xs'
     | _ -> failwith "drop"
 
+  let length32 xs = Int32.of_int (List.length xs)
+
+  let rec nth32 xs n =
+  match n, xs with
+    | 0l, x::_ -> x
+    | n, _::xs' when n > 0l -> nth32 xs' (Int32.sub n 1l)
+    | _ -> failwith "nth32"
+
   let rec last = function
     | x::[] -> x
     | _::xs -> last xs

ml-proto/given/lib.mli

@@ -7,6 +7,9 @@ sig
   val take : int -> 'a list -> 'a list (* raise Failure *)
   val drop : int -> 'a list -> 'a list (* raise Failure *)
 
+  val length32 : 'a list -> int32
+  val nth32 : 'a list -> int32 -> 'a (* raise Failure *)
+
   val last : 'a list -> 'a (* raise Failure *)
   val split_last : 'a list -> 'a list * 'a (* raise Failure *)
 

ml-proto/host/arrange.ml

@@ -192,7 +192,7 @@ let storeop op =
 
 (* Expressions *)
 
-let var x = string_of_int x.it
+let var x = Int32.to_string x.it
 let value v = string_of_value v.it
 let constop v = value_type (type_of v.it) ^ ".const"
 

ml-proto/host/encode.ml

@@ -63,14 +63,15 @@ let encode m =
     let vec f xs = vu (List.length xs); list f xs
     let vec1 f xo = bool (xo <> None); opt f xo
 
-    let gap () = let p = pos s in u32 0l; p
-    let patch_gap p n =
+    let gap32 () = let p = pos s in u32 0l; u8 0; p
+    let patch_gap32 p n =
       assert (n <= 0x0fff_ffff); (* Strings cannot excess 2G anyway *)
       let lsb i = Char.chr (i land 0xff) in
       patch s p (lsb (n lor 0x80));
       patch s (p + 1) (lsb ((n lsr 7) lor 0x80));
       patch s (p + 2) (lsb ((n lsr 14) lor 0x80));
-      patch s (p + 3) (lsb (n lsr 21))
+      patch s (p + 3) (lsb ((n lsr 21) lor 0x80));
+      patch s (p + 4) (lsb (n lsr 28))
 
     (* Types *)
 
@@ -98,8 +99,7 @@ let encode m =
     let op n = u8 n
     let memop {align; offset; _} = vu align; vu64 offset  (*TODO: to be resolved*)
 
-    let var x = vu x.it
-    let var32 x = vu32 (Int32.of_int x.it)
+    let var x = vu32 x.it
 
     let rec instr e =
       match e.it with
@@ -113,7 +113,7 @@ let encode m =
       | Select -> op 0x05
       | Br (n, x) -> op 0x06; vu n; var x
       | BrIf (n, x) -> op 0x07; vu n; var x
-      | BrTable (n, xs, x) -> op 0x08; vu n; vec var32 xs; var32 x
+      | BrTable (n, xs, x) -> op 0x08; vu n; vec var xs; var x
       | Return -> op 0x09
       | Nop -> op 0x0a
       | Drop -> op 0x0b
@@ -334,30 +334,30 @@ let encode m =
 
     let section id f x needed =
       if needed then begin
-        string id;
-        let g = gap () in
+        u8 id;
+        let g = gap32 () in
         let p = pos s in
         f x;
-        patch_gap g (pos s - p)
+        patch_gap32 g (pos s - p)
       end
 
     (* Type section *)
     let type_section ts =
-      section "type" (vec func_type) ts (ts <> [])
+      section 1 (vec func_type) ts (ts <> [])
 
     (* Import section *)
     let import imp =
       let {itype; module_name; func_name} = imp.it in
       var itype; string module_name; string func_name
 
     let import_section imps =
-      section "import" (vec import) imps (imps <> [])
+      section 2 (vec import) imps (imps <> [])
 
     (* Function section *)
     let func f = var f.it.ftype
 
     let func_section fs =
-      section "function" (vec func) fs (fs <> [])
+      section 3 (vec func) fs (fs <> [])
 
     (* Table section *)
     let limits vu lim =
@@ -369,23 +369,23 @@ let encode m =
       elem_type etype; limits vu32 tlimits
 
     let table_section tabo =
-      section "table" (opt table) tabo (tabo <> None)
+      section 4 (opt table) tabo (tabo <> None)
 
     (* Memory section *)
     let memory mem =
       let {mlimits} = mem.it in
       limits vu32 mlimits
 
     let memory_section memo =
-      section "memory" (opt memory) memo (memo <> None)
+      section 5 (opt memory) memo (memo <> None)
 
     (* Global section *)
     let global g =
       let {gtype; value} = g.it in
       value_type gtype; const value
 
     let global_section gs =
-      section "global" (vec global) gs (gs <> [])
+      section 6 (vec global) gs (gs <> [])
 
     (* Export section *)
     let export exp =
@@ -398,11 +398,11 @@ let encode m =
     let export_section exps =
       (*TODO: pending resolution*)
       let exps = List.filter (fun exp -> exp.it.kind <> `Memory) exps in
-      section "export" (vec export) exps (exps <> [])
+      section 7 (vec export) exps (exps <> [])
 
     (* Start section *)
     let start_section xo =
-      section "start" (opt var) xo (xo <> None)
+      section 8 (opt var) xo (xo <> None)
 
     (* Code section *)
     let compress ts =
@@ -415,14 +415,15 @@ let encode m =
 
     let code f =
       let {locals; body; _} = f.it in
-      vec local (compress locals);
-      let g = gap () in
+      let g = gap32 () in
       let p = pos s in
+      vec local (compress locals);
       list instr body;
-      patch_gap g (pos s - p)
+      u8 0x0f;
+      patch_gap32 g (pos s - p)
 
     let code_section fs =
-      section "code" (vec code) fs (fs <> [])
+      section 9 (vec code) fs (fs <> [])
 
     (* Element section *)
     let segment dat seg =
@@ -433,14 +434,14 @@ let encode m =
       segment (vec var) seg
 
     let elem_section elems =
-      section "element" (vec table_segment) elems (elems <> [])
+      section 10 (vec table_segment) elems (elems <> [])
 
     (* Data section *)
     let memory_segment seg =
       segment string seg
 
     let data_section data =
-      section "data" (vec memory_segment) data (data <> [])
+      section 11 (vec memory_segment) data (data <> [])
 
     (* Module *)
 
@@ -455,8 +456,8 @@ let encode m =
       global_section m.it.globals;
       export_section m.it.exports;
       start_section m.it.start;
-      code_section m.it.funcs;
       elem_section m.it.elems;
+      code_section m.it.funcs;
       data_section m.it.data
   end
   in E.module_ m; to_string s

ml-proto/host/import.ml

@@ -13,7 +13,7 @@ let register name lookup = registry := Registry.add name lookup !registry
 
 let lookup m import =
   let {module_name; func_name; itype} = import.it in
-  let ty = List.nth m.it.types itype.it in
+  let ty = Lib.List.nth32 m.it.types itype.it in
   try Registry.find module_name !registry func_name ty with Not_found ->
     Unknown.error import.at
       ("no function \"" ^ module_name ^ "." ^ func_name ^

ml-proto/host/parser.mly

@@ -35,36 +35,31 @@ let ati i =
 (* Literals *)
 
 let literal f s =
-  try f s with
-  | Failure msg -> error s.at ("constant out of range: " ^ msg)
-  | _ -> error s.at "constant out of range"
+  try f s with Failure _ -> error s.at ("constant out of range")
 
 let int s at =
-  try int_of_string s with Failure _ ->
-    error at "int constant out of range"
+  try int_of_string s with Failure _ -> error at "int constant out of range"
 
 let int32 s at =
-  try I32.of_string s with Failure _ ->
-    error at "i32 constant out of range"
+  try I32.of_string s with Failure _ -> error at "i32 constant out of range"
 
 let int64 s at =
-  try I64.of_string s with Failure _ ->
-    error at "i64 constant out of range"
+  try I64.of_string s with Failure _ -> error at "i64 constant out of range"
 
 
 (* Symbolic variables *)
 
 module VarMap = Map.Make(String)
 
-type space = {mutable map : int VarMap.t; mutable count : int}
-let empty () = {map = VarMap.empty; count = 0}
+type space = {mutable map : int32 VarMap.t; mutable count : int32}
+let empty () = {map = VarMap.empty; count = 0l}
 
-type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list}
+type types = {mutable tmap : int32 VarMap.t; mutable tlist : Types.func_type list}
 let empty_types () = {tmap = VarMap.empty; tlist = []}
 
 type context =
   {types : types; funcs : space; imports : space;
-   locals : space; globals : space; labels : int VarMap.t}
+   locals : space; globals : space; labels : int32 VarMap.t}
 
 let empty_context () =
   {types = empty_types (); funcs = empty (); imports = empty ();
@@ -93,49 +88,50 @@ let label c x =
 let bind_type c x ty =
   if VarMap.mem x.it c.types.tmap then
     error x.at ("duplicate type " ^ x.it);
-  c.types.tmap <- VarMap.add x.it (List.length c.types.tlist) c.types.tmap;
+  c.types.tmap <-
+    VarMap.add x.it (Lib.List.length32 c.types.tlist) c.types.tmap;
   c.types.tlist <- c.types.tlist @ [ty]
 
 let bind category space x =
   if VarMap.mem x.it space.map then
     error x.at ("duplicate " ^ category ^ " " ^ x.it);
   space.map <- VarMap.add x.it space.count space.map;
-  space.count <- space.count + 1
+  space.count <- Int32.add space.count 1l
 
 let bind_func c x = bind "function" c.funcs x
 let bind_import c x = bind "import" c.imports x
 let bind_local c x = bind "local" c.locals x
 let bind_global c x = bind "global" c.globals x
 let bind_label c x =
-  {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)}
+  {c with labels = VarMap.add x.it 0l (VarMap.map (Int32.add 1l) c.labels)}
 
 let anon_type c ty =
   c.types.tlist <- c.types.tlist @ [ty]
 
-let anon space n = space.count <- space.count + n
+let anon space n = space.count <- Int32.add space.count n
 
-let anon_func c = anon c.funcs 1
-let anon_import c = anon c.imports 1
-let anon_locals c ts = anon c.locals (List.length ts)
-let anon_global c = anon c.globals 1
-let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels}
+let anon_func c = anon c.funcs 1l
+let anon_import c = anon c.imports 1l
+let anon_locals c ts = anon c.locals (Lib.List.length32 ts)
+let anon_global c = anon c.globals 1l
+let anon_label c = {c with labels = VarMap.map (Int32.add 1l) c.labels}
 
 let empty_type = FuncType ([], [])
 
 let explicit_decl c name t at =
   let x = name c type_ in
   if
-    x.it < List.length c.types.tlist &&
+    x.it < Lib.List.length32 c.types.tlist &&
     t <> empty_type &&
-    t <> List.nth c.types.tlist x.it
+    t <> Lib.List.nth32 c.types.tlist x.it
   then
     error at "signature mismatch";
   x
 
 let implicit_decl c t at =
   match Lib.List.index_of t c.types.tlist with
-  | None -> let i = List.length c.types.tlist in anon_type c t; i @@ at
-  | Some i -> i @@ at
+  | None -> let i = Lib.List.length32 c.types.tlist in anon_type c t; i @@ at
+  | Some i -> Int32.of_int i @@ at
 
 %}
 
@@ -222,7 +218,7 @@ literal :
 ;
 
 var :
-  | NAT { let at = at () in fun c lookup -> int $1 at @@ at }
+  | NAT { let at = at () in fun c lookup -> int32 $1 at @@ at }
   | VAR { let at = at () in fun c lookup -> lookup c ($1 @@ at) @@ at }
 ;
 var_list :
@@ -358,7 +354,7 @@ func_body :
   | instr_list
     { empty_type,
       fun c -> let c' = anon_label c in
-      {ftype = -1 @@ at(); locals = []; body = $1 c'} }
+      {ftype = -1l @@ at(); locals = []; body = $1 c'} }
   | LPAR LOCAL value_type_list RPAR func_body
     { fst $5,
       fun c -> anon_locals c $3; let f = (snd $5) c in
@@ -397,7 +393,8 @@ export_opt :
   | /* empty */ { fun c -> [] }
   | TEXT
     { let at = at () in
-      fun c -> [{name = $1; kind = `Func (c.funcs.count - 1 @@ at)} @@ at] }
+      fun c ->
+      [{name = $1; kind = `Func (Int32.sub c.funcs.count 1l @@ at)} @@ at] }
 ;
 
 

ml-proto/host/print.ml

@@ -8,7 +8,7 @@ open Printf
 open Types
 
 let func_type m f =
-  List.nth m.it.types f.it.ftype.it
+  Lib.List.nth32 m.it.types f.it.ftype.it
 
 let string_of_table_type = function
   | None -> "()"
@@ -25,12 +25,12 @@ let print_export m i ex =
   let {name; kind} = ex.it in
   let ascription =
     match kind with
-    | `Func x -> string_of_func_type (func_type m (List.nth m.it.funcs x.it))
+    | `Func x -> string_of_func_type (func_type m (Lib.List.nth32 m.it.funcs x.it))
     | `Memory -> "memory"
   in printf "export \"%s\" : %s\n" name ascription
 
 let print_start start =
-  Lib.Option.app (fun x -> printf "start = func %d\n" x.it) start
+  Lib.Option.app (fun x -> printf "start = func %ld\n" x.it) start
 
 
 (* Ast *)

ml-proto/spec/ast.ml

@@ -70,7 +70,7 @@ type storeop = Memory.mem_size memop
 
 (* Expressions *)
 
-type var = int Source.phrase
+type var = int32 Source.phrase
 type literal = value Source.phrase
 
 type instr = instr' Source.phrase

ml-proto/spec/check.ml

@@ -36,8 +36,8 @@ type context =
 }
 
 let lookup category list x =
-  try List.nth list x.it with Failure _ ->
-    error x.at ("unknown " ^ category ^ " " ^ string_of_int x.it)
+  try Lib.List.nth32 list x.it with Failure _ ->
+    error x.at ("unknown " ^ category ^ " " ^ Int32.to_string x.it)
 
 let type_ types x = lookup "function type" types x
 let func c x = lookup "function" c.funcs x