Implement globals

ml-proto/host/arrange.ml

@@ -217,6 +217,8 @@ let rec expr e =
     | GetLocal x -> "get_local " ^ var x, []
     | SetLocal (x, e) -> "set_local " ^ var x, [expr e]
     | TeeLocal (x, e) -> "tee_local " ^ var x, [expr e]
+    | GetGlobal x -> "get_global " ^ var x, []
+    | SetGlobal (x, e) -> "set_global " ^ var x, [expr e]
     | Load (op, e) -> memop "load" op, [expr e]
     | Store (op, e1, e2) -> memop "store" op, [expr e1; expr e2]
     | LoadExtend (op, e) -> extop op, [expr e]
@@ -276,6 +278,10 @@ let import i im =
     [atom string module_name; atom string func_name; ty]
   )
 
+let global g =
+  let {gtype; init} = g.it in
+  Node ("global", [atom value_type gtype; expr init])
+
 let export ex =
   let {name; kind} = ex.it in
   let desc = match kind with `Func x -> var x | `Memory -> "memory" in
@@ -291,6 +297,7 @@ let module_ m =
     listi func m.it.funcs @
     table m.it.table @
     opt memory m.it.memory @
+    list global m.it.globals @
     list export m.it.exports @
     opt start m.it.start
   )

ml-proto/host/encode.ml

@@ -127,6 +127,8 @@ let encode m =
       | Ast.Get_local x -> op 0x14; var x
       | Ast.Set_local (x, e) -> unary e 0x15; var x
       | Ast.Tee_local (x, e) -> unary e 0x19; var x
+      | Ast.Get_global x -> op 0xbb; var x
+      | Ast.Set_global (x, e) -> unary e 0xbc; var x
 
       | Ast.Call (x, es) -> nary es 0x16; var x
       | Ast.Call_indirect (x, e, es) -> expr e; nary es 0x17; var x
@@ -334,6 +336,14 @@ let encode m =
     let memory_section memo =
       section "memory" (opt memory) memo (memo <> None)
 
+    (* Global section *)
+    let global g =
+      let {gtype = t; init = e} = g.it in
+      value_type t; expr e; op 0x0f
+
+    let global_section gs =
+      section "global" (vec global) gs (gs <> [])
+
     (* Export section *)
     let export exp =
       let {Kernel.name; kind} = exp.it in
@@ -352,11 +362,11 @@ let encode m =
       section "start" (opt var) xo (xo <> None)
 
     (* Code section *)
-    let compress locals =
+    let compress ts =
       let combine t = function
         | (t', n) :: ts when t = t' -> (t, n + 1) :: ts
         | ts -> (t, 1) :: ts
-      in List.fold_right combine locals []
+      in List.fold_right combine ts []
 
     let local (t, n) = vu n; value_type t
 
@@ -390,6 +400,7 @@ let encode m =
       func_section m.it.funcs;
       table_section m.it.table;
       memory_section m.it.memory;
+      global_section m.it.globals;
       export_section m.it.exports;
       start_section m.it.start;
       code_section m.it.funcs;

ml-proto/host/lexer.mll

@@ -160,6 +160,8 @@ rule token = parse
   | "get_local" { GET_LOCAL }
   | "set_local" { SET_LOCAL }
   | "tee_local" { TEE_LOCAL }
+  | "get_global" { GET_GLOBAL }
+  | "set_global" { SET_GLOBAL }
 
   | (nxx as t)".load"
     { LOAD (fun (o, a, e) ->
@@ -360,6 +362,7 @@ rule token = parse
   | "param" { PARAM }
   | "result" { RESULT }
   | "local" { LOCAL }
+  | "global" { GLOBAL }
   | "module" { MODULE }
   | "memory" { MEMORY }
   | "segment" { SEGMENT }

ml-proto/host/parser.mly

@@ -52,11 +52,11 @@ let empty_types () = {tmap = VarMap.empty; tlist = []}
 
 type context =
   {types : types; funcs : space; imports : space;
-   locals : space; labels : int VarMap.t}
+   locals : space; globals : space; labels : int VarMap.t}
 
 let empty_context () =
   {types = empty_types (); funcs = empty (); imports = empty ();
-   locals = empty (); labels = VarMap.empty}
+   locals = empty (); globals = empty (); labels = VarMap.empty}
 
 let enter_func c =
   assert (VarMap.is_empty c.labels);
@@ -73,6 +73,7 @@ let lookup category space x =
 let func c x = lookup "function" c.funcs x
 let import c x = lookup "import" c.imports x
 let local c x = lookup "local" c.locals x
+let global c x = lookup "global" c.globals x
 let label c x =
   try VarMap.find x.it c.labels
   with Not_found -> error x.at ("unknown label " ^ x.it)
@@ -92,6 +93,7 @@ let bind category space x =
 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)}
 
