Introduce explicit type for full AST

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 *)

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 *)

ml-proto/host/lexer.mll

@@ -1,6 +1,6 @@
 {
 open Parser
-open Ast
+open Kernel
 
 let convert_pos pos =
   { Source.file = pos.Lexing.pos_fname;

ml-proto/host/main.ml

@@ -33,8 +33,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

ml-proto/host/parser.mly

@@ -1,8 +1,8 @@
 %{
 open Source
-open Ast
-open Sugar
 open Types
+open Kernel
+open Ast
 open Script
 
 
@@ -171,15 +171,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
 
@@ -246,52 +246,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
-      Sugar.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 }
@@ -324,10 +324,8 @@ case_list :
 
 func_fields :
   | expr_list
-    { let at = at () in
-      empty_type,
-      fun c -> let body = Sugar.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 }

ml-proto/host/print.ml

@@ -1,4 +1,4 @@
-open Ast
+open Kernel
 open Source
 open Printf
 

ml-proto/host/print.mli

@@ -1,4 +1,4 @@
-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
 

ml-proto/host/script.ml

@@ -3,16 +3,31 @@ open Source
 
 (* Script representation *)
 
-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
+type 'm command = 'm command' Source.phrase
+and 'm command' =
+  | Define of 'm
+  | Invoke of string * Kernel.literal list
+  | 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 *)
@@ -32,7 +47,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...";
@@ -107,7 +122,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;
@@ -119,4 +134,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

ml-proto/host/script.mli

@@ -1,18 +1,21 @@
-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
+type 'm command = 'm command' Source.phrase
+and 'm command' =
+  | Define of 'm
+  | Invoke of string * Kernel.literal list
+  | 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

ml-proto/spec/arithmetic.ml

@@ -26,7 +26,7 @@ let f64_of_value n =
 
 module Int32Op =
 struct
-  open Ast.Int32Op
+  open Kernel.Int32Op
 
   let unop op =
     let f = match op with
@@ -88,7 +88,7 @@ end
 
 module Int64Op =
 struct
-  open Ast.Int64Op
+  open Kernel.Int64Op
 
   let unop op =
     let f = match op with
@@ -153,7 +153,7 @@ end
 
 module Float32Op =
 struct
-  open Ast.Float32Op
+  open Kernel.Float32Op
 
   let unop op =
     let f = match op with
@@ -207,7 +207,7 @@ end
 
 module Float64Op =
 struct
-  open Ast.Float64Op
+  open Kernel.Float64Op
 
   let unop op =
     let f = match op with

ml-proto/spec/arithmetic.mli

@@ -2,7 +2,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