Implement mutable globals

ml-proto/README.md

@@ -150,7 +150,7 @@ result:  ( result <type> )
 local:   ( local <type>* ) | ( local <name> <type> )
 
 func_sig:   ( type <var> ) | <param>* <result>?
-global_sig: <type>
+global_sig: <type> | ( mut <type> )
 table_sig:  <nat> <nat>? <elem_type>
 memory_sig: <nat> <nat>?
 

ml-proto/host/arrange.ml

@@ -56,6 +56,10 @@ let struct_type = func_type
 let limits int {min; max} =
   String.concat " " (int min :: opt int max)
 
+let global_type = function
+  | GlobalType (t, Immutable) -> atom string_of_value_type t
+  | GlobalType (t, Mutable) -> Node ("mut", [atom string_of_value_type t])
+
 
 (* Operators *)
 
@@ -296,8 +300,7 @@ let import_kind i k =
     Node ("func $" ^ string_of_int i, [Node ("type", [atom var x])])
   | TableImport t -> table 0 i ({ttype = t} @@ k.at)
   | MemoryImport t -> memory 0 i ({mtype = t} @@ k.at)
-  | GlobalImport t ->
-    Node ("global $" ^ string_of_int i, [atom value_type t])
+  | GlobalImport t -> Node ("global $" ^ string_of_int i, [global_type t])
 
 let import i im =
   let {module_name; item_name; ikind} = im.it in
@@ -320,9 +323,7 @@ let export ex =
 
 let global off i g =
   let {gtype; value} = g.it in
-  Node ("global $" ^ string_of_int (off + i),
-    [atom value_type gtype; expr value]
-  )
+  Node ("global $" ^ string_of_int (off + i), [global_type gtype; expr value])
 
 
 (* Modules *)

ml-proto/host/encode.ml

@@ -100,6 +100,13 @@ let encode m =
     let memory_type = function
       | MemoryType lim -> limits vu32 lim
 
+    let mutability = function
+      | Immutable -> u8 0
+      | Mutable -> u8 1
+
+    let global_type = function
+      | GlobalType (t, mut) -> value_type t; mutability mut
+
     (* Expressions *)
 
     open Source
@@ -330,7 +337,7 @@ let encode m =
       | FuncImport x -> u8 0x00; var x
       | TableImport t -> u8 0x01; table_type t
       | MemoryImport t -> u8 0x02; memory_type t
-      | GlobalImport t -> u8 0x03; value_type t
+      | GlobalImport t -> u8 0x03; global_type t
 
     let import imp =
       let {module_name; item_name; ikind} = imp.it in
@@ -364,7 +371,7 @@ let encode m =
     (* Global section *)
     let global g =
       let {gtype; value} = g.it in
-      value_type gtype; expr value; op 0x0f
+      global_type gtype; expr value; op 0x0f
 
     let global_section gs =
       section "global" (vec global) gs (gs <> [])

ml-proto/host/import/spectest.ml

@@ -26,7 +26,7 @@ let lookup name t =
   match name, t with
   | "print", ExternalFuncType ft -> ExternalFunc (HostFunc (print ft.out))
   | "print", _ -> ExternalFunc (HostFunc (print None))
-  | "global", ExternalGlobalType t -> ExternalGlobal (global t)
+  | "global", ExternalGlobalType (GlobalType (t, _)) -> ExternalGlobal (global t)
   | "global", _ -> ExternalGlobal (global Int32Type)
   | "table", _ -> ExternalTable table
   | "memory", _ -> ExternalMemory memory

ml-proto/host/lexer.mll

@@ -140,6 +140,7 @@ rule token = parse
           F64_const (n @@ s.at), Values.Float64 n))
     }
   | "anyfunc" { ANYFUNC }
+  | "mut" { MUT }
 
   | "nop" { NOP }
   | "unreachable" { UNREACHABLE }

ml-proto/host/parser.mly

@@ -145,7 +145,7 @@ let inline_type c t at =
 
 %}
 
-%token NAT INT FLOAT TEXT VAR VALUE_TYPE ANYFUNC LPAR RPAR
+%token NAT INT FLOAT TEXT VAR VALUE_TYPE ANYFUNC MUT LPAR RPAR
 %token NOP DROP BLOCK IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE
 %token CALL CALL_INDIRECT RETURN
 %token GET_LOCAL SET_LOCAL TEE_LOCAL GET_GLOBAL SET_GLOBAL
@@ -205,6 +205,11 @@ elem_type :
   | ANYFUNC { AnyFuncType }
 ;
 
+global_type :
+  | VALUE_TYPE { GlobalType ($1, Immutable) }
+  | LPAR MUT VALUE_TYPE RPAR { GlobalType ($3, Mutable) }
+;
+
 func_type :
   | LPAR FUNC func_sig RPAR { $3 }
 ;
@@ -397,7 +402,7 @@ func :
 ;
 
 
-/* Tables & Memories */
+/* Tables, Memories & Globals */
 
 elem :
   | LPAR ELEM var expr var_list RPAR
