remove tuples

wasm/emit_wat.ml

@@ -84,18 +84,22 @@ module Conv = struct
     let function_call_handling handler ~tail call : Expr.t =
       if tail then call
       else
-        let var = Local.fresh "call_result" in
+        let var1 = Local.fresh "call_result1" in
+        let var2 = Local.fresh "call_result2" in
+
         let body : Expr.t =
           If_then_else
-            { cond = Unop (Tuple_extract { arity = 2; field = 0 }, Var (V var))
+            { cond = Var (V var1)
             ; if_expr =
-                NR (raise handler (Unop (Tuple_extract { arity = 2; field = 1 }, Var (V var))))
-            ; else_expr = Unop (Tuple_extract { arity = 2; field = 1 }, Var (V var))
+                NR (raise handler (Var (V var2)))
+            ; else_expr = Var (V var2)
             }
         in
-        Let
-          { var
-          ; typ = Type.Tuple [ I32; ref_eq ]
+        Let2
+          { var1
+          ; var2
+          ; typ1 = I32
+          ; typ2 = ref_eq
           ; defining_expr = call
           ; body
           }
@@ -488,6 +492,7 @@ module Conv = struct
     match e with
     | Var _ | I32 _ | I64 _ | F64 _ | Global_get _ -> true
     | Unop (I31_new, e) -> expr_is_pure e
+    | Let2 { defining_expr; body; _ }
     | Let { defining_expr; body } ->
       expr_is_pure defining_expr && expr_is_pure body
     | _ -> false
@@ -2087,8 +2092,6 @@ module ToWasm = struct
       Cst.node name [ arg ]
     | Abs_float -> Cst.node "f64.abs" [ arg ]
     | Neg_float -> Cst.node "f64.neg" [ arg ]
-    | Tuple_extract { arity; field } ->
-        C.tuple_extract ~arity ~field arg
 
   let irelop_name nn (op : Expr.irelop) =
     match op with
@@ -2127,6 +2130,11 @@ module ToWasm = struct
     | Let { var; typ = _; defining_expr; body } ->
       C.local_set (Expr.Local.V var) (conv_expr_group defining_expr)
       :: conv_expr body
+    | Let2 { var1; typ1 = _; var2; typ2 = _; defining_expr; body } ->
+      C.local_set (Expr.Local.V var1)
+        (C.local_set (Expr.Local.V var2)
+            (conv_expr_group defining_expr))
+      :: conv_expr body
     | I32 i -> [ C.i32 i ]
     | I64 i -> [ C.i64 i ]
     | F64 f -> [ C.f64 f ]
@@ -2141,18 +2149,11 @@ module ToWasm = struct
     | Call_ref { typ; args; func; tail } ->
       let args = List.map conv_expr_group args @ [ conv_expr_group func ] in
       if tail then [ C.return_call_ref typ args ] else [ C.call_ref typ args ]
-    | Call { typ; args; func; tail } ->
+    | Call { typ = _; args; func; tail } ->
       let args = List.map conv_expr_group args in
       if tail then
-        (* This should be
-           {[ [ C.return_call func args ] ]}
-           But return call is not handled by the gc branch so we play a trick
-           with return_call_ref
-        *)
-        let _ = typ in
         (* TODO do something about C calls that does not return exceptions ? *)
         [ C.return_call func args ]
-        (* [ C.return_call_ref typ (args @ [ C.ref_func func ]) ] *)
       else [ C.call func args ]
     | Ref_cast { typ; r } -> [ C.ref_cast typ [ conv_expr_group r ] ]
     | Global_get g -> [ C.global_get g ]
@@ -2171,45 +2172,16 @@ module ToWasm = struct
           C.block cont result_types [ C.br fallthrough [ conv_expr_group body ] ]
         in
         let handler_expr = conv_expr handler in
-        (*
-        match mode with
-        | Reference ->
-          let handler =
-            List.map
-              (fun (var, _typ) ->
-                  match var with
-                  | Some var -> C.local_set' (Expr.Local.V var)
-                  | None -> C.drop' )
-              params
-            @ handler_expr
-          in
-          [ C.block fallthrough [ ref_eq ] (body :: handler) ]
-        | Binarien ->
-            *)
-        let set_locals =
-          match params with
-          | [] -> [ body ]
-          | [ (None, _typ) ] -> [ C.drop body ]
-          | [ (Some var, _typ) ] -> [ C.local_set (Expr.Local.V var) body ]
-          | _ ->
-            let arity = List.length params in
-            let local_tuple = Expr.Local.Block_result cont in
-            let _i, assigns =
-              List.fold_left
-                (fun (i, assigns) (var, _typ) ->
-                    match var with
-                    | Some var ->
-                      let project =
-                        C.tuple_extract ~arity ~field:i (C.local_get (Expr.Local.V local_tuple))
-                      in
-                      let expr = C.local_set (Expr.Local.V var) project in
-                      (i + 1, expr :: assigns)
-                    | None -> (i + 1, assigns) )
-                (0, []) params
-            in
-            [ C.local_set (Expr.Local.V local_tuple) body ] @ assigns
+        let handler =
+          List.map
+            (fun (var, _typ) ->
+                match var with
+                | Some var -> C.local_set' (Expr.Local.V var)
+                | None -> C.drop' )
+            (List.rev params)
+          @ handler_expr
         in
-        [ C.block fallthrough [ ref_eq ] (set_locals @ handler_expr) ]
+        [ C.block fallthrough [ ref_eq ] (body :: handler) ]
       end
     | Br_on_cast { value; typ; if_cast; if_else } ->
       [ C.drop (C.br_on_cast if_cast typ (conv_expr_group value)) ]
@@ -2349,7 +2321,6 @@ module ToWasm = struct
                     body
                 in
                 let _, typs = List.split body in
-                let exprs = [ C.tuple_make exprs ] in
                 (exprs, List.map C.result typs)
             end
           | No_value body -> (conv_no_value body, [])
@@ -2406,11 +2377,8 @@ let output_file ~output_prefix ~module_ =
         output_wat ppf module_;
         Format.fprintf ppf "@\n")
 
-let run ~output_prefix (flambda : Flambda.program) =
+let run (flambda : Flambda.program) =
   State.reset ();
-  let print_everything =
-    match Sys.getenv_opt "WASMPRINT" with None -> false | Some _ -> true
-  in
   let offsets = Wasm_closure_offsets.compute flambda in
   let top_env = Conv.{ offsets } in
   let m = Conv.conv_body top_env flambda.program_body [] in
@@ -2425,10 +2393,7 @@ let run ~output_prefix (flambda : Flambda.program) =
   in
   let functions = Conv.conv_functions ~top_env flambda in
   let m = closure_types @ m @ functions in
-  if print_everything then
-    Format.printf "WASM %s@.%a@." output_prefix Module.print m;
   let common = Conv.make_common () in
-  if print_everything then Format.printf "COMMON@.%a@." Module.print common;
   let wasm =
     Profile.record_call "ToWasm" (fun () -> ToWasm.conv_module (common @ m))
   in
@@ -2438,7 +2403,7 @@ let run ~output_prefix (flambda : Flambda.program) =
   Wat.{ module_ = wasm }
 
 let emit ~to_file ~output_prefix (flambda : Flambda.program) =
-  let r = run ~output_prefix flambda in
+  let r = run flambda in
   if to_file then
     Profile.record_call "output_wasm" (fun () ->
       output_file ~output_prefix ~module_:r.module_  );

wasm/link_wat.ml

@@ -29,13 +29,17 @@ let options =
   [ "--enable-multivalue"
   ; "--enable-gc"
   ; "--enable-reference-types"
-  ; "--enable-exception-handling"
   ; "--enable-tail-call"
-  ]
+  ] @ match Wstate.exception_repr with
+    | Native_exceptions -> [ "--enable-exception-handling" ]
+    | Multi_return ->  []
 
 let wasm_merge = "wasm-merge"
 
-let runtime = [ "exn_tag"; "runtime"; "imports" ]
+let runtime = [  "runtime"; "imports" ]
+  @ match Wstate.exception_repr with
+    | Native_exceptions -> [ "exn_tag" ]
+    | Multi_return ->  []
 
 let merge_files ~runtime_dir ~text files output =
   let text = if text then [ emit_text ] else [] in

wasm/runtime.wat

@@ -4,7 +4,8 @@
   (type $Array (sub (array (mut (ref eq)))))
   (type $FloatArray (sub (array (mut f64))))
   (type $Gen_block (sub (array (mut (ref eq)))))
-  (import "exn_tag" "exc" (tag $exc (param (ref eq))))
+  ;; TODO: re-enable exception
+  ;;(import "exn_tag" "exc" (tag $exc (param (ref eq))))
 
   ;; ==========
   ;; Exceptions
@@ -216,11 +217,15 @@
               (ref.cast (ref $String) (local.get $arr))
               (local.get $field))))
         (else
-          (throw $exc
+          unreachable
+          ;; TODO: re-enable exception
+          (;(throw $exc
             (array.new_fixed $Gen_block 3
               (ref.i31 (i32.const 0))
               (global.get $invalid_argument)
-              (global.get $index_out_of_bound_string)))))
+              (global.get $index_out_of_bound_string)))
+          ;)
+          ))
   )
 
   (func $string_eq (param $a (ref $String)) (param $b (ref $String)) (result i32)

wasm/test/bdd.ml

@@ -243,21 +243,16 @@ let test_hwb bdd vars =
   eval bdd vars = if !ntrue > 0 then vars.(!ntrue - 1) else false
 
 let main () =
-  let n = 22 in
+  let n = 25 in
   let ntests = 100 in
   let bdd = hwb n in
   let succeeded = ref true in
   for _ = 1 to ntests do
     succeeded := !succeeded && test_hwb bdd (random_vars n)
   done;
-  assert !succeeded
-
-(*
+  assert !succeeded;
   if !succeeded
   then print_string "OK\n"
-  else print_string "FAILED\n";
-Format.eprintf "%d@." !nodeC;
-  exit 0
-*)
+  else print_string "FAILED\n"
 
-let _ = main ()
+let () = main ()

wasm/test/boyer.ml

@@ -1206,7 +1206,6 @@ let _ =
     print_string "Proved!\n"
   else
     print_string "Cannot prove!\n";
-  exit 0
 *)
 
 (*********

wasm/test/boyer_no_exc.ml

@@ -1215,7 +1215,6 @@ let _ =
     print_string "Proved!\n"
   else
     print_string "Cannot prove!\n";
-  exit 0
 *)
 
 (*********

wasm/test/fannkuch2.ml

@@ -4,6 +4,8 @@
    contributed by Isaac Gouy, transliterated from Mike Pall's Lua program
 *)
 
