Group primitive types into their own constructor

tjammer · Jun 15, 2024 · 3beebb7 · 3beebb7
1 parent 6d38409
commit 3beebb7
Show file tree

Hide file tree

Showing 11 changed files with 176 additions and 169 deletions.
diff --git a/lib/builtin.ml b/lib/builtin.ml
@@ -71,29 +71,30 @@ type t =
 [@@deriving show]
 
 let tbl =
-  let p = { Types.pattr = Dnorm; pt = Tunit } in
+  let open Types in
+  let p = { Types.pattr = Dnorm; pt = tunit } in
   let tbl = Hashtbl.create 64 in
 
   Hashtbl.add tbl "__unsafe_ptr_get"
     ( Unsafe_ptr_get,
       Types.Tfun
-        ( [ { p with pt = Traw_ptr (Qvar "0") }; { p with pt = Tint } ],
+        ( [ { p with pt = Traw_ptr (Qvar "0") }; { p with pt = tint } ],
           Qvar "0",
           Simple ) );
   Hashtbl.add tbl "__unsafe_ptr_set"
     ( Unsafe_ptr_set,
       Tfun
         ( [
             { pt = Traw_ptr (Qvar "0"); pattr = Dmut };
-            { p with pt = Tint };
+            { p with pt = tint };
             { pt = Qvar "0"; pattr = Dmove };
           ],
-          Tunit,
+          tunit,
           Simple ) );
   Hashtbl.add tbl "__unsafe_ptr_at"
     ( Unsafe_ptr_at,
       Tfun
-        ( [ { p with pt = Traw_ptr (Qvar "0") }; { p with pt = Tint } ],
+        ( [ { p with pt = Traw_ptr (Qvar "0") }; { p with pt = tint } ],
           Traw_ptr (Qvar "0"),
           Simple ) );
   Hashtbl.add tbl "__unsafe_ptr_reinterpret"
@@ -106,71 +107,71 @@ let tbl =
   Hashtbl.add tbl "__realloc"
     ( Realloc,
       Tfun
-        ( [ { pt = Traw_ptr (Qvar "0"); pattr = Dmut }; { p with pt = Tint } ],
-          Tunit,
+        ( [ { pt = Traw_ptr (Qvar "0"); pattr = Dmut }; { p with pt = tint } ],
+          tunit,
           Simple ) );
   Hashtbl.add tbl "__malloc"
-    (Malloc, Tfun ([ { p with pt = Tint } ], Traw_ptr (Qvar "0"), Simple));
+    (Malloc, Tfun ([ { p with pt = tint } ], Traw_ptr (Qvar "0"), Simple));
   Hashtbl.add tbl "ignore"
-    (Ignore, Tfun ([ { p with pt = Qvar "0" } ], Tunit, Simple));
+    (Ignore, Tfun ([ { p with pt = Qvar "0" } ], tunit, Simple));
   Hashtbl.add tbl "int_of_float"
-    (Int_of_float, Tfun ([ { p with pt = Tfloat } ], Tint, Simple));
+    (Int_of_float, Tfun ([ { p with pt = tfloat } ], tint, Simple));
   Hashtbl.add tbl "int_of_i32"
-    (Int_of_i32, Tfun ([ { p with pt = Ti32 } ], Tint, Simple));
+    (Int_of_i32, Tfun ([ { p with pt = ti32 } ], tint, Simple));
   Hashtbl.add tbl "int_of_f32"
-    (Int_of_f32, Tfun ([ { p with pt = Tf32 } ], Tint, Simple));
+    (Int_of_f32, Tfun ([ { p with pt = tf32 } ], tint, Simple));
   Hashtbl.add tbl "float_of_int"
-    (Float_of_int, Tfun ([ { p with pt = Tint } ], Tfloat, Simple));
+    (Float_of_int, Tfun ([ { p with pt = tint } ], tfloat, Simple));
   Hashtbl.add tbl "float_of_f32"
-    (Float_of_f32, Tfun ([ { p with pt = Tf32 } ], Tfloat, Simple));
+    (Float_of_f32, Tfun ([ { p with pt = tf32 } ], tfloat, Simple));
   Hashtbl.add tbl "float_of_i32"
-    (Float_of_i32, Tfun ([ { p with pt = Ti32 } ], Tfloat, Simple));
+    (Float_of_i32, Tfun ([ { p with pt = ti32 } ], tfloat, Simple));
   Hashtbl.add tbl "i32_of_int"
-    (I32_of_int, Tfun ([ { p with pt = Tint } ], Ti32, Simple));
+    (I32_of_int, Tfun ([ { p with pt = tint } ], ti32, Simple));
   Hashtbl.add tbl "i32_of_float"
-    (I32_of_float, Tfun ([ { p with pt = Tfloat } ], Ti32, Simple));
+    (I32_of_float, Tfun ([ { p with pt = tfloat } ], ti32, Simple));
   Hashtbl.add tbl "i32_of_f32"
-    (I32_of_f32, Tfun ([ { p with pt = Tf32 } ], Ti32, Simple));
+    (I32_of_f32, Tfun ([ { p with pt = tf32 } ], ti32, Simple));
   Hashtbl.add tbl "f32_of_float"
-    (F32_of_float, Tfun ([ { p with pt = Tfloat } ], Tf32, Simple));
+    (F32_of_float, Tfun ([ { p with pt = tfloat } ], tf32, Simple));
   Hashtbl.add tbl "f32_of_int"
-    (F32_of_int, Tfun ([ { p with pt = Tint } ], Tf32, Simple));
+    (F32_of_int, Tfun ([ { p with pt = tint } ], tf32, Simple));
   Hashtbl.add tbl "f32_of_i32"
-    (F32_of_i32, Tfun ([ { p with pt = Ti32 } ], Tf32, Simple));
+    (F32_of_i32, Tfun ([ { p with pt = ti32 } ], tf32, Simple));
   Hashtbl.add tbl "u8_of_int"
-    (U8_of_int, Tfun ([ { p with pt = Tint } ], Tu8, Simple));
+    (U8_of_int, Tfun ([ { p with pt = tint } ], Tprim Tu8, Simple));
   Hashtbl.add tbl "u8_to_int"
-    (U8_to_int, Tfun ([ { p with pt = Tu8 } ], Tint, Simple));
+    (U8_to_int, Tfun ([ { p with pt = Tprim Tu8 } ], tint, Simple));
   Hashtbl.add tbl "u16_of_int"
-    (U16_of_int, Tfun ([ { p with pt = Tint } ], Tu16, Simple));
+    (U16_of_int, Tfun ([ { p with pt = tint } ], Tprim Tu16, Simple));
   Hashtbl.add tbl "u16_to_int"
-    (U16_to_int, Tfun ([ { p with pt = Tu16 } ], Tint, Simple));
-  Hashtbl.add tbl "not" (Not, Tfun ([ { p with pt = Tbool } ], Tbool, Simple));
+    (U16_to_int, Tfun ([ { p with pt = Tprim Tu16 } ], tint, Simple));
+  Hashtbl.add tbl "not" (Not, Tfun ([ { p with pt = tbool } ], tbool, Simple));
   Hashtbl.add tbl "mod"
-    (Mod, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Mod, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "__array_get"
     ( Array_get,
       Tfun
-        ( [ { p with pt = Tarray (Qvar "0") }; { p with pt = Tint } ],
+        ( [ { p with pt = Tarray (Qvar "0") }; { p with pt = tint } ],
           Qvar "0",
           Simple ) );
   Hashtbl.add tbl "__array_length"
-    (Array_length, Tfun ([ { p with pt = Tarray (Qvar "0") } ], Tint, Simple));
+    (Array_length, Tfun ([ { p with pt = Tarray (Qvar "0") } ], tint, Simple));
   Hashtbl.add tbl "__array_drop_back"
     ( Array_drop_back,
-      Tfun ([ { pt = Tarray (Qvar "0"); pattr = Dmut } ], Tunit, Simple) );
+      Tfun ([ { pt = Tarray (Qvar "0"); pattr = Dmut } ], tunit, Simple) );
   Hashtbl.add tbl "__array_data"
     ( Array_data,
       Tfun ([ { p with pt = Tarray (Qvar "0") } ], Traw_ptr (Qvar "0"), Simple)
     );
   Hashtbl.add tbl "__array_capacity"
-    (Array_capacity, Tfun ([ { p with pt = Tarray (Qvar "0") } ], Tint, Simple));
+    (Array_capacity, Tfun ([ { p with pt = Tarray (Qvar "0") } ], tint, Simple));
   Hashtbl.add tbl "__fixed_array_get"
     ( Fixed_array_get,
       Tfun
         ( [
             { p with pt = Tfixed_array (ref (Types.Generalized "0"), Qvar "0") };
-            { p with pt = Tint };
+            { p with pt = tint };
           ],
           Qvar "0",
           Simple ) );
@@ -180,7 +181,7 @@ let tbl =
         ( [
             { p with pt = Tfixed_array (ref (Types.Generalized "0"), Qvar "0") };
           ],
-          Tint,
+          tint,
           Simple ) );
   Hashtbl.add tbl "__fixed_array_data"
     ( Fixed_array_data,
@@ -193,96 +194,96 @@ let tbl =
   Hashtbl.add tbl "__unsafe_array_realloc"
     ( Unsafe_array_realloc,
       Tfun
-        ( [ { pt = Tarray (Qvar "0"); pattr = Dmut }; { p with pt = Tint } ],
-          Tunit,
+        ( [ { pt = Tarray (Qvar "0"); pattr = Dmut }; { p with pt = tint } ],
+          tunit,
           Simple ) );
   Hashtbl.add tbl "__unsafe_array_create"
     ( Unsafe_array_create,
-      Tfun ([ { p with pt = Tint } ], Tarray (Qvar "0"), Simple) );
+      Tfun ([ { p with pt = tint } ], Tarray (Qvar "0"), Simple) );
   Hashtbl.add tbl "__unsafe_array_length"
     ( Unsafe_array_length,
-      Tfun ([ { p with pt = Tarray (Qvar "0") } ], Tint, Simple) );
+      Tfun ([ { p with pt = Tarray (Qvar "0") } ], tint, Simple) );
   Hashtbl.add tbl "__unsafe_nullptr"
-    (Unsafe_nullptr, Tfun ([], Traw_ptr Tu8, Simple));
+    (Unsafe_nullptr, Tfun ([], Traw_ptr (Tprim Tu8), Simple));
   Hashtbl.add tbl "__unsafe_funptr"
-    (Unsafe_funptr, Tfun ([ { p with pt = Qvar "0" } ], Traw_ptr Tunit, Simple));
+    (Unsafe_funptr, Tfun ([ { p with pt = Qvar "0" } ], Traw_ptr tunit, Simple));
   Hashtbl.add tbl "__unsafe_clsptr"
-    (Unsafe_clsptr, Tfun ([ { p with pt = Qvar "0" } ], Traw_ptr Tunit, Simple));
+    (Unsafe_clsptr, Tfun ([ { p with pt = Qvar "0" } ], Traw_ptr tunit, Simple));
   Hashtbl.add tbl "nullptr?"
-    (Is_nullptr, Tfun ([ { p with pt = Traw_ptr (Qvar "0") } ], Tbool, Simple));
+    (Is_nullptr, Tfun ([ { p with pt = Traw_ptr (Qvar "0") } ], tbool, Simple));
   Hashtbl.add tbl "assert"
-    (Assert, Tfun ([ { p with pt = Tbool } ], Tunit, Simple));
+    (Assert, Tfun ([ { p with pt = tbool } ], tunit, Simple));
   Hashtbl.add tbl "copy"
     (Copy, Tfun ([ { p with pt = Qvar "0" } ], Qvar "0", Simple));
   Hashtbl.add tbl "land"
-    (Land, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Land, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "lor"
-    (Lor, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Lor, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "lxor"
-    (Lxor, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Lxor, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "lshl"
-    (Lshl, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Lshl, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "lshr"
-    (Lshr, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Lshr, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "ashr"
-    (Ashr, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Ashr, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "__addi"
-    (Addi, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Addi, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "__subi"
-    (Subi, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Subi, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "__multi"
-    (Multi, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Multi, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "__divi"
-    (Divi, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tint, Simple));
+    (Divi, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tint, Simple));
   Hashtbl.add tbl "__addf"
     ( Addf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tfloat, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tfloat, Simple)
     );
   Hashtbl.add tbl "__subf"
     ( Subf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tfloat, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tfloat, Simple)
     );
   Hashtbl.add tbl "__mulf"
     ( Mulf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tfloat, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tfloat, Simple)
     );
   Hashtbl.add tbl "__divf"
     ( Divf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tfloat, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tfloat, Simple)
     );
   Hashtbl.add tbl "__lessi"
-    (Lessi, Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tbool, Simple));
+    (Lessi, Tfun ([ { p with pt = tint }; { p with pt = tint } ], tbool, Simple));
   Hashtbl.add tbl "__greateri"
     ( Greateri,
-      Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tbool, Simple) );
+      Tfun ([ { p with pt = tint }; { p with pt = tint } ], tbool, Simple) );
   Hashtbl.add tbl "__lesseqi"
     ( Lesseqi,
-      Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tbool, Simple) );
+      Tfun ([ { p with pt = tint }; { p with pt = tint } ], tbool, Simple) );
   Hashtbl.add tbl "__greatereqi"
     ( Greatereqi,
-      Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tbool, Simple) );
+      Tfun ([ { p with pt = tint }; { p with pt = tint } ], tbool, Simple) );
   Hashtbl.add tbl "__equali"
     ( Equali,
-      Tfun ([ { p with pt = Tint }; { p with pt = Tint } ], Tbool, Simple) );
+      Tfun ([ { p with pt = tint }; { p with pt = tint } ], tbool, Simple) );
   Hashtbl.add tbl "__lessf"
     ( Lessf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tbool, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tbool, Simple)
     );
   Hashtbl.add tbl "__greaterf"
     ( Greaterf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tbool, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tbool, Simple)
     );
   Hashtbl.add tbl "__lesseqf"
     ( Lesseqf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tbool, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tbool, Simple)
     );
   Hashtbl.add tbl "__greatereqf"
     ( Greatereqf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tbool, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tbool, Simple)
     );
   Hashtbl.add tbl "__equalf"
     ( Equalf,
-      Tfun ([ { p with pt = Tfloat }; { p with pt = Tfloat } ], Tbool, Simple)
+      Tfun ([ { p with pt = tfloat }; { p with pt = tfloat } ], tbool, Simple)
     );
   Hashtbl.add tbl "__rc_create"
     ( Rc_create,

diff --git a/lib/map_module.ml b/lib/map_module.ml
@@ -36,7 +36,7 @@ module Canonize = struct
             let ns = string_of_int !c in
             incr c;
             (Smap.add id ns sub, Qvar ns))
