From 8585f7a332b548c229676b37658ed51a9d86f679 Mon Sep 17 00:00:00 2001
From: Andreas Rossberg <rossberg@chromium.org>
Date: Mon, 2 Nov 2015 10:49:59 +0100
Subject: [PATCH 1/3] Rename Ast to Kernel

---
 ml-proto/host/builtins.ml                |  2 +-
 ml-proto/host/builtins.mli               |  2 +-
 ml-proto/host/lexer.mll                  |  2 +-
 ml-proto/host/parser.mly                 | 26 ++++++++++++------------
 ml-proto/host/print.ml                   |  2 +-
 ml-proto/host/print.mli                  |  4 ++--
 ml-proto/host/script.ml                  | 12 +++++------
 ml-proto/host/script.mli                 | 12 +++++------
 ml-proto/spec/arithmetic.ml              |  8 ++++----
 ml-proto/spec/arithmetic.mli             |  8 ++++----
 ml-proto/spec/check.ml                   |  2 +-
 ml-proto/spec/check.mli                  |  2 +-
 ml-proto/spec/{sugar.ml => desugar.ml}   |  2 +-
 ml-proto/spec/{sugar.mli => desugar.mli} |  2 +-
 ml-proto/spec/eval.ml                    |  4 ++--
 ml-proto/spec/eval.mli                   |  2 +-
 ml-proto/spec/{ast.ml => kernel.ml}      |  2 +-
 17 files changed, 47 insertions(+), 47 deletions(-)
 rename ml-proto/spec/{sugar.ml => desugar.ml} (99%)
 rename ml-proto/spec/{sugar.mli => desugar.mli} (99%)
 rename ml-proto/spec/{ast.ml => kernel.ml} (98%)

diff --git a/ml-proto/host/builtins.ml b/ml-proto/host/builtins.ml
index 61619cbdb7..ae7528b0ea 100644
--- a/ml-proto/host/builtins.ml
+++ b/ml-proto/host/builtins.ml
@@ -1,6 +1,6 @@
 open Source
+open Kernel
 open Types
-open Ast
 
 module Unknown = Error.Make ()
 exception Unknown = Unknown.Error  (* indicates unknown import name *)
diff --git a/ml-proto/host/builtins.mli b/ml-proto/host/builtins.mli
index 36d8d9db71..87057790a9 100644
--- a/ml-proto/host/builtins.mli
+++ b/ml-proto/host/builtins.mli
@@ -1,3 +1,3 @@
 exception Unknown of Source.region * string
 
