Add support for ArrayBuffer and typed arrays to @unboxed (#7788)

* Add support for ArrayBuffer to @unboxed

* Add support for typed arrays to @unboxed

Author: mediremi

compiler/ml/ast_untagged_variants.ml

@@ -1,12 +1,44 @@
 module Instance = struct
-  type t = Array | Blob | Date | File | Promise | RegExp
+  type t =
+    | Array
+    | ArrayBuffer
+    | BigInt64Array
+    | BigUint64Array
+    | Blob
+    | DataView
+    | Date
+    | File
+    | Float32Array
+    | Float64Array
+    | Int16Array
+    | Int32Array
+    | Int8Array
+    | Promise
+    | RegExp
+    | Uint16Array
+    | Uint32Array
+    | Uint8Array
+    | Uint8ClampedArray
   let to_string = function
     | Array -> "Array"
+    | ArrayBuffer -> "ArrayBuffer"
+    | BigInt64Array -> "BigInt64Array"
+    | BigUint64Array -> "BigUint64Array"
     | Blob -> "Blob"
+    | DataView -> "DataView"
     | Date -> "Date"
     | File -> "File"
+    | Float32Array -> "Float32Array"
+    | Float64Array -> "Float64Array"
+    | Int16Array -> "Int16Array"
+    | Int32Array -> "Int32Array"
+    | Int8Array -> "Int8Array"
     | Promise -> "Promise"
     | RegExp -> "RegExp"
+    | Uint16Array -> "Uint16Array"
+    | Uint32Array -> "Uint32Array"
+    | Uint8Array -> "Uint8Array"
+    | Uint8ClampedArray -> "Uint8ClampedArray"
 end
 
 type untagged_error =
@@ -200,37 +232,54 @@ let type_to_instanceof_backed_obj (t : Types.type_expr) =
   | Tconstr (path, _, _) when Path.same path Predef.path_array -> Some Array
   | Tconstr (path, _, _) -> (
     match Path.name path with
+    | "Stdlib_ArrayBuffer.t" -> Some ArrayBuffer
+    | "Stdlib.BigInt64Array.t" -> Some BigInt64Array
+    | "Stdlib.BigUint64Array.t" -> Some BigUint64Array
+    | "Stdlib.DataView.t" -> Some DataView
     | "Stdlib_Date.t" -> Some Date
+    | "Stdlib.Float32Array.t" -> Some Float32Array
+    | "Stdlib.Float64Array.t" -> Some Float64Array
+    | "Stdlib.Int16Array.t" -> Some Int16Array
+    | "Stdlib.Int32Array.t" -> Some Int32Array
+    | "Stdlib.Int8Array.t" -> Some Int8Array
     | "Stdlib_RegExp.t" -> Some RegExp
+    | "Stdlib.Uint16Array.t" -> Some Uint16Array
+    | "Stdlib.Uint32Array.t" -> Some Uint32Array
+    | "Stdlib.Uint8Array.t" -> Some Uint8Array
+    | "Stdlib.Uint8ClampedArray.t" -> Some Uint8ClampedArray
     | "Js_file.t" -> Some File
     | "Js_blob.t" -> Some Blob
     | _ -> None)
   | _ -> None
 
 let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option =
-  let t = !expand_head env t in
-  match t with
-  | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string ->
-    Some StringType
-  | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int ->
-    Some IntType
-  | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float ->
-    Some FloatType
-  | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint ->
-    Some BigintType
-  | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool ->
-    Some BooleanType
-  | {desc = Tarrow _} -> Some FunctionType
-  | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string ->
-    Some StringType
-  | {desc = Tconstr _} as t when type_is_builtin_object t -> Some ObjectType
-  | {desc = Tconstr _} as t
-    when type_to_instanceof_backed_obj t |> Option.is_some -> (
-    match type_to_instanceof_backed_obj t with
-    | None -> None
-    | Some instance_type -> Some (InstanceType instance_type))
-  | {desc = Ttuple _} -> Some (InstanceType Array)
-  | _ -> None
+  (* First check the original (unexpanded) type for typed arrays and other instance types *)
+  match type_to_instanceof_backed_obj t with
+  | Some instance_type -> Some (InstanceType instance_type)
+  | None -> (
+    (* If original type didn't match, expand and try standard checks *)
+    let expanded_t = !expand_head env t in
+    match expanded_t with
+    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string ->
+      Some StringType
+    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int ->
+      Some IntType
+    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float ->
+      Some FloatType
+    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint ->
+      Some BigintType
+    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool ->
+      Some BooleanType
+    | {desc = Tarrow _} -> Some FunctionType
+    | {desc = Tconstr _} as expanded_t when type_is_builtin_object expanded_t ->
+      Some ObjectType
+    | {desc = Tconstr _} as expanded_t
+      when type_to_instanceof_backed_obj expanded_t |> Option.is_some -> (
+      match type_to_instanceof_backed_obj expanded_t with
+      | None -> None
+      | Some instance_type -> Some (InstanceType instance_type))
+    | {desc = Ttuple _} -> Some (InstanceType Array)
+    | _ -> None)
 
 let get_block_type ~env (cstr : Types.constructor_declaration) :
     block_type option =

tests/tests/src/UntaggedVariants.mjs

@@ -2,7 +2,6 @@
 
 import * as Js_dict from "rescript/lib/es6/Js_dict.js";
 import * as Belt_Array from "rescript/lib/es6/Belt_Array.js";
-import * as Primitive_array from "rescript/lib/es6/Primitive_array.js";
 import * as Primitive_option from "rescript/lib/es6/Primitive_option.js";
 
 function classify(x) {
@@ -289,7 +288,7 @@ let OverlapObject = {
 
 function classify$7(v) {
   if (Array.isArray(v)) {
-    return Primitive_array.get(v, 0);
+    return v[0];
   } else {
     return v.x;
   }
@@ -303,7 +302,7 @@ function classify$8(v) {
   if (typeof v === "object" && !Array.isArray(v)) {
     return v.x;
   } else {
-    return Primitive_array.get(v, 0);
+    return v[0];
   }
 }
 
@@ -356,7 +355,7 @@ let OptionUnboxingHeuristic = {
 
 function classify$9(v) {
   if (Array.isArray(v)) {
-    return Primitive_array.get(v, 0);
+    return v[0];
   }
   switch (typeof v) {
     case "object" :
@@ -522,6 +521,58 @@ async function classifyAll(t) {
     console.log(t.size);
     return;
   }
+  if (t instanceof ArrayBuffer) {
+    console.log("ArrayBuffer");
+    return;
+  }
+  if (t instanceof Int8Array) {
+    console.log("Int8Array");
+    return;
+  }
+  if (t instanceof Int16Array) {
+    console.log("Int16Array");
+    return;
+  }
+  if (t instanceof Int32Array) {
+    console.log("Int32Array");
+    return;
+  }
+  if (t instanceof Uint8Array) {
+    console.log("Uint8Array");
+    return;
+  }
+  if (t instanceof Uint8ClampedArray) {
+    console.log("Uint8ClampedArray");
+    return;
+  }
+  if (t instanceof Uint16Array) {
+    console.log("Uint16Array");
+    return;
+  }
+  if (t instanceof Uint32Array) {
+    console.log("Uint32Array");
+    return;
+  }
+  if (t instanceof Float32Array) {
+    console.log("Float32Array");
+    return;
+  }
+  if (t instanceof Float64Array) {
+    console.log("Float64Array");
+    return;
+  }
+  if (t instanceof BigInt64Array) {
+    console.log("BigInt64Array");
+    return;
+  }
+  if (t instanceof BigUint64Array) {
+    console.log("BigUint64Array");
+    return;
+  }
+  if (t instanceof DataView) {
+    console.log("DataView");
+    return;
+  }
   switch (typeof t) {
     case "string" :
       console.log(t);
@@ -606,8 +657,6 @@ let RecursiveType = {
   }
 };
 
-let $$Array;
-
 let i = 42;
 
 let i2 = 42.5;
@@ -622,7 +671,6 @@ let w = {
 };
 
 export {
-  $$Array,
   i,
   i2,
   s,

tests/tests/src/UntaggedVariants.res

@@ -1,5 +1,3 @@
-module Array = Ocaml_Array
-
 @unboxed
 type t = A | I(int) | S(string)
 @unboxed
@@ -182,7 +180,7 @@ let classify  (x : t) : tagged_t =
   else if Js_array2.isArray x  then
     JSONArray (Obj.magic x)
   else
-    JSONObject (Obj.magic x)  
+    JSONObject (Obj.magic x)
  */
 }
 
@@ -249,7 +247,7 @@ module RecordIsObject = {
   let classify = v =>
     switch v {
     | Record({x}) => x
-    | Array(a) => a[0]
+    | Array(a) => a->Array.getUnsafe(0)
     }
 }
 
@@ -260,7 +258,7 @@ module ArrayAndObject = {
   let classify = v =>
     switch v {
     | Record({x}) => x
-    | Array(a) => a[0]
+    | Array(a) => a->Array.getUnsafe(0)
     }
 }
 
@@ -303,7 +301,7 @@ module TestFunctionCase = {
   let classify = v =>
     switch v {
     | Record({x}) => x
-    | Array(a) => a[0]
+    | Array(a) => a->Array.getUnsafe(0)
     | Function(f) => f(3)
     }
 
@@ -402,6 +400,19 @@ module AllInstanceofTypes = {
     | RegExp(Stdlib_RegExp.t)
     | File(Js.File.t)
     | Blob(Js.Blob.t)
+    | ArrayBuffer(ArrayBuffer.t)
+    | Int8Array(Int8Array.t)
+    | Int16Array(Int16Array.t)
+    | Int32Array(Int32Array.t)
+    | Uint8Array(Uint8Array.t)
+    | Uint8ClampedArray(Uint8ClampedArray.t)
+    | Uint16Array(Uint16Array.t)
+    | Uint32Array(Uint32Array.t)
+    | Float32Array(Float32Array.t)
+    | Float64Array(Float64Array.t)
+    | BigInt64Array(BigInt64Array.t)
+    | BigUint64Array(BigUint64Array.t)
+    | DataView(DataView.t)
 
   let classifyAll = async (t: t) =>
     switch t {
@@ -413,6 +424,19 @@ module AllInstanceofTypes = {
     | Array(arr) => Js.log(arr->Belt.Array.joinWith("-", x => x))
     | File(file) => Js.log(file->fileName)
     | Blob(blob) => Js.log(blob->blobSize)
+    | ArrayBuffer(_) => Js.log("ArrayBuffer")
+    | Int8Array(_) => Js.log("Int8Array")
+    | Int16Array(_) => Js.log("Int16Array")
+    | Int32Array(_) => Js.log("Int32Array")
+    | Uint8Array(_) => Js.log("Uint8Array")
+    | Uint8ClampedArray(_) => Js.log("Uint8ClampedArray")
+    | Uint16Array(_) => Js.log("Uint16Array")
+    | Uint32Array(_) => Js.log("Uint32Array")
+    | Float32Array(_) => Js.log("Float32Array")
+    | Float64Array(_) => Js.log("Float64Array")
+    | BigInt64Array(_) => Js.log("BigInt64Array")
+    | BigUint64Array(_) => Js.log("BigUint64Array")
+    | DataView(_) => Js.log("DataView")
     }
 }