Implement exceptions by returning null

Author: vouillon

compiler/lib-wasm/curry.ml

@@ -256,20 +256,25 @@ module Make (Target : Target_sig.S) = struct
            match l with
            | [] ->
                let* y = y in
-               instr (Push y)
+               instr (Return (Some y))
            | x :: rem ->
                let* x = load x in
-               build_applies (call ~cps:false ~arity:1 y [ x ]) rem
+               let* c = call ~cps:false ~arity:1 y [ x ] in
+               build_applies (return (W.Br_on_null (0, c))) rem
          in
          build_applies (load f) l)
     in
+    let body =
+      let* () = block { params = []; result = [] } body in
+      instr (Return (Some (RefNull Any)))
+    in
     let param_names = l @ [ f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
       { name
       ; exported_name = None
       ; typ = None
-      ; signature = Type.primitive_type (arity + 1)
+      ; signature = Type.func_type arity
       ; param_names
       ; locals
       ; body

compiler/lib-wasm/gc_target.ml

@@ -27,6 +27,8 @@ let include_closure_arity = false
 module Type = struct
   let value = W.Ref { nullable = false; typ = Eq }
 
+  let value_or_exn = W.Ref { nullable = true; typ = Eq }
+
   let block_type =
     register_type "block" (fun () ->
         return
@@ -205,7 +207,8 @@ module Type = struct
   let primitive_type n =
     { W.params = List.init ~len:n ~f:(fun _ -> value); result = [ value ] }
 
-  let func_type n = primitive_type (n + 1)
+  let func_type n =
+    { W.params = List.init ~len:(n + 1) ~f:(fun _ -> value); result = [ value_or_exn ] }
 
   let function_type ~cps n =
     let n = if cps then n + 1 else n in

compiler/lib-wasm/generate.ml

@@ -782,6 +782,8 @@ module Generate (Target : Target_sig.S) = struct
         in
         Memory.allocate ~tag:0 ~deadcode_sentinal:ctx.deadcode_sentinal ~load l)
 
+  let exception_handler_pc = -3
+
   let rec translate_expr ctx context x e =
     match e with
     | Apply { f; args; exact }
@@ -799,17 +801,21 @@ module Generate (Target : Target_sig.S) = struct
                   (load funct)
               in
               let* b = is_closure f in
+              let label = label_index context exception_handler_pc in
               if b
-              then return (W.Call (f, List.rev (closure :: acc)))
+              then return (W.Br_on_null (label, W.Call (f, List.rev (closure :: acc))))
               else
                 match funct with
                 | W.RefFunc g ->
                     (* Functions with constant closures ignore their
                        environment. In case of partial application, we
                        still need the closure. *)
                     let* cl = if exact then Value.unit else return closure in
-                    return (W.Call (g, List.rev (cl :: acc)))
-                | _ -> return (W.Call_ref (ty, funct, List.rev (closure :: acc))))
+                    return (W.Br_on_null (label, W.Call (g, List.rev (cl :: acc))))
+                | _ ->
+                    return
+                      (W.Br_on_null
+                         (label, W.Call_ref (ty, funct, List.rev (closure :: acc)))))
           | x :: r ->
               let* x = load_and_box ctx x in
               loop (x :: acc) r
@@ -821,7 +827,9 @@ module Generate (Target : Target_sig.S) = struct
         in
         let* args = expression_list (fun x -> load_and_box ctx x) args in
         let* closure = load f in
-        return (W.Call (apply, args @ [ closure ]))
+        return
+          (W.Br_on_null
+             (label_index context exception_handler_pc, W.Call (apply, args @ [ closure ])))
     | Block (tag, a, _, _) ->
         Memory.allocate
           ~deadcode_sentinal:ctx.deadcode_sentinal
@@ -1075,32 +1083,55 @@ module Generate (Target : Target_sig.S) = struct
           { params = []; result = [] }
           (body ~result_typ:[] ~fall_through:(`Block pc) ~context:(`Block pc :: context))
       in
-      if List.is_empty result_typ
+      if true && List.is_empty result_typ
       then handler
       else
         let* () = handler in
-        instr (W.Return (Some (RefI31 (Const (I32 0l)))))
+        let* u = Value.unit in
+        instr (W.Return (Some u))
     else body ~result_typ ~fall_through ~context
 
-  let wrap_with_handlers p pc ~result_typ ~fall_through ~context body =
+  let wrap_with_handlers ~location p pc ~result_typ ~fall_through ~context body =
     let need_zero_divide_handler, need_bound_error_handler = needed_handlers p pc in
     wrap_with_handler
-      need_bound_error_handler
-      bound_error_pc
-      (let* f =
-         register_import ~name:"caml_bound_error" (Fun { params = []; result = [] })
-       in
-       instr (CallInstr (f, [])))
+      true
+      exception_handler_pc
+      (match location with
+      | `Toplevel ->
+          let* exn =
+            register_import
+              ~import_module:"env"
+              ~name:"caml_exception"
+              (Global { mut = true; typ = Type.value })
+          in
+          let* tag = register_import ~name:exception_name (Tag Type.value) in
+          instr (Throw (tag, GlobalGet exn))
+      | `Exception_handler ->
+          let* exn =
+            register_import
+              ~import_module:"env"
+              ~name:"caml_exception"
+              (Global { mut = true; typ = Type.value })
+          in
+          instr (Br (2, Some (GlobalGet exn)))
+      | `Function -> instr (Return (Some (RefNull Any))))
       (wrap_with_handler
-         need_zero_divide_handler
-         zero_divide_pc
+         need_bound_error_handler
+         bound_error_pc
          (let* f =
-            register_import
-              ~name:"caml_raise_zero_divide"
-              (Fun { params = []; result = [] })
+            register_import ~name:"caml_bound_error" (Fun { params = []; result = [] })
           in
           instr (CallInstr (f, [])))
-         body)
+         (wrap_with_handler
+            need_zero_divide_handler
+            zero_divide_pc
+            (let* f =
+               register_import
+                 ~name:"caml_raise_zero_divide"
+                 (Fun { params = []; result = [] })
+             in
+             instr (CallInstr (f, [])))
+            body))
       ~result_typ
       ~fall_through
       ~context
@@ -1208,19 +1239,34 @@ module Generate (Target : Target_sig.S) = struct
               instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1)))
           | Raise (x, _) -> (
               let* e = load x in
-              let* tag = register_import ~name:exception_name (Tag Type.value) in
               match fall_through with
               | `Catch -> instr (Push e)
               | `Block _ | `Return | `Skip -> (
                   match catch_index context with
                   | Some i -> instr (Br (i, Some e))
-                  | None -> instr (Throw (tag, e))))
+                  | None ->
+                      if Option.is_some name_opt
+                      then
+                        let* exn =
+                          register_import
+                            ~import_module:"env"
+                            ~name:"caml_exception"
+                            (Global { mut = true; typ = Type.value })
+                        in
+                        let* () = instr (GlobalSet (exn, e)) in
+                        instr (Return (Some (RefNull Any)))
+                      else
+                        let* tag =
+                          register_import ~name:exception_name (Tag Type.value)
+                        in
+                        instr (Throw (tag, e))))
           | Pushtrap (cont, x, cont') ->
               handle_exceptions
                 ~result_typ
                 ~fall_through
                 ~context:(extend_context fall_through context)
                 (wrap_with_handlers
+                   ~location:`Exception_handler
                    p
                    (fst cont)
                    (fun ~result_typ ~fall_through ~context ->
@@ -1291,6 +1337,10 @@ module Generate (Target : Target_sig.S) = struct
            let* () = build_initial_env in
            let* () =
              wrap_with_handlers
+               ~location:
+                 (match name_opt with
+                 | None -> `Toplevel
+                 | Some _ -> `Function)
                p
                pc
                ~result_typ:[ Type.value ]
@@ -1342,7 +1392,9 @@ module Generate (Target : Target_sig.S) = struct
                in
                let* () = instr (Drop (Call (f, []))) in
                cont)
-             ~init:(instr (Push (RefI31 (Const (I32 0l)))))
+             ~init:
+               (let* u = Value.unit in
+                instr (Push u))
              to_link)
     in
     context.other_fields <-

compiler/lib-wasm/tail_call.ml

@@ -30,6 +30,10 @@ let rewrite_tail_call ~y i =
       Some (Wasm_ast.Return_call (symb, l))
   | LocalSet (x, Call_ref (ty, e, l)) when Code.Var.equal x y ->
       Some (Return_call_ref (ty, e, l))
+  | LocalSet (x, Br_on_null (_, Call (symb, l))) when Code.Var.equal x y ->
+      Some (Wasm_ast.Return_call (symb, l))
+  | LocalSet (x, Br_on_null (_, Call_ref (ty, e, l))) when Code.Var.equal x y ->
+      Some (Return_call_ref (ty, e, l))
   | _ -> None
 
 let rec instruction ~tail i =
@@ -42,6 +46,11 @@ let rec instruction ~tail i =
   | Push (Call (symb, l)) when tail -> Return_call (symb, l)
   | Push (Call_ref (ty, e, l)) when tail -> Return_call_ref (ty, e, l)
   | Push (Call_ref _) -> i
+  | Return (Some (Br_on_null (_, Call (symb, l)))) -> Return_call (symb, l)
+  | Return (Some (Br_on_null (_, Call_ref (ty, e, l)))) -> Return_call_ref (ty, e, l)
+  | Push (Br_on_null (_, Call (symb, l))) when tail -> Return_call (symb, l)
+  | Push (Br_on_null (_, Call_ref (ty, e, l))) when tail -> Return_call_ref (ty, e, l)
+  | Push (Br_on_null (_, Call_ref _)) -> i
   | Drop (BlockExpr (typ, l)) -> Drop (BlockExpr (typ, instructions ~tail:false l))
   | Drop _
   | LocalSet _