-val match_imports : Ast.module_ -> Eval.import list (* raises Unknown *)
+val match_imports : Kernel.module_ -> Eval.import list (* raises Unknown *)
diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll
index 1c141b63d0..fcd9f46454 100644
--- a/ml-proto/host/lexer.mll
+++ b/ml-proto/host/lexer.mll
@@ -4,7 +4,7 @@
 
 {
 open Parser
-open Ast
+open Kernel
 
 let convert_pos pos =
   { Source.file = pos.Lexing.pos_fname;
diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly
index 82e26307b8..eb8b7f0248 100644
--- a/ml-proto/host/parser.mly
+++ b/ml-proto/host/parser.mly
@@ -4,8 +4,8 @@
 
 %{
 open Source
-open Ast
-open Sugar
+open Kernel
+open Desugar
 open Types
 open Script
 
@@ -175,15 +175,15 @@ let implicit_decl c t at =
 %token<string> VAR
 %token<Types.value_type> VALUE_TYPE
 %token<Types.value_type> CONST
-%token<Ast.unop> UNARY
-%token<Ast.binop> BINARY
-%token<Ast.selop> SELECT
-%token<Ast.relop> COMPARE
-%token<Ast.cvt> CONVERT
-%token<Ast.memop> LOAD
-%token<Ast.memop> STORE
-%token<Ast.extop> LOAD_EXTEND
-%token<Ast.wrapop> STORE_WRAP
+%token<Kernel.unop> UNARY
+%token<Kernel.binop> BINARY
+%token<Kernel.selop> SELECT
+%token<Kernel.relop> COMPARE
+%token<Kernel.cvt> CONVERT
+%token<Kernel.memop> LOAD
+%token<Kernel.memop> STORE
+%token<Kernel.extop> LOAD_EXTEND
+%token<Kernel.wrapop> STORE_WRAP
 %token<Memory.offset> OFFSET
 %token<int> ALIGN
 
@@ -263,7 +263,7 @@ expr1 :
   | LABEL labeling expr
     { fun c -> let c', l = $2 c in
       let c'' = if l.it = Unlabelled then anon_label c' else c' in
-      Sugar.label ($3 c'') }
+      Desugar.label ($3 c'') }
   | BR var expr_opt { fun c -> br ($2 c label, $3 c) }
   | RETURN expr_opt
     { let at1 = ati 1 in
@@ -330,7 +330,7 @@ func_fields :
   | expr_list
     { let at = at () in
       empty_type,
-      fun c -> let body = Sugar.func_body ($1 c) @@ at in
+      fun c -> let body = func_body ($1 c) @@ at in
         {ftype = -1 @@ at; locals = []; body} }
   | LPAR PARAM value_type_list RPAR func_fields
     { {(fst $5) with ins = $3 @ (fst $5).ins},
diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml
index 7ba63b784e..3fe52984b0 100644
--- a/ml-proto/host/print.ml
+++ b/ml-proto/host/print.ml
@@ -2,7 +2,7 @@
  * (c) 2015 Andreas Rossberg
  *)
 
-open Ast
+open Kernel
 open Source
 open Printf
 
diff --git a/ml-proto/host/print.mli b/ml-proto/host/print.mli
index df70541ee0..966a5b9f6a 100644
--- a/ml-proto/host/print.mli
+++ b/ml-proto/host/print.mli
@@ -2,7 +2,7 @@
  * (c) 2015 Andreas Rossberg
  *)
 
-val print_module : Ast.module_ -> unit
-val print_module_sig : Ast.module_ -> unit
+val print_module : Kernel.module_ -> unit
+val print_module_sig : Kernel.module_ -> unit
 val print_value : Values.value option -> unit
 
diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml
index cc71f2830a..6621667984 100644
--- a/ml-proto/host/script.ml
+++ b/ml-proto/host/script.ml
@@ -9,12 +9,12 @@ open Source
 
 type command = command' phrase
 and command' =
-  | Define of Ast.module_
-  | Invoke of string * Ast.literal list
-  | AssertInvalid of Ast.module_ * string
-  | AssertReturn of string * Ast.literal list * Ast.literal option
-  | AssertReturnNaN of string * Ast.literal list
-  | AssertTrap of string * Ast.literal list * string
+  | Define of Kernel.module_
+  | Invoke of string * Kernel.literal list
+  | AssertInvalid of Kernel.module_ * string
+  | AssertReturn of string * Kernel.literal list * Kernel.literal option
+  | AssertReturnNaN of string * Kernel.literal list
+  | AssertTrap of string * Kernel.literal list * string
 
 type script = command list
 
diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli
index 4214ae2eb1..f89472efa0 100644
--- a/ml-proto/host/script.mli
+++ b/ml-proto/host/script.mli
@@ -4,12 +4,12 @@
 
 type command = command' Source.phrase
 and command' =
-  | Define of Ast.module_
-  | Invoke of string * Ast.literal list
-  | AssertInvalid of Ast.module_ * string
-  | AssertReturn of string * Ast.literal list * Ast.literal option
-  | AssertReturnNaN of string * Ast.literal list
-  | AssertTrap of string * Ast.literal list * string
+  | Define of Kernel.module_
+  | Invoke of string * Kernel.literal list
+  | AssertInvalid of Kernel.module_ * string
+  | AssertReturn of string * Kernel.literal list * Kernel.literal option
+  | AssertReturnNaN of string * Kernel.literal list
+  | AssertTrap of string * Kernel.literal list * string
 
 type script = command list
 
diff --git a/ml-proto/spec/arithmetic.ml b/ml-proto/spec/arithmetic.ml
index 97f35228a5..302d5a8588 100644
--- a/ml-proto/spec/arithmetic.ml
+++ b/ml-proto/spec/arithmetic.ml
@@ -30,7 +30,7 @@ let f64_of_value n =
 
 module Int32Op =
 struct
-  open Ast.Int32Op
+  open Kernel.Int32Op
 
   let unop op =
     let f = match op with
@@ -92,7 +92,7 @@ end
 
 module Int64Op =
 struct
-  open Ast.Int64Op
+  open Kernel.Int64Op
 
   let unop op =
     let f = match op with
@@ -157,7 +157,7 @@ end
 
 module Float32Op =
 struct
-  open Ast.Float32Op
+  open Kernel.Float32Op
 
   let unop op =
     let f = match op with
@@ -211,7 +211,7 @@ end
 
 module Float64Op =
 struct
-  open Ast.Float64Op
+  open Kernel.Float64Op
 
   let unop op =
     let f = match op with
diff --git a/ml-proto/spec/arithmetic.mli b/ml-proto/spec/arithmetic.mli
index eefd5d822e..5b1bb2c82e 100644
--- a/ml-proto/spec/arithmetic.mli
+++ b/ml-proto/spec/arithmetic.mli
@@ -6,7 +6,7 @@ open Values
 
 exception TypeError of int * value * Types.value_type
 
-val eval_unop : Ast.unop -> value -> value
-val eval_binop : Ast.binop -> value -> value -> value
-val eval_relop : Ast.relop -> value -> value -> bool
-val eval_cvt : Ast.cvt -> value -> value
+val eval_unop : Kernel.unop -> value -> value
+val eval_binop : Kernel.binop -> value -> value -> value
+val eval_relop : Kernel.relop -> value -> value -> bool
+val eval_cvt : Kernel.cvt -> value -> value
diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml
index 0f9a6cc31e..ef53c4f8d2 100644
--- a/ml-proto/spec/check.ml
+++ b/ml-proto/spec/check.ml
@@ -2,7 +2,7 @@
  * (c) 2015 Andreas Rossberg
  *)
 
-open Ast
+open Kernel
 open Source
 open Types
 
diff --git a/ml-proto/spec/check.mli b/ml-proto/spec/check.mli
index fc780d6b8d..07b61caf48 100644
--- a/ml-proto/spec/check.mli
+++ b/ml-proto/spec/check.mli
@@ -4,4 +4,4 @@
 
 exception Invalid of Source.region * string
 
-val check_module : Ast.module_ -> unit (* raise Invalid *)
+val check_module : Kernel.module_ -> unit (* raise Invalid *)
diff --git a/ml-proto/spec/sugar.ml b/ml-proto/spec/desugar.ml
similarity index 99%
rename from ml-proto/spec/sugar.ml
rename to ml-proto/spec/desugar.ml
index 2e65b8831a..c959ba50f0 100644
--- a/ml-proto/spec/sugar.ml
+++ b/ml-proto/spec/desugar.ml
@@ -1,5 +1,5 @@
 open Source
-open Ast
+open Kernel
 
 
 type labeling = labeling' phrase
diff --git a/ml-proto/spec/sugar.mli b/ml-proto/spec/desugar.mli
similarity index 99%
rename from ml-proto/spec/sugar.mli
rename to ml-proto/spec/desugar.mli
index 4666e831b3..348bb92c3e 100644
--- a/ml-proto/spec/sugar.mli
+++ b/ml-proto/spec/desugar.mli
@@ -1,4 +1,4 @@
-open Ast
+open Kernel
 
 type labeling = labeling' Source.phrase
 and labeling' = Unlabelled | Labelled
diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml
index 3d8a3dd839..8ac54333bd 100644
--- a/ml-proto/spec/eval.ml
+++ b/ml-proto/spec/eval.ml
@@ -4,7 +4,7 @@
 
 open Values
 open Types
-open Ast
+open Kernel
 open Source
 
 
@@ -317,7 +317,7 @@ let add_export funcs ex =
   ExportMap.add ex.it.name (List.nth funcs ex.it.func.it)
 
 let init m imports host =
-  assert (List.length imports = List.length m.it.Ast.imports);
+  assert (List.length imports = List.length m.it.Kernel.imports);
   let {memory; funcs; exports; _} = m.it in
   {module_ = m;
    imports;
diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli
index 71c4905757..236ecb9842 100644
--- a/ml-proto/spec/eval.mli
+++ b/ml-proto/spec/eval.mli
@@ -12,7 +12,7 @@ type host_params = {
 exception Trap of Source.region * string
 exception Crash of Source.region * string
 
-val init : Ast.module_ -> import list -> host_params -> instance
+val init : Kernel.module_ -> import list -> host_params -> instance
 val invoke : instance -> string -> value list -> value option
   (* raises Trap, Crash *)
 
diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/kernel.ml
similarity index 98%
rename from ml-proto/spec/ast.ml
rename to ml-proto/spec/kernel.ml
index 61d79ebe39..6627e50e38 100644
--- a/ml-proto/spec/ast.ml
+++ b/ml-proto/spec/kernel.ml
@@ -103,7 +103,7 @@ and expr' =
   | Select of selop * expr * expr * expr    (* branchless conditional *)
   | Compare of relop * expr * expr          (* arithmetic comparison *)
   | Convert of cvt * expr                   (* conversion *)
-  | Unreachable                                    (* trap *)
+  | Unreachable                             (* trap *)
   | Host of hostop * expr list              (* host interaction *)
 
 

From 77334be1da074b86e793a07a9ba2075174cc25fb Mon Sep 17 00:00:00 2001
From: Andreas Rossberg <rossberg@chromium.org>
Date: Mon, 2 Nov 2015 11:04:09 +0100
Subject: [PATCH 2/3] Introduce full Ast

---
 ml-proto/host/main.ml     |   4 +-
 ml-proto/host/parser.mly  |  68 +++++++-------
 ml-proto/host/script.ml   |  31 +++++--
 ml-proto/host/script.mli  |  15 ++--
 ml-proto/spec/ast.ml      |  68 ++++++++++++++
 ml-proto/spec/check.ml    |   5 +-
 ml-proto/spec/desugar.ml  | 184 +++++++++++++++-----------------------
 ml-proto/spec/desugar.mli |  38 +-------
 ml-proto/spec/kernel.ml   |   2 +-
 9 files changed, 212 insertions(+), 203 deletions(-)
 create mode 100644 ml-proto/spec/ast.ml

diff --git a/ml-proto/host/main.ml b/ml-proto/host/main.ml
index a126d76dbe..989579ddfd 100644
--- a/ml-proto/host/main.ml
+++ b/ml-proto/host/main.ml
@@ -37,8 +37,10 @@ let process file source =
   try
     Script.trace "Parsing...";
     let script = parse file source in
+    Script.trace "Desugaring...";
+    let script' = Script.desugar script in
     Script.trace "Running...";
-    Script.run script;
+    Script.run script';
     true
   with
   | Script.Syntax (at, msg) -> error at "syntax error" msg
diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly
index eb8b7f0248..bc0cacb131 100644
--- a/ml-proto/host/parser.mly
+++ b/ml-proto/host/parser.mly
@@ -4,9 +4,9 @@
 
 %{
 open Source
-open Kernel
-open Desugar
 open Types
+open Kernel
+open Ast
 open Script
 
 
@@ -250,52 +250,52 @@ expr :
   | LPAR expr1 RPAR { let at = at () in fun c -> $2 c @@ at }
 ;
 expr1 :
-  | NOP { fun c -> nop }
+  | NOP { fun c -> Nop }
   | BLOCK labeling expr expr_list
-    { fun c -> let c', l = $2 c in block (l, $3 c' :: $4 c') }
-  | IF_ELSE expr expr expr { fun c -> if_else ($2 c, $3 c, $4 c) }
-  | IF expr expr { fun c -> if_ ($2 c, $3 c) }
-  | BR_IF expr var { fun c -> br_if ($2 c, $3 c label) }
+    { fun c -> let c', l = $2 c in Block (l, $3 c' :: $4 c') }
+  | IF_ELSE expr expr expr { fun c -> If_else ($2 c, $3 c, $4 c) }
+  | IF expr expr { fun c -> If ($2 c, $3 c) }
+  | BR_IF expr var { fun c -> Br_if ($2 c, $3 c label) }
   | LOOP labeling labeling expr_list
     { fun c -> let c', l1 = $2 c in let c'', l2 = $3 c' in
       let c''' = if l1.it = Unlabelled then anon_label c'' else c'' in
-      loop (l1, l2, $4 c''') }
+      Loop (l1, l2, $4 c''') }
   | LABEL labeling expr
     { fun c -> let c', l = $2 c in
       let c'' = if l.it = Unlabelled then anon_label c' else c' in
-      Desugar.label ($3 c'') }
-  | BR var expr_opt { fun c -> br ($2 c label, $3 c) }
+      Label ($3 c'') }
+  | BR var expr_opt { fun c -> Br ($2 c label, $3 c) }
   | RETURN expr_opt
     { let at1 = ati 1 in
-      fun c -> return (label c ("return" @@ at1) @@ at1, $2 c) }
+      fun c -> Return (label c ("return" @@ at1) @@ at1, $2 c) }
   | TABLESWITCH labeling expr LPAR TABLE target_list RPAR target case_list
     { fun c -> let c', l = $2 c in let e = $3 c' in
       let c'' = enter_switch c' in let es = $9 c'' in
-      tableswitch (l, e, $6 c'', $8 c'', es) }
-  | CALL var expr_list { fun c -> call ($2 c func, $3 c) }
-  | CALL_IMPORT var expr_list { fun c -> call_import ($2 c import, $3 c) }
+      Tableswitch (l, e, $6 c'', $8 c'', es) }
+  | CALL var expr_list { fun c -> Call ($2 c func, $3 c) }
+  | CALL_IMPORT var expr_list { fun c -> Call_import ($2 c import, $3 c) }
   | CALL_INDIRECT var expr expr_list
-    { fun c -> call_indirect ($2 c type_, $3 c, $4 c) }
-  | GET_LOCAL var { fun c -> get_local ($2 c local) }
-  | SET_LOCAL var expr { fun c -> set_local ($2 c local, $3 c) }
+    { fun c -> Call_indirect ($2 c type_, $3 c, $4 c) }
+  | GET_LOCAL var { fun c -> Get_local ($2 c local) }
+  | SET_LOCAL var expr { fun c -> Set_local ($2 c local, $3 c) }
   | LOAD offset align expr
-    { fun c -> load (memop $1 $2 $3, $4 c) }
+    { fun c -> Load (memop $1 $2 $3, $4 c) }
   | STORE offset align expr expr
-    { fun c -> store (memop $1 $2 $3, $4 c, $5 c) }
+    { fun c -> Store (memop $1 $2 $3, $4 c, $5 c) }
   | LOAD_EXTEND offset align expr
-    { fun c -> load_extend (extop $1 $2 $3, $4 c) }
+    { fun c -> Load_extend (extop $1 $2 $3, $4 c) }
   | STORE_WRAP offset align expr expr
-    { fun c -> store_wrap (wrapop $1 $2 $3, $4 c, $5 c) }
-  | CONST literal { fun c -> const (literal $2 $1) }
-  | UNARY expr { fun c -> unary ($1, $2 c) }
-  | BINARY expr expr { fun c -> binary ($1, $2 c, $3 c) }
-  | SELECT expr expr expr { fun c -> select ($1, $2 c, $3 c, $4 c) }
-  | COMPARE expr expr { fun c -> compare ($1, $2 c, $3 c) }
-  | CONVERT expr { fun c -> convert ($1, $2 c) }
-  | UNREACHABLE { fun c -> unreachable }
-  | MEMORY_SIZE { fun c -> host (MemorySize, []) }
-  | GROW_MEMORY expr { fun c -> host (GrowMemory, [$2 c]) }
-  | HAS_FEATURE TEXT { fun c -> host (HasFeature $2, []) }
+    { fun c -> Store_wrap (wrapop $1 $2 $3, $4 c, $5 c) }
+  | CONST literal { fun c -> Const (literal $2 $1) }
+  | UNARY expr { fun c -> Unary ($1, $2 c) }
+  | BINARY expr expr { fun c -> Binary ($1, $2 c, $3 c) }
+  | SELECT expr expr expr { fun c -> Select ($1, $2 c, $3 c, $4 c) }
+  | COMPARE expr expr { fun c -> Compare ($1, $2 c, $3 c) }
+  | CONVERT expr { fun c -> Convert ($1, $2 c) }
+  | UNREACHABLE { fun c -> Unreachable }
+  | MEMORY_SIZE { fun c -> Host (MemorySize, []) }
+  | GROW_MEMORY expr { fun c -> Host (GrowMemory, [$2 c]) }
+  | HAS_FEATURE TEXT { fun c -> Host (HasFeature $2, []) }
 ;
 expr_opt :
   | /* empty */ { fun c -> None }
@@ -328,10 +328,8 @@ case_list :
 
 func_fields :
   | expr_list
-    { let at = at () in
-      empty_type,
-      fun c -> let body = func_body ($1 c) @@ at in
-        {ftype = -1 @@ at; locals = []; body} }
+    { empty_type,
+      fun c -> {ftype = -1 @@ at(); locals = []; body = $1 c} }
   | LPAR PARAM value_type_list RPAR func_fields
     { {(fst $5) with ins = $3 @ (fst $5).ins},
       fun c -> anon_locals c $3; (snd $5) c }
diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml
index 6621667984..3f23566dbf 100644
--- a/ml-proto/host/script.ml
+++ b/ml-proto/host/script.ml
@@ -7,16 +7,31 @@ open Source
 
 (* Script representation *)
 
-type command = command' phrase
-and command' =
-  | Define of Kernel.module_
+type 'm command = 'm command' Source.phrase
+and 'm command' =
+  | Define of 'm
   | Invoke of string * Kernel.literal list
-  | AssertInvalid of Kernel.module_ * string
+  | AssertInvalid of 'm * string
   | AssertReturn of string * Kernel.literal list * Kernel.literal option
   | AssertReturnNaN of string * Kernel.literal list
   | AssertTrap of string * Kernel.literal list * string
 
-type script = command list
+type script = Ast.module_ command list
+type script' = Kernel.module_ command list
+
+
+(* Desugaring *)
+
+let rec desugar_cmd c = desugar_cmd' c.it @@ c.at
+and desugar_cmd' = function
+  | Define m -> Define (Desugar.desugar m)
+  | Invoke (s, ls) -> Invoke (s, ls)
+  | AssertInvalid (m, r) -> AssertInvalid (Desugar.desugar m, r)
+  | AssertReturn (s, ls, lo) -> AssertReturn (s, ls, lo)
+  | AssertReturnNaN (s, ls) -> AssertReturnNaN (s, ls)
+  | AssertTrap (s, ls, r) -> AssertTrap (s, ls, r)
+
+let desugar = List.map desugar_cmd
 
 
 (* Execution *)
@@ -36,7 +51,7 @@ let get_module at = match !current_module with
   | None -> raise (Eval.Crash (at, "no module defined to invoke"))
 
 
-let run_command cmd =
+let run_cmd cmd =
   match cmd.it with
   | Define m ->
     trace "Checking...";
@@ -111,7 +126,7 @@ let run_command cmd =
       AssertFailure.error cmd.at "expected runtime trap"
     )
 
-let dry_command cmd =
+let dry_cmd cmd =
   match cmd.it with
   | Define m ->
     Check.check_module m;
@@ -123,4 +138,4 @@ let dry_command cmd =
   | AssertTrap _ -> ()
 
 let run script =
-  List.iter (if !Flags.dry then dry_command else run_command) script
+  List.iter (if !Flags.dry then dry_cmd else run_cmd) script
diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli
index f89472efa0..ca49af20a4 100644
--- a/ml-proto/host/script.mli
+++ b/ml-proto/host/script.mli
@@ -2,21 +2,24 @@
  * (c) 2015 Andreas Rossberg
  *)
 
-type command = command' Source.phrase
-and command' =
-  | Define of Kernel.module_
+type 'm command = 'm command' Source.phrase
+and 'm command' =
+  | Define of 'm
   | Invoke of string * Kernel.literal list
-  | AssertInvalid of Kernel.module_ * string
+  | AssertInvalid of 'm * string
   | AssertReturn of string * Kernel.literal list * Kernel.literal option
   | AssertReturnNaN of string * Kernel.literal list
   | AssertTrap of string * Kernel.literal list * string
 
-type script = command list
+type script = Ast.module_ command list
+type script' = Kernel.module_ command list
+
+val desugar : script -> script'
 
 exception Syntax of Source.region * string
 exception AssertFailure of Source.region * string
 
-val run : script -> unit
+val run : script' -> unit
   (* raises Check.Invalid, Eval.Trap, Eval.Crash, Failure *)
 
 val trace : string -> unit
diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml
new file mode 100644
index 0000000000..cb7c8a2c78
--- /dev/null
+++ b/ml-proto/spec/ast.ml
@@ -0,0 +1,68 @@
+(*
+ * (c) 2015 Andreas Rossberg
+ *)
+
+(* Expressions *)
+
+type var = Kernel.var
+
+type labeling = labeling' Source.phrase
+and labeling' = Unlabelled | Labelled
+
+type target = target' Source.phrase
+and target' = Case of var | Case_br of var
+
+type expr = expr' Source.phrase
+and expr' =
+  | Nop
+  | Block of labeling * expr list
+  | If of expr * expr
+  | If_else of expr * expr * expr
+  | Br_if of expr * var
+  | Loop of labeling * labeling * expr list
+  | Label of expr
+  | Br of var * expr option
+  | Return of var * expr option
+  | Tableswitch of labeling * expr * target list * target * expr list list
+  | Call of var * expr list
+  | Call_import of var * expr list
+  | Call_indirect of var * expr * expr list
+  | Get_local of var
+  | Set_local of var * expr
+  | Load of Kernel.memop * expr
+  | Store of Kernel.memop * expr * expr
+  | Load_extend of Kernel.extop * expr
+  | Store_wrap of Kernel.wrapop * expr * expr
+  | Const of Kernel.literal
+  | Unary of Kernel.unop * expr
+  | Binary of Kernel.binop * expr * expr
+  | Select of Kernel.selop * expr * expr * expr
+  | Compare of Kernel.relop * expr * expr
+  | Convert of Kernel.cvt * expr
+  | Unreachable
+  | Host of Kernel.hostop * expr list
+
+
+(* Functions *)
+
+type func = func' Source.phrase
+and func' =
+{
+  ftype : var;
+  locals :Types.value_type list;
+  body : expr list;
+}
+
+
+(* Modules *)
+
+type module_ = module' Source.phrase
+and module' =
+{
+  memory : Kernel.memory option;
+  types : Types.func_type list;
+  funcs : func list;
+  imports : Kernel.import list;
+  exports : Kernel.export list;
+  table : var list;
+}
diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml
index ef53c4f8d2..7cec6b3712 100644
--- a/ml-proto/spec/check.ml
+++ b/ml-proto/spec/check.ml
@@ -221,9 +221,8 @@ let rec check_expr c et e =
     ()
 
   | Host (hostop, es) ->
-    let ({ins; out}, hasmem) = type_hostop hostop in
-    if hasmem then
-      check_has_memory c e.at;
+    let {ins; out}, has_mem = type_hostop hostop in
+    if has_mem then check_has_memory c e.at;
     check_exprs c ins es;
     check_type out et e.at
 
diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml
index c959ba50f0..35789d4803 100644
--- a/ml-proto/spec/desugar.ml
+++ b/ml-proto/spec/desugar.ml
@@ -1,118 +1,78 @@
 open Source
-open Kernel
 
+module A = Ast
+module K = Kernel
 
-type labeling = labeling' phrase
-and labeling' = Unlabelled | Labelled
 
-type case = case' phrase
-and case' = Case of var | Case_br of var
+(* Expressions *)
 
-
-let labeling l e =
+let labeling l e' =
   match l.it with
-  | Unlabelled -> e
-  | Labelled -> Label (e @@ l.at)
-
-let expr_seq es =
-  match es with
-  | [] -> Nop @@ Source.no_region
-  | [e] -> e
-  | es -> Block es @@@ List.map Source.at es
-
-
-let nop =
-  Nop
-
-let block (l, es) =
- labeling l (Block es)
-
-let if_else (e1, e2, e3) =
-  If (e1, e2, e3)
-
-let if_ (e1, e2) =
-  If (e1, e2, Nop @@ Source.after e2.at)
-
-let br_if (e, x) =
-  if_ (e, Break (x, None) @@ x.at)
-
-let loop (l1, l2, es) =
-  let e = expr_seq es in
-  if l2.it = Unlabelled then Loop e else labeling l1 (Loop e)
-
-let label e =
-  Label e
-
-let br (x, e) =
-  Break (x, e)
-
-let return (x, eo) =
-  Break (x, eo)
-
-let tableswitch (l, e, ts, t, es) =
-  let translate_target t (xs, es') =
-    match t.it with
-    | Case x -> x :: xs, es'
-    | Case_br x ->
-      (List.length es' @@ t.at) :: xs, (Break (x, None) @@ t.at) :: es'
-  in
-  let xs, es' = List.fold_right translate_target (t :: ts) ([], []) in
-  let es'' = List.map expr_seq es in
-  let n = List.length es' in
-  let sh x = (if x.it >= n then x.it + n else x.it) @@ x.at in
-  labeling l (Switch (e, List.map sh (List.tl xs), sh (List.hd xs), es' @ es''))
-
-let call (x, es) =
-  Call (x, es)
-
-let call_import (x, es) =
-  CallImport (x, es)
-
-let call_indirect (x, e, es) =
-  CallIndirect (x, e, es)
-
-let get_local x =
-  GetLocal x
-
-let set_local (x, e) =
-  SetLocal (x, e)
-
-let load (memop, e) =
-  Load (memop, e)
-
-let store (memop, e1, e2) =
-  Store (memop, e1, e2)
-
-let load_extend (extop, e) =
-  LoadExtend (extop, e)
-
-let store_wrap (wrapop, e1, e2) =
-  StoreWrap (wrapop, e1, e2)
-
-let const c =
-  Const c
-
-let unary (unop, e) =
-  Unary (unop, e)
-
-let binary (binop, e1, e2) =
-  Binary (binop, e1, e2)
-
-let select (selop, cond, e1, e2) =
-  Select (selop, cond, e1, e2)
-
-let compare (relop, e1, e2) =
-  Compare (relop, e1, e2)
-
-let convert (cvt, e) =
-  Convert (cvt, e)
-
-let unreachable =
-  Unreachable
-
-let host (hostop, es) =
-  Host (hostop, es)
-
-
-let func_body es =
-  Label (expr_seq es)
+  | A.Unlabelled -> e'
+  | A.Labelled -> K.Label (e' @@ l.at)
+
+
+let rec expr e = expr' e.it @@ e.at
+and expr' = function
+  | A.Nop -> K.Nop
+  | A.Block (l, es) -> labeling l (K.Block (List.map expr es))
+  | A.If (e1, e2) -> K.If (expr e1, expr e2, K.Nop @@ Source.after e2.at)
+  | A.If_else (e1, e2, e3) -> K.If (expr e1, expr e2, expr e3)
+  | A.Br_if (e, x) -> expr' (A.If (e, A.Br (x, None) @@ x.at))
+  | A.Loop (l1, l2, es) when l2.it = A.Unlabelled -> K.Loop (seq es)
+  | A.Loop (l1, l2, es) -> labeling l1 (K.Loop (seq es))
+  | A.Label e -> K.Label (expr e)
+  | A.Br (x, eo) -> K.Break (x, Lib.Option.map expr eo)
+  | A.Return (x, eo) -> K.Break (x, Lib.Option.map expr eo)
+  | A.Tableswitch (l, e, ts, t, es) ->
+    let target t (xs, es') =
+      match t.it with
+      | A.Case x -> x :: xs, es'
+      | A.Case_br x ->
+        (List.length es' @@ t.at) :: xs, (K.Break (x, None) @@ t.at) :: es'
+    in
+    let xs, es' = List.fold_right target (t :: ts) ([], []) in
+    let es'' = List.map seq es in
+    let n = List.length es' in
+    let sh x = (if x.it >= n then x.it + n else x.it) @@ x.at in
+    labeling l
+      (K.Switch (expr e, List.map sh (List.tl xs), sh (List.hd xs), es' @ es''))
+  | A.Call (x, es) -> K.Call (x, List.map expr es)
+  | A.Call_import (x, es) -> K.CallImport (x, List.map expr es)
+  | A.Call_indirect (x, e, es) -> K.CallIndirect (x, expr e, List.map expr es)
+  | A.Get_local x -> K.GetLocal x
+  | A.Set_local (x, e) -> K.SetLocal (x, expr e)
+  | A.Load (memop, e) -> K.Load (memop, expr e)
+  | A.Store (memop, e1, e2) -> K.Store (memop, expr e1, expr e2)
+  | A.Load_extend (extop, e) -> K.LoadExtend (extop, expr e)
+  | A.Store_wrap (wrapop, e1, e2) -> K.StoreWrap (wrapop, expr e1, expr e2)
+  | A.Const c -> K.Const c
+  | A.Unary (unop, e) -> K.Unary (unop, expr e)
+  | A.Binary (binop, e1, e2) -> K.Binary (binop, expr e1, expr e2)
+  | A.Select (selop, e1, e2, e3) -> K.Select (selop, expr e1, expr e2, expr e3)
+  | A.Compare (relop, e1, e2) -> K.Compare (relop, expr e1, expr e2)
+  | A.Convert (cvt, e) -> K.Convert (cvt, expr e)
+  | A.Unreachable -> K.Unreachable
+  | A.Host (hostop, es) -> K.Host (hostop, List.map expr es)
+
+and seq = function
+  | [] -> K.Nop @@ Source.no_region
+  | [e] -> expr e
+  | es -> K.Block (List.map expr es) @@@ List.map Source.at es
+
+
+(* Functions and Modules *)
+
+let rec func f = func' f.it @@ f.at
+and func' = function
+  | {A.body = []; ftype; locals} ->
+    {K.body = K.Nop @@ no_region; ftype; locals}
+  | {A.body = es; ftype; locals} ->
+    {K.body = K.Label (seq es) @@@ List.map at es; ftype; locals}
+
+let rec module_ m = module' m.it @@ m.at
+and module' = function
+  | {A.funcs = fs; memory; types; imports; exports; table} ->
+    {K.funcs = List.map func fs; memory; types; imports; exports; table}
+
+let desugar = module_
diff --git a/ml-proto/spec/desugar.mli b/ml-proto/spec/desugar.mli
index 348bb92c3e..b3abdf41e9 100644
--- a/ml-proto/spec/desugar.mli
+++ b/ml-proto/spec/desugar.mli
@@ -1,37 +1 @@
-open Kernel
-
-type labeling = labeling' Source.phrase
-and labeling' = Unlabelled | Labelled
-
-type case = case' Source.phrase
-and case' = Case of var | Case_br of var
-
-val nop : expr'
-val block : labeling * expr list -> expr'
-val if_else : expr * expr * expr -> expr'
-val if_ : expr * expr -> expr'
-val br_if : expr * var -> expr'
-val loop : labeling * labeling * expr list -> expr'
-val label : expr -> expr'
-val br : var * expr option -> expr'
-val return : var * expr option -> expr'
-val tableswitch : labeling * expr * case list * case * expr list list -> expr'
-val call : var * expr list -> expr'
-val call_import : var * expr list -> expr'
-val call_indirect : var * expr * expr list -> expr'
-val get_local : var -> expr'
-val set_local : var * expr -> expr'
-val load : memop * expr -> expr'
-val store : memop * expr * expr -> expr'
-val load_extend : extop * expr -> expr'
-val store_wrap : wrapop * expr * expr -> expr'
-val const : literal -> expr'
-val unary : unop * expr -> expr'
-val binary : binop * expr * expr -> expr'
-val select : selop * expr * expr * expr -> expr'
-val compare : relop * expr * expr -> expr'
-val convert : cvt * expr -> expr'
-val unreachable : expr'
-val host : hostop * expr list -> expr'
-
-val func_body : expr list -> expr'
+val desugar : Ast.module_ -> Kernel.module_
diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml
index 6627e50e38..58005eb2b7 100644
--- a/ml-proto/spec/kernel.ml
+++ b/ml-proto/spec/kernel.ml
@@ -61,9 +61,9 @@ module Float64Op = FloatOp ()
 
 type unop = (Int32Op.unop, Int64Op.unop, Float32Op.unop, Float64Op.unop) op
 type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op
+type selop = (Int32Op.selop, Int64Op.selop, Float32Op.selop, Float64Op.selop) op
 type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op
 type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op
-type selop = (Int32Op.selop, Int64Op.selop, Float32Op.selop, Float64Op.selop) op
 
 type memop = {ty : value_type; offset : Memory.offset; align : int option}
 type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension}

From 8c45afac27e5ae83d10e2fb41ca9eae3d2d5de43 Mon Sep 17 00:00:00 2001
From: Andreas Rossberg <rossberg@chromium.org>
Date: Mon, 16 Nov 2015 14:06:39 +0100
Subject: [PATCH 3/3] Copyright leftover

---
 ml-proto/spec/kernel.ml | 4 ----
 1 file changed, 4 deletions(-)

diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml
index 58005eb2b7..bcc7bbffe7 100644
--- a/ml-proto/spec/kernel.ml
+++ b/ml-proto/spec/kernel.ml
@@ -1,7 +1,3 @@
-(*
- * (c) 2015 Andreas Rossberg
- *)
-
 (*
  * Throughout the implementation we use consistent naming conventions for
  * syntactic elements, associated with the types defined here and in a few