-    | (Tint | Tbool | Tunit | Tu8 | Tu16 | Tfloat | Ti32 | Tf32) as t -> (sub, t)
+    | Tprim _ as t -> (sub, t)
     | Tvar { contents = Link t } -> canonize sub t
     | Tfun (ps, r, k) ->
         let sub, ps =

diff --git a/lib/module.ml b/lib/module.ml
@@ -564,7 +564,7 @@ let extract_name_type env = function
   | Malias (l, n, tree) -> Some (n, l, tree.typ, Mvalue None)
   | Mlocal_module (l, n, _) ->
       (* Do we have to deal with this? *)
-      Some (n, l, Tunit, Mvalue None)
+      Some (n, l, tunit, Mvalue None)
   | Mmodule_alias _ | Mmodule_type _ | Mfunctor _ | Mapplied_functor _ -> None
 
 let find_item name kind (n, _, _, tkind) =

diff --git a/lib/monomorph_tree.ml b/lib/monomorph_tree.ml
@@ -156,14 +156,14 @@ let reconstr_module_username ~mname ~mainmod username =
 
 let rec cln p = function
   | Types.Tvar { contents = Link t } | Talias (_, t) -> cln p t
-  | Tint -> Tint
-  | Tbool -> Tbool
-  | Tunit -> Tunit
-  | Tu8 -> Tu8
-  | Tu16 -> Tu16
-  | Tfloat -> Tfloat
-  | Ti32 -> Ti32
-  | Tf32 -> Tf32
+  | Tprim Tint -> Tint
+  | Tprim Tbool -> Tbool
+  | Tprim Tunit -> Tunit
+  | Tprim Tu8 -> Tu8
+  | Tprim Tu16 -> Tu16
+  | Tprim Tfloat -> Tfloat
+  | Tprim Ti32 -> Ti32
+  | Tprim Tf32 -> Tf32
   | Qvar id | Tvar { contents = Unbound (id, _) } -> Tpoly id
   | Tfun (params, ret, kind) ->
       Tfun (List.map (cln_param p) params, cln p ret, cln_kind p kind)

