OxCaml: null support

Author: vouillon

compiler/lib-wasm/gc_target.ml

@@ -1060,6 +1060,11 @@ module Constant = struct
     | NativeInt i ->
         let* e = Memory.make_int32 ~kind:`Nativeint (return (W.Const (I32 i))) in
         return (Const, e)
+    | Null_ ->
+        let* var =
+          register_import ~name:"null" (Global { mut = false; typ = Type.value })
+        in
+        return (Const, W.GlobalGet var)
 
   let translate ~unboxed c =
     match c with

compiler/lib-wasm/generate.ml

@@ -235,8 +235,8 @@ module Generate (Target : Target_sig.S) = struct
         (if negate then Value.phys_neq else Value.phys_eq)
           (transl_prim_arg ctx ~typ:Top x)
           (transl_prim_arg ctx ~typ:Top y)
-    | (Int _ | Number _ | Tuple _ | Bigarray _), _
-    | _, (Int _ | Number _ | Tuple _ | Bigarray _) ->
+    | (Int _ | Number _ | Tuple _ | Bigarray _ | Null), _
+    | _, (Int _ | Number _ | Tuple _ | Bigarray _ | Null) ->
         (* Only Top may contain JavaScript values *)
         (if negate then Value.phys_neq else Value.phys_eq)
           (transl_prim_arg ctx ~typ:Top x)
@@ -1132,7 +1132,13 @@ module Generate (Target : Target_sig.S) = struct
                 let* indices' = transl_prim_arg ctx indices in
                 let* v' = transl_prim_arg ctx v in
                 return (W.Call (f, [ ta'; indices'; v' ])))
-        | _ -> invalid_arity "caml_ba_set_generic" l ~expected:3)
+        | _ -> invalid_arity "caml_ba_set_generic" l ~expected:3);
+    register_un_prim "caml_is_null" `Pure ~ret_typ:int_n (fun x ->
+        let* x = x in
+        let* null =
+          register_import ~name:"null" (Global { mut = false; typ = Type.value })
+        in
+        return (W.RefEq (x, GlobalGet null)))
 
   let unboxed_type ty : W.value_type option =
     match ty with

compiler/lib-wasm/typing.ml

@@ -129,6 +129,7 @@ type typ =
           overapproximation of the possible values of each of its
           fields is given by the array of types *)
   | Bigarray of Bigarray.t
+  | Null
   | Bot
 
 module Domain = struct
@@ -156,11 +157,12 @@ module Domain = struct
            else
              Array.init (max l l') ~f:(fun i ->
                  if i < l then if i < l' then join t.(i) t'.(i) else t.(i) else t'.(i)))
-    | Int _, Tuple _ -> t'
-    | Tuple _, Int _ -> t
+    | (Int _ | Null), Tuple _ -> t'
+    | Tuple _, (Int _ | Null) -> t
     | Bigarray b, Bigarray b' when Bigarray.equal b b' -> t
+    | Null, Null -> Null
     | Top, _ | _, Top -> Top
-    | (Int _ | Number _ | Tuple _ | Bigarray _), _ -> Top
+    | (Int _ | Number _ | Tuple _ | Bigarray _ | Null), _ -> Top
 
   let join_set ?(others = false) f s =
     if others then Top else Var.Set.fold (fun x a -> join (f x) a) s Bot
@@ -173,20 +175,21 @@ module Domain = struct
     | Tuple t, Tuple t' ->
         Array.length t = Array.length t' && Array.for_all2 ~f:equal t t'
     | Bigarray b, Bigarray b' -> Bigarray.equal b b'
-    | (Top | Tuple _ | Int _ | Number _ | Bigarray _ | Bot), _ -> false
+    | Null, Null -> true
+    | (Top | Tuple _ | Int _ | Number _ | Bigarray _ | Null | Bot), _ -> false
 
   let bot = Bot
 
   let depth_treshold = 4
 
   let rec depth t =
     match t with
-    | Top | Bot | Number _ | Int _ | Bigarray _ -> 0
+    | Top | Bot | Number _ | Int _ | Bigarray _ | Null -> 0
     | Tuple l -> 1 + Array.fold_left ~f:(fun acc t' -> max (depth t') acc) l ~init:0
 
   let rec truncate depth t =
     match t with
