Merge remote-tracking branch 'origin/son_string'

kremlib/c/c.c

@@ -8,6 +8,10 @@
 
 intptr_t nullptr = (intptr_t) NULL;
 
+char char_of_uint8(uint8_t c) {
+    return c;
+}
+
 bool __eq__C_char(char c1, char c2) {
   return c1 == c2;
 }

src/Ast.ml

@@ -629,3 +629,5 @@ let flags_of_decl = function
   | DType (_, flags, _, _)
   | DExternal (_, flags, _, _, _) ->
       flags
+
+let tuple_lid = [ "K" ], ""

src/Inlining.ml

@@ -463,11 +463,6 @@ let inline files =
 
 
 let inline_type_abbrevs files =
-  let gc_map = Helpers.build_map files (fun map -> function
-    | DType (lid, flags, _, _) when List.mem GcType flags -> Hashtbl.add map lid ()
-    | _ -> ()
-  ) in
-
   let map = Helpers.build_map files (fun map -> function
     | DType (lid, _, _, Abbrev t) -> Hashtbl.add map lid (White, t)
     | _ -> ()
@@ -493,31 +488,21 @@ let inline_type_abbrevs files =
    *   type pair a b = Tuple (1, 0)
    * breaks this invariant. *)
   filter_decls (function
-    | DType (lid, flags, n, Abbrev def) ->
-        begin match def with
-        | TApp (hd, args)
-          when List.assoc_opt (hd, args) !NamingHints.hints = None &&
-          not (Hashtbl.mem gc_map hd) ->
-            (* Don't use a type abbreviation towards a to-be-GC'd type as a
-             * hint, because there will be a mismatch later on with a * being
-             * added. This is mosly for backwards-compat with miTLS having
-             * hand-written code in mitlsffi.c. *)
-            NamingHints.(hints := ((hd, args), lid) :: !hints);
-            (* Never leave the abbreviation in the program otherwise there will
-             * be two types with the same name, the abbreviation and the
-             * monomorphized one. *)
-            None
-        | TTuple args when List.assoc_opt (Monomorphization.tuple_lid, args) !NamingHints.hints = None ->
-            NamingHints.(hints := ((Monomorphization.tuple_lid, args), lid) :: !hints);
-            None
-        | _ ->
-          if n = 0 then
-            Some (DType (lid, flags, n, Abbrev def))
-          else
-            (* A type definition with parameters is not something we'll be able to
-             * generate code for (at the moment). So, drop it. *)
-            None
-        end
+    | DType (_, _, n, Abbrev def) as d ->
+        let in_hints = match def with
+          | TApp (hd, args) ->
+              List.assoc_opt (hd, args) !NamingHints.hints <> None
+          | TTuple args ->
+              List.assoc_opt (tuple_lid, args) !NamingHints.hints <> None
+          | _ ->
+              false
+        in
+        if in_hints then
+          None
+        else if n > 0 then
+          None
+        else
+          Some d
 
     | d ->
         Some d

src/Kremlin.ml

@@ -498,6 +498,7 @@ Supported options:|}
    *   A_f" comes before "static void B_g" (since they're static, there's no
    *   forward declaration in the header. *)
   let files = Builtin.make_libraries files in
+  NamingHints.record files;
   let files = Bundles.topological_sort files in
 
   (* 1. We create bundles, and monomorphize functions first. This creates more

src/Monomorphization.ml

@@ -58,7 +58,6 @@ let build_def_map files =
  *)
 type node = lident * typ list
 type color = Gray | Black
-let tuple_lid = [ "K" ], ""
 
 let monomorphize_data_types map = object(self)
 

src/NamingHints.ml

@@ -16,6 +16,37 @@ open PrintAst.Ops
    elimination / unit field elimination. *)
 let hints: ((lident * typ list) * lident) list ref = ref []
 
+
+let record files =
+  let gc_map = Helpers.build_map files (fun map -> function
+    | DType (lid, flags, _, _) when List.mem Common.GcType flags -> Hashtbl.add map lid ()
+    | _ -> ()
+  ) in
+
+  (object
+    inherit [_] iter
+
+    method visit_DType _ lid _ n def =
+      match def with
+      | Abbrev (TApp (hd, args))
+        when List.assoc_opt (hd, args) !hints = None &&
+        not (Hashtbl.mem gc_map hd) &&
+        n = 0 ->
+          (* Don't use a type abbreviation towards a to-be-GC'd type as a
+           * hint, because there will be a mismatch later on with a * being
+           * added. This is mosly for backwards-compat with miTLS having
+           * hand-written code in mitlsffi.c. *)
+          hints := ((hd, args), lid) :: !hints
+
+      | Abbrev (TTuple args)
+        when List.assoc_opt (tuple_lid, args) !hints = None &&
+        n = 0 ->
+          hints := ((tuple_lid, args), lid) :: !hints
+
+      | _ ->
+          ()
+  end)#visit_files () files
+
 let debug () =
   KPrint.bprintf "==== state of naming hints ====\n";
   List.iter (fun ((hd, args), lid) ->