+exception Done
+
 let fannkuch n =
   let p = Array.make n 0 in
   let q = Array.make n 0 in
@@ -36,19 +38,19 @@ let fannkuch n =
         let qq = q.(!q0) in
         q.(!q0) <- !q0;
         (if !q0 >= 3
-         then
-           let i = ref 1 in
-           let j = ref (!q0 - 1) in
-           while
-             let t = q.(!i) in
-             q.(!i) <- q.(!j);
-             q.(!j) <- t;
-             incr i;
-             decr j;
-             !i < !j
-           do
-             ()
-           done);
+          then
+            let i = ref 1 in
+            let j = ref (!q0 - 1) in
+            while
+              let t = q.(!i) in
+              q.(!i) <- q.(!j);
+              q.(!j) <- t;
+              incr i;
+              decr j;
+              !i < !j
+            do
+              ()
+            done);
         q0 := qq;
         incr flips
       done);
@@ -73,7 +75,7 @@ let fannkuch n =
           if i = n - 1
           then (
             if false then Format.eprintf "%d %d@." !sum !maxflips;
-            exit 0);
+            raise Done);
           s.(i) <- i;
           let t = p.(0) in
           for j = 0 to i do
@@ -86,8 +88,4 @@ let fannkuch n =
 
 let n = 10
 
-let pf = fannkuch n
-
-(*
-//print(pf[0] + "\n" + "Pfannkuchen(" + n + ") = " + pf[1]);
-*)
+let () = try fannkuch n with Done -> ()

wasm/test/fib.ml

@@ -3,14 +3,6 @@ let rec fib n =
   else fib (n - 1) + fib (n - 2)
 
 let () =
-  let n = 40 in
-  assert (fib n = 102334155)
-  (*
-  for i = 0 to 40 do
-    print_string "fib (";
-    print_int i;
-    print_string ") = ";
-    print_int (fib i);
-    print_string "\n"
-  done
-  *)
+  let n = 43 in
+  let res = fib n in
+  print_int res

wasm/test/kb.ml

@@ -584,5 +584,5 @@ let group_order = rpo group_precedence lex_ext
 let greater pair =
   match group_order pair with Greater -> true | _ -> false
 
-let _ =
-  for i = 1 to 20 do kb_complete greater [] geom_rules done
+let () =
+  for i = 1 to 55 do kb_complete greater [] geom_rules done