@@ -453,6 +458,19 @@ memory :
       [] }
 ;
 
+global :
+  | LPAR GLOBAL bind_var_opt inline_export global_type expr RPAR
+    { let at = at () in
+      fun c -> $3 c anon_global bind_global;
+      (fun () -> {gtype = $5; value = $6 c} @@ at),
+      $4 GlobalExport c.globals.count c }
+  /* Need to duplicate above for empty inline_export_opt to avoid LR(1) conflict. */
+  | LPAR GLOBAL bind_var_opt global_type expr RPAR
+    { let at = at () in
+      fun c -> $3 c anon_global bind_global;
+      (fun () -> {gtype = $4; value = $5 c} @@ at), [] }
+;
+
 
 /* Imports & Exports */
 
@@ -466,7 +484,7 @@ import_kind :
     { fun c -> $3 c anon_table bind_table; TableImport $4 }
   | LPAR MEMORY bind_var_opt memory_sig RPAR
     { fun c -> $3 c anon_memory bind_memory; MemoryImport $4 }
-  | LPAR GLOBAL bind_var_opt VALUE_TYPE RPAR
+  | LPAR GLOBAL bind_var_opt global_type RPAR
     { fun c -> $3 c anon_global bind_global; GlobalImport $4 }
 ;
 import :
@@ -489,7 +507,7 @@ import :
     { let at = at () in
       fun c -> $3 c anon_memory bind_memory;
       {module_name = fst $4; item_name = snd $4; ikind = MemoryImport $5 @@ at} @@ at }
-  | LPAR GLOBAL bind_var_opt inline_import VALUE_TYPE RPAR  /* Sugar */
+  | LPAR GLOBAL bind_var_opt inline_import global_type RPAR  /* Sugar */
     { let at = at () in
       fun c -> $3 c anon_global bind_global;
       {module_name = fst $4; item_name = snd $4; ikind = GlobalImport $5 @@ at} @@ at }
@@ -532,14 +550,6 @@ type_def :
     { fun c -> bind_type c $3 $4 }
 ;
 
-global :
-  | LPAR GLOBAL bind_var_opt inline_export_opt VALUE_TYPE expr RPAR
-    { let at = at () in
-      fun c -> $3 c anon_global bind_global;
-      (fun () -> {gtype = $5; value = $6 c} @@ at),
-      $4 GlobalExport c.globals.count c }
-;
-
 start :
   | LPAR START var RPAR
     { fun c -> $3 c func }

ml-proto/host/print.ml

@@ -1,27 +1,25 @@
 open Kernel
 open Source
 open Printf
+open Types
 
 
-(* Types *)
-
-open Types
+(* Ast *)
 
-let print_no_sig prefix i =
-  printf "%s %d\n" prefix i
+let print_sig prefix i string_of_type t =
+  printf "%s %d : %s\n" prefix i (string_of_type t)
 
-let print_var_sig prefix i t =
-  printf "%s %d : %s\n" prefix i (string_of_value_type t)
+let print_func m i f =
+  print_sig "func" i string_of_func_type (List.nth m.it.types f.it.ftype.it)
 
-let print_func_sig m prefix i x =
-  let t = List.nth m.it.types x.it in
-  printf "%s %d : %s\n" prefix i (string_of_func_type t)
+let print_table m i tab =
+  print_sig "table" i string_of_table_type tab.it.ttype
 
-let print_table_sig prefix i t =
-  printf "%s %d : %s\n" prefix i (string_of_table_type t)
+let print_memory m i mem =
+  print_sig "memory" i string_of_memory_type mem.it.mtype
 
-let print_memory_sig prefix i t =
-  printf "%s %d : %s\n" prefix i (string_of_memory_type t)
+let print_global m i glob =
+  print_sig "global" i string_of_global_type glob.it.gtype
 
 let print_export m i ex =
   let {name; ekind; item} = ex.it in
@@ -36,21 +34,6 @@ let print_export m i ex =
 let print_start start =
   Lib.Option.app (fun x -> printf "start = func %d\n" x.it) start
 
-
-(* Ast *)
-
-let print_func m i f =
-  print_func_sig m "func" i f.it.ftype
-
-let print_global m i glob =
-  print_var_sig "global" i glob.it.gtype
-
-let print_table m i tab =
-  print_table_sig "table" i tab.it.ttype
-
-let print_memory m i mem =
-  print_memory_sig "memory" i mem.it.mtype
-
 let print_module m =
   (* TODO: more complete print function *)
   let {funcs; globals; tables; memories; start; exports; _} = m.it in
@@ -77,4 +60,3 @@ let print_value vo =
   | None ->
       printf "()\n";
       flush_all ()
-

ml-proto/spec/ast.ml

@@ -200,7 +200,7 @@ and expr' =
 type global = global' Source.phrase
 and global' =
 {
-  gtype : Types.value_type;
+  gtype : Types.global_type;
   value : expr;
 }
 

ml-proto/spec/check.ml