@@ -103,6 +105,7 @@ let anon space n = space.count <- 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 empty_type = {ins = []; out = None}
@@ -127,10 +130,11 @@ let implicit_decl c t at =
 %token NAT INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR
 %token NOP DROP BLOCK IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE
 %token CALL CALL_IMPORT CALL_INDIRECT RETURN
-%token GET_LOCAL SET_LOCAL TEE_LOCAL LOAD STORE OFFSET ALIGN
+%token GET_LOCAL SET_LOCAL TEE_LOCAL GET_GLOBAL SET_GLOBAL
+%token LOAD STORE OFFSET ALIGN
 %token CONST UNARY BINARY COMPARE CONVERT
 %token UNREACHABLE CURRENT_MEMORY GROW_MEMORY
-%token FUNC START TYPE PARAM RESULT LOCAL
+%token FUNC START TYPE PARAM RESULT LOCAL GLOBAL
 %token MODULE MEMORY SEGMENT IMPORT EXPORT TABLE
 %token ASSERT_INVALID ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE
 %token INPUT OUTPUT
@@ -262,6 +266,8 @@ expr1 :
   | GET_LOCAL var { fun c -> Get_local ($2 c local) }
   | SET_LOCAL var expr { fun c -> Set_local ($2 c local, $3 c) }
   | TEE_LOCAL var expr { fun c -> Tee_local ($2 c local, $3 c) }
+  | GET_GLOBAL var { fun c -> Get_global ($2 c global) }
+  | SET_GLOBAL var expr { fun c -> Set_global ($2 c global, $3 c) }
   | LOAD offset align expr { fun c -> $1 ($2, $3, $4 c) }
   | STORE offset align expr expr { fun c -> $1 ($2, $3, $4 c, $5 c) }
   | CONST literal { fun c -> fst (literal $1 $2) }
@@ -350,6 +356,16 @@ export_opt :
 start :
   | LPAR START var RPAR
     { fun c -> $3 c func }
+;
+
+global :
+  | LPAR GLOBAL VALUE_TYPE expr RPAR
+    { let at = at () in
+      fun c -> anon_global c; fun () -> {gtype = $3; init = $4 c} @@ at }
+  | LPAR GLOBAL bind_var VALUE_TYPE expr RPAR  /* Sugar */
+    { let at = at () in
+      fun c -> bind_global c $3; fun () -> {gtype = $4; init = $5 c} @@ at }
+;
 
 segment :
   | LPAR SEGMENT NAT text_list RPAR
@@ -410,11 +426,14 @@ export :
 module_fields :
   | /* empty */
     { fun c ->
-      {memory = None; types = c.types.tlist; funcs = []; start = None; imports = [];
-       exports = []; table = []} }
+      {memory = None; types = c.types.tlist; globals = []; funcs = [];
+       start = None; imports = []; exports = []; table = []} }
   | func module_fields
     { fun c -> let f = $1 c in let m = $2 c in let func, exs = f () in
       {m with funcs = func :: m.funcs; exports = exs @ m.exports} }
+  | global module_fields
+    { fun c -> let g = $1 c in let m = $2 c in
+      {m with globals = g () :: m.globals} }
   | import module_fields
     { fun c -> let i = $1 c in let m = $2 c in
       {m with imports = i :: m.imports} }
@@ -423,7 +442,7 @@ module_fields :
       {m with exports = $1 c :: m.exports} }
   | table module_fields
     { fun c -> let m = $2 c in
-      {m with table = ($1 c) @ m.table} }
+      {m with table = $1 c @ m.table} }
   | type_def module_fields
     { fun c -> $1 c; $2 c }
   | memory module_fields

ml-proto/spec/ast.ml

@@ -26,10 +26,12 @@ and expr' =
   | Call_import of var * expr list
   | Call_indirect of var * expr * expr list
 
-  (* Locals *)
+  (* Variables *)
   | Get_local of var
   | Set_local of var * expr
   | Tee_local of var * expr
+  | Get_global of var
+  | Set_global of var * expr
 
   (* Memory access *)
   | I32_load of Memory.offset * int * expr
@@ -194,7 +196,14 @@ and expr' =
   | Grow_memory of expr
 
 
-(* Functions *)
+(* Globals and Functions *)
+
+type global = global' Source.phrase
+and global' =
+{
+  gtype : Types.value_type;
+  init : expr;
+}
 
 type func = func' Source.phrase
 and func' =