diff --git a/lib/typing/env.ml b/lib/typing/env.ml
@@ -130,7 +130,7 @@ type unused = (Path.t * warn_kind * Ast.loc) list
 
 let def_value env =
   {
-    typ = Tunit;
+    typ = Tprim Tunit;
     param = false;
     const = false;
     global = false;
@@ -140,7 +140,7 @@ let def_value env =
 
 let def_mname mname =
   {
-    typ = Tunit;
+    typ = Tprim Tunit;
     param = false;
     const = false;
     global = false;

diff --git a/lib/typing/inference.ml b/lib/typing/inference.ml
@@ -148,6 +148,7 @@ let rec unify t1 t2 =
         unify l r;
         if not (Int.equal li ri) then raise Unify
     | Tfixed_array (li, l), Tfixed_array (ri, r) when li == ri -> unify l r
+    | Tprim l, Tprim r when l == r -> ()
     | l, r when l == r -> ()
     | _ -> raise Unify
 
@@ -336,8 +337,7 @@ module Nameset = Set.Make (Path)
    We need to match everything for weak vars though *)
 let rec types_match ~in_functor l r =
   let rec collect_names acc = function
-    | Tint | Tbool | Tunit | Tu8 | Tu16 | Tfloat | Ti32 | Tf32 | Qvar _ | Tfun _
-    | Traw_ptr _ | Tarray _ | Trc _
+    | Tprim _ | Qvar _ | Tfun _ | Traw_ptr _ | Tarray _ | Trc _
     | Tvar { contents = Unbound _ }
     | Trecord (_, None, _)
     | Tfixed_array _ ->
@@ -357,6 +357,7 @@ let rec types_match ~in_functor l r =
     if l == r then (r, qsubst, true)
     else
       match (l, r) with
+      | Tprim l, Tprim r' when l == r' -> (r, qsubst, true)
       | Tvar { contents = Unbound (l, _) }, Tvar { contents = Unbound (rid, _) }
       | Qvar l, Tvar { contents = Unbound (rid, _) }
         when in_functor -> (
@@ -569,7 +570,7 @@ and match_type_params ~in_functor params typ =
   | Talias (n, t) ->
       let* t = match_type_params ~in_functor params t in
       Ok (Talias (n, t))
-  | (Tint | Tbool | Tunit | Tu8 | Tu16 | Tfloat | Ti32 | Tf32) as t -> (
+  | Tprim _ as t -> (
       match params with
       | [] -> Ok t
       | _ -> Error "Primitive type has no type parameter")
@@ -597,7 +598,7 @@ and match_type_params ~in_functor params typ =
   | Tfun _ -> failwith "TODO abstract function types"
 
 and replace_qvar ~in_functor subst = function
-  | (Tint | Tbool | Tunit | Tu8 | Tu16 | Tfloat | Ti32 | Tf32) as t -> t
+  | Tprim _ as t -> t
   | Qvar s -> (
       match Smap.find_opt s subst with
       | None -> Qvar s