@@ -22,7 +22,7 @@ type context =
   types : func_type list;
   funcs : func_type list;
   locals : value_type list;
-  globals : value_type list;
+  globals : global_type list;
   return : expr_type;
   labels : expr_type_future list;
   tables : table_type list;
@@ -201,10 +201,13 @@ let rec check_expr c et e =
     check_type (Some (local c x)) et e.at
 
   | GetGlobal x ->
-    check_type (Some (global c x)) et e.at
+    let GlobalType (t, mut) = global c x in
+    check_type (Some t) et e.at
 
   | SetGlobal (x, e1) ->
-    check_expr c (some (global c x)) e1;
+    let GlobalType (t, mut) = global c x in
+    require (mut = Mutable) x.at "global is immutable";
+    check_expr c (some t) e1;
     check_type None et e.at
 
   | Load (memop, e1) ->
@@ -322,7 +325,7 @@ let check_func c f =
   check_expr c' (known s.out) body
 
 
-(* Tables & Memories *)
+(* Tables, Memories, & Globals *)
 
 let check_table_type (t : table_type) at =
   let TableType ({min; max}, _) = t in
@@ -381,14 +384,15 @@ let check_memory_segment c prev_end seg =
     "data segment does not fit into memory";
   end_
 
-
-(* Modules *)
-
 let check_global c glob =
   let {gtype; value} = glob.it in
-  check_const c gtype value;
+  let GlobalType (t, mut) = gtype in
+  check_const c t value;
   {c with globals = c.globals @ [gtype]}
 
+
+(* Modules *)
+
 let check_start c start =
   Lib.Option.app (fun x ->
     let start_type = func c x in
@@ -408,6 +412,8 @@ let check_import im c =
   | MemoryImport t ->
     check_memory_type t ikind.at; {c with memories = t :: c.memories}
   | GlobalImport t ->
+    let GlobalType (_, mut) = t in
+    require (mut = Immutable) ikind.at "mutable globals cannot be imported (yet)";
     {c with globals = t :: c.globals}
 
 module NameSet = Set.Make(String)
@@ -418,7 +424,9 @@ let check_export c set ex =
   | FuncExport -> ignore (func c item)
   | TableExport -> ignore (table c item)
   | MemoryExport -> ignore (memory c item)
-  | GlobalExport -> ignore (global c item)
+  | GlobalExport ->
+    let GlobalType (_, mut) = global c item in
+    require (mut = Immutable) ekind.at "mutable globals cannot be exported (yet)"
   );
   require (not (NameSet.mem name set)) ex.at "duplicate export name";
   NameSet.add name set

ml-proto/spec/decode.ml

@@ -149,6 +149,17 @@ let memory_type s =
   let lim = limits vu32 s in
   MemoryType lim
 
+let mutability s =
+  match u8 s with
+  | 0 -> Immutable
+  | 1 -> Mutable
+  | _ -> error s (pos s - 1) "invalid mutability"
+
+let global_type s =
+  let t = value_type s in
+  let mut = mutability s in
+  GlobalType (t, mut)
+
 
 (* Decode expressions *)
 
@@ -505,7 +516,7 @@ let import_kind s =
   | 0x00 -> FuncImport (at var s)
   | 0x01 -> TableImport (table_type s)
   | 0x02 -> MemoryImport (memory_type s)
-  | 0x03 -> GlobalImport (value_type s)
+  | 0x03 -> GlobalImport (global_type s)
   | _ -> error s (pos s - 1) "invalid import kind"
 
 let import s =
@@ -547,7 +558,7 @@ let memory_section s =
 (* Global section *)
 
 let global s =
-  let t = value_type s in
+  let t = global_type s in
   let pos = pos s in
   let es = expr_block s in
   require (List.length es = 1) s pos "single expression expected";

ml-proto/spec/eval.ml

@@ -320,7 +320,7 @@ let create_memory mem =
   Memory.create lim
 
 let create_global glob =
-  let {gtype = t; _} = glob.it in
+  let {gtype = GlobalType (t, _); _} = glob.it in
   ref (default_value t)
 
 let init_func c f =
@@ -369,15 +369,13 @@ let add_import (ext : extern) (imp : import) (inst : instance) : instance =
     );
     {inst with funcs = f :: inst.funcs}
   | ExternalTable tab, TableImport (TableType (lim, _)) ->
-    (* TODO: no checking of element type? *)
     check_limits (Table.limits tab) lim imp.it.ikind.at;
     {inst with tables = tab :: inst.tables}
   | ExternalMemory mem, MemoryImport (MemoryType lim) ->
     check_limits (Memory.limits mem) lim imp.it.ikind.at;
     {inst with memories = mem :: inst.memories}
-  | ExternalGlobal glob, GlobalImport _ ->
-    (* TODO: no checking of value type? *)
-    {inst with globals = ref glob :: inst.globals}
+  | ExternalGlobal v, GlobalImport (GlobalType _) ->
+    {inst with globals = ref v :: inst.globals}
   | _ ->
     Link.error imp.it.ikind.at "type mismatch"