From 0cfb20e702284b706568cc38ec5ca51f6dd98951 Mon Sep 17 00:00:00 2001 From: Jonathan Protzenko Date: Tue, 23 Mar 2021 18:33:16 -0600 Subject: [PATCH 1/2] Record hints prior to bundle elimination so that users can provide naming hints in to-be-dropped files --- src/Ast.ml | 2 ++ src/Inlining.ml | 45 ++++++++++++++--------------------------- src/Kremlin.ml | 1 + src/Monomorphization.ml | 1 - src/NamingHints.ml | 31 ++++++++++++++++++++++++++++ 5 files changed, 49 insertions(+), 31 deletions(-) diff --git a/src/Ast.ml b/src/Ast.ml index d6378b40f..9258523b4 100644 --- a/src/Ast.ml +++ b/src/Ast.ml @@ -629,3 +629,5 @@ let flags_of_decl = function | DType (_, flags, _, _) | DExternal (_, flags, _, _, _) -> flags + +let tuple_lid = [ "K" ], "" diff --git a/src/Inlining.ml b/src/Inlining.ml index ec40af688..ce897e260 100644 --- a/src/Inlining.ml +++ b/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 diff --git a/src/Kremlin.ml b/src/Kremlin.ml index 5d3f671b1..508574158 100644 --- a/src/Kremlin.ml +++ b/src/Kremlin.ml @@ -495,6 +495,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 diff --git a/src/Monomorphization.ml b/src/Monomorphization.ml index 43c527760..80df065a0 100644 --- a/src/Monomorphization.ml +++ b/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) diff --git a/src/NamingHints.ml b/src/NamingHints.ml index 82e1cd6e5..49601f137 100644 --- a/src/NamingHints.ml +++ b/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) -> From 82cae1dc4c0ab0a475b597b3314ddfccfcaf88a5 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Sun, 11 Apr 2021 09:05:09 +0200 Subject: [PATCH 2/2] Add an implementation for char_of_uint8 in kremlib/c/c.c --- kremlib/c/c.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/kremlib/c/c.c b/kremlib/c/c.c index 18e78ce88..bffc2b9a8 100644 --- a/kremlib/c/c.c +++ b/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; }