@@ -212,6 +221,7 @@ and module' =
 {
   memory : Kernel.memory option;
   types : Types.func_type list;
+  globals : global list;
   funcs : func list;
   start : var option;
   imports : Kernel.import list;

ml-proto/spec/check.ml

@@ -22,6 +22,7 @@ type context =
   funcs : func_type list;
   imports : func_type list;
   locals : value_type list;
+  globals : value_type list;
   return : expr_type;
   labels : expr_type_future list;
   has_memory : bool
@@ -35,6 +36,7 @@ let type_ types x = lookup "function type" types x
 let func c x = lookup "function" c.funcs x
 let import c x = lookup "import" c.imports x
 let local c x = lookup "local" c.locals x
+let global c x = lookup "global" c.globals x
 let label c x = lookup "label" c.labels x
 
 
@@ -195,6 +197,13 @@ let rec check_expr c et e =
     check_expr c (some (local c x)) e1;
     check_type (Some (local c x)) et e.at
 
+  | GetGlobal x ->
+    check_type (Some (global c x)) et e.at
+
+  | SetGlobal (x, e1) ->
+    check_expr c (some (global c x)) e1;
+    check_type None et e.at
+
   | Load (memop, e1) ->
     check_load c et memop e1 e.at
 
@@ -283,6 +292,11 @@ and check_memop memop at =
 and check_mem_type ty sz at =
   require (ty = Int64Type || sz <> Memory.Mem32) at "memory size too big"
 
+let check_init_expr e =
+  match e.it with
+  | Const _ | GetGlobal _ -> ()
+  | _ -> error e.at "not an initialization expression"
+
 
 (*
  * check_func : context -> func -> unit
@@ -307,6 +321,11 @@ let check_func c f =
 let check_elem c x =
   ignore (func c x)
 
+let check_global c g =
+  let {gtype; init} = g.it in
+  check_init_expr init;
+  check_expr c (some gtype) init
+
 module NameSet = Set.Make(String)
 
 let check_export c set ex =
@@ -345,16 +364,19 @@ let check_memory memory =
   ignore (List.fold_left (check_segment mem.min) 0L mem.segments)
 
 let check_module m =
-  let {memory; types; funcs; start; imports; exports; table} = m.it in
+  let {memory; types; globals; funcs; start; imports; exports; table} = m.it in
   Lib.Option.app check_memory memory;
   let c = {types;
            funcs = List.map (fun f -> type_ types f.it.ftype) funcs;
            imports = List.map (fun i -> type_ types i.it.itype) imports;
+           globals = [];
            locals = [];
            return = None;
            labels = [];
            has_memory = memory <> None} in
-  List.iter (check_func c) funcs;
-  List.iter (check_elem c) table;
-  ignore (List.fold_left (check_export c) NameSet.empty exports);
-  check_start c start
+  List.iter (check_global c) globals;
+  let c' = {c with globals = List.map (fun g -> g.it.gtype) globals} in
+  List.iter (check_func c') funcs;
+  List.iter (check_elem c') table;
+  ignore (List.fold_left (check_export c') NameSet.empty exports);
+  check_start c' start

ml-proto/spec/decode.ml

@@ -250,7 +250,7 @@ let rec expr stack s =
     let x = at var s in
     Tee_local (x, e), es
 
-  | 0x1a | 0x1b | 0x1c | 0x1d | 0x1e | 0x1f as b, _ ->
+  | 0x1c | 0x1d | 0x1e | 0x1f as b, _ ->
     illegal s pos b
 
   | 0x20, e :: es -> let o, a = memop s in I32_load8_s (o, a, e), es
@@ -415,7 +415,14 @@ let rec expr stack s =
   | 0xb9, e2 :: e1 :: es -> I64_rotr (e1, e2), es
   | 0xba, e :: es -> I64_eqz e, es
 
-  | b, _ when b > 0xba -> illegal s pos b
+  | 0xbb, es ->
+    let x = at var s in
+    Get_global x, es
+  | 0xbc, e :: es ->
+    let x = at var s in
+    Set_global (x, e), es
+
+  | b, _ when b > 0xbc -> illegal s pos b
 
   | b, _ -> error s pos "too few operands for operator"
 
@@ -443,6 +450,7 @@ let id s =
   | "function" -> `FuncSection
   | "table" -> `TableSection
   | "memory" -> `MemorySection
+  | "global" -> `GlobalSection
   | "export" -> `ExportSection
   | "start" -> `StartSection
   | "code" -> `CodeSection
@@ -503,6 +511,20 @@ let memory_section s =
   section `MemorySection (opt (at memory) true) None s
 
 
+(* Global section *)
+
+let global s =
+  let t = value_type s in
+  let pos = pos s in
+  let es = expr_block s in
+  require (List.length es = 1) s pos "single expression expected";
+  expect 0x0f s "`end` opcode expected";
+  {gtype = t; init = List.hd es}
+
+let global_section s =
+  section `GlobalSection (vec (at global)) [] s
+
+
 (* Export section *)
 
 let export s =
@@ -574,6 +596,8 @@ let module_ s =
   iterate unknown_section s;
   let memory_limits = memory_section s in
   iterate unknown_section s;
+  let globals = global_section s in
+  iterate unknown_section s;
   let exports = export_section s in
   iterate unknown_section s;
   let start = start_section s in
@@ -596,7 +620,7 @@ let module_ s =
     match memory_limits with
     | None -> None
     | Some memory -> Some Source.({memory.it with segments} @@ memory.at)
-  in {memory; types; funcs; imports; exports; table; start}
+  in {memory; types; globals; funcs; imports; exports; table; start}
 
 
 let decode name bs = at module_ (stream name bs)