-    | Top | Bot | Number _ | Int _ | Bigarray _ -> t
+    | Top | Bot | Number _ | Int _ | Bigarray _ | Null -> t
     | Tuple l ->
         if depth = 0
         then Top
@@ -225,6 +228,7 @@ module Domain = struct
           | Boxed -> "boxed"
           | Unboxed -> "unboxed")
     | Bigarray b -> Bigarray.print f b
+    | Null -> Format.fprintf f "null"
     | Tuple t ->
         Format.fprintf
           f
@@ -290,6 +294,7 @@ let rec constant_type (c : constant) =
   | NativeInt _ -> Number (Nativeint, Unboxed)
   | Float _ -> Number (Float, Unboxed)
   | Tuple (_, a, _) -> Tuple (Array.map ~f:(fun c' -> Domain.box (constant_type c')) a)
+  | Null_ -> Null
   | _ -> Top
 
 let arg_type ~approx arg =
@@ -540,7 +545,7 @@ let box_numbers p st types =
                     Var.Set.iter box s)
           | Expr _ -> ()
           | Phi { known; _ } -> Var.Set.iter box known)
-      | Number (_, Boxed) | Int _ | Tuple _ | Bigarray _ | Bot -> ())
+      | Number (_, Boxed) | Int _ | Tuple _ | Bigarray _ | Null | Bot -> ())
   in
   Code.fold_closures
     p

compiler/lib-wasm/typing.mli

@@ -47,6 +47,7 @@ type typ =
   | Number of boxed_number * boxed_status
   | Tuple of typ array
   | Bigarray of Bigarray.t
+  | Null
   | Bot
 
 val constant_type : Code.constant -> typ

compiler/lib/code.ml

@@ -328,6 +328,7 @@ type constant =
   | Int64 of Int64.t
   | NativeInt of Int32.t (* Native int are 32bit on all known backend *)
   | Tuple of int * constant array * array_or_not
+  | Null_
 
 module Constant = struct
   type t = constant
@@ -360,6 +361,7 @@ module Constant = struct
              b)
     | Float a, Float b ->
         Some (Float.ieee_equal (Int64.float_of_bits a) (Int64.float_of_bits b))
+    | Null_, Null_ -> Some true
     | String _, NativeString _ | NativeString _, String _ -> None
     | Int _, Float _ | Float _, Int _ -> None
     | Tuple ((0 | 254), _, _), Float_array _ -> None
@@ -402,6 +404,7 @@ module Constant = struct
     | ( (Int _ | Int32 _ | NativeInt _)
       , (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) ->
         Some false
+    | Null_, _ | _, Null_ -> Some false
     (* Note: the following cases should not occur when compiling to Javascript *)
     | Int _, (Int32 _ | NativeInt _)
     | Int32 _, (Int _ | NativeInt _)
@@ -521,6 +524,7 @@ module Print = struct
               constant f a.(i)
             done;
             Format.fprintf f ")")
+    | Null_ -> Format.fprintf f "null"
 
   let arg f a =
     match a with

compiler/lib/code.mli

@@ -150,6 +150,7 @@ type constant =
   | Int64 of Int64.t
   | NativeInt of Int32.t  (** Only produced when compiling to WebAssembly. *)
   | Tuple of int * constant array * array_or_not
+  | Null_
 
 module Constant : sig
   type t = constant

compiler/lib/eval.ml

@@ -477,6 +477,7 @@ let constant_js_equal a b =
       Some (Float.ieee_equal (Int64.float_of_bits a) (Int64.float_of_bits b))
   | NativeString a, NativeString b -> Some (Native_string.equal a b)
   | String a, String b when Config.Flag.use_js_string () -> Some (String.equal a b)
+  | Null_, Null_ -> Some true
   | Int _, Float _ | Float _, Int _ -> None
   (* All other values may be distinct objects and thus different by [caml_js_equals]. *)
   | String _, _
@@ -492,7 +493,9 @@ let constant_js_equal a b =
   | NativeInt _, _
   | _, NativeInt _
   | Tuple _, _
-  | _, Tuple _ -> None
+  | _, Tuple _
+  | Null_, _
+  | _, Null_ -> None
 
 (* [eval_prim] does not distinguish the two constants *)
 let constant_equal a b =
@@ -504,10 +507,11 @@ let constant_equal a b =
   | Int32 a, Int32 b -> Int32.equal a b
   | NativeInt a, NativeInt b -> Int32.equal a b
   | Int64 a, Int64 b -> Int64.equal a b
+  | Null_, Null_ -> true
   (* We don't need to compare other constants, so let's just return false. *)
   | Tuple _, Tuple _ -> false
   | Float_array _, Float_array _ -> false
-  | (Int _ | Float _ | Int64 _ | Int32 _ | NativeInt _), _ -> false
+  | (Int _ | Float _ | Int64 _ | Int32 _ | NativeInt _ | Null_), _ -> false
   | (String _ | NativeString _), _ -> false
   | (Float_array _ | Tuple _), _ -> false
 
@@ -712,6 +716,7 @@ let the_cond_of info x =
     (fun x ->
       match Flow.Info.def info x with
       | Some (Constant (Int x)) -> if Targetint.is_zero x then Zero else Non_zero
+      | Some (Constant Null_) -> Zero
       | Some
           (Constant
              ( Int32 _

compiler/lib/generate.ml

@@ -536,6 +536,7 @@ let rec constant_rec ~ctx x level instrs =
           Mlvalue.Block.make ~tag ~args:l, instrs)
   | Int i -> targetint i, instrs
   | Int32 i | NativeInt i -> targetint (Targetint.of_int32_exn i), instrs
+  | Null_ -> s_var "null", instrs
 
 let constant ~ctx x level =
   let expr, instr = constant_rec ~ctx x level [] in
@@ -1392,7 +1393,8 @@ let _ =
       bool (J.EBin (J.EqEqEq, cx, cy)));
   register_bin_prim "caml_js_instanceof" `Mutator (fun cx cy _ ->
       bool (J.EBin (J.InstanceOf, cx, cy)));
-  register_un_prim "caml_js_typeof" `Mutator (fun cx _ -> J.EUn (J.Typeof, cx))
+  register_un_prim "caml_js_typeof" `Mutator (fun cx _ -> J.EUn (J.Typeof, cx));
+  register_un_prim "caml_is_null" `Pure (fun cx _ -> J.EBin (EqEqEq, cx, s_var "null"))
 
 (****)
 (* when raising ocaml exception and [improved_stacktrace] is enabled,

compiler/lib/ocaml_compiler.ml

@@ -59,7 +59,7 @@ let rec constant_of_const c : Code.constant =
       Tuple (tag, l, Unknown)
   | ((Const_base (Const_float32 _ | Const_unboxed_float32 _)) [@if oxcaml]) ->
       failwith "Float32 unsupported"
-  | (Const_null [@if oxcaml]) -> failwith "Null unsupported"
+  | (Const_null [@if oxcaml]) -> Null_
 
 type module_or_not =
   | Module

compiler/lib/parse_bytecode.ml

@@ -479,8 +479,16 @@ end = struct
 
   let ident_native = ident_of_custom (Obj.repr 0n)
 
+  external is_null : Obj.t -> bool = "%is_null" [@@if oxcaml]
+
+  let is_null obj = is_null (Sys.opaque_identity obj) [@@if oxcaml]
+
+  let is_null _ = false [@@if not oxcaml]
+
   let rec parse x =
-    if Obj.is_block x
+    if is_null x
+    then Null_
+    else if Obj.is_block x
     then
       let tag = Obj.tag x in
       if tag = Obj.string_tag
@@ -528,6 +536,7 @@ end = struct
         match target with
         | `JavaScript -> true
         | `Wasm -> false)
+    | Null_ -> true
 end
 
 let const32 i = Constant (Int (Targetint.of_int32_exn i))