Merge pull request #357 from FStarLang/protz_renamings

New option to record renamings in a .h file

lib/AstToCFlat.ml

@@ -67,7 +67,7 @@ type env = {
      *     StringLiteral. The strings are shared in memory at compile-time, and
      *     hashconsing in CFlatToWasm guarantees that they are shared in the
      *     resulting code, too. *)
-  names: (lident, ident) Hashtbl.t;
+  names: GlobalNames.mapping;
 }
 
 

lib/AstToCStar.ml

@@ -975,7 +975,7 @@ and mk_files files m ifdefs macros =
 let mk_macros_set files =
   let seen = Hashtbl.create 31 in
   let record x =
-    let t = String.uppercase_ascii GlobalNames.(target_c_name ~attempt_shortening:false ~kind:Macro x) in
+    let t = fst GlobalNames.(target_c_name ~attempt_shortening:false ~kind:Macro x) in
     if Hashtbl.mem seen t then
       Warn.(maybe_fatal_error ("", ConflictMacro (x, t)));
     Hashtbl.add seen t ()

lib/CStarToC11.ml

@@ -64,10 +64,9 @@ module S = Set.Make(String)
 let rec vars_of m = function
   | CStar.Var v ->
       S.singleton v
-  | Qualified v ->
-      S.singleton (to_c_name m v)
+  | Qualified v
   | Macro v ->
-      S.singleton (String.uppercase_ascii (to_c_name m v))
+      S.singleton (to_c_name m v)
   | Constant _
   | Bool _
   | StringLiteral _
@@ -935,11 +934,9 @@ and mk_expr m (e: expr): C.expr =
   | Var ident ->
       Name ident
 
-  | Qualified ident ->
-      Name (to_c_name m ident)
-
+  | Qualified ident
   | Macro ident ->
-      Name (String.uppercase_ascii (to_c_name m ident))
+      Name (to_c_name m ident)
 
   | Constant (w, c) ->
       (* See discussion in AstToCStar.ml, around mk_arith. *)
@@ -1338,7 +1335,7 @@ let mk_file m decls =
         (if_private_or_abstract_struct (mk_type_or_external m C))))
     decls
 
-let mk_files (map: (Ast.lident, Ast.ident) Hashtbl.t) files =
+let mk_files (map: GlobalNames.mapping) files =
   List.map (fun (name, program) -> name, mk_file map program) files
 
 (* Building three flavors of headers. *)
@@ -1368,7 +1365,7 @@ let mk_static f d =
 
 (* Generates either a static header (the union of public + internal), OR just
    the public part. *)
-let mk_public_header (m: (Ast.lident, Ast.ident) Hashtbl.t) decls =
+let mk_public_header (m: GlobalNames.mapping) decls =
   (* In the header file, we put functions and global stubs, along with type
    * definitions that are visible from the outside. *)
   (* What should be the behavior for a type declaration marked as CAbstract but
@@ -1384,15 +1381,15 @@ let mk_public_header (m: (Ast.lident, Ast.ident) Hashtbl.t) decls =
     decls
 
 (* Private part if not already a static header, empty otherwise. *)
-let mk_internal_header (m: (Ast.lident, Ast.ident) Hashtbl.t) decls =
+let mk_internal_header (m: GlobalNames.mapping) decls =
   KList.map_flatten
     (if_internal (
       (if_header_inline_static m
         (mk_static (either (mk_function_or_global_body m) (mk_type_or_external m ~is_inline_static:true C)))
         (either (mk_function_or_global_stub m) (mk_type_or_external m H)))))
     decls
 
-let mk_headers (map: (Ast.lident, Ast.ident) Hashtbl.t)
+let mk_headers (map: GlobalNames.mapping)
   (files: (string * CStar.decl list) list)
 =
   (* Generate headers with a sensible order for the message "WRITING H FILES: ...". *)

lib/GenCtypes.ml

@@ -351,7 +351,7 @@ type t =
  * OCaml declarations. *)
 let mk_ocaml_bindings
   (files : (ident * decl list) list)
-  (m: (A.lident, A.ident) Hashtbl.t)
+  (m: GlobalNames.mapping)
   (file_of: A.lident -> string option):
   (string * string list * structure_item list) list
 =

lib/GenCtypes.mli

@@ -2,7 +2,7 @@ type t
 
 val mk_ocaml_bindings:
   (CStar.ident * CStar.decl list) list ->
-  (Ast.lident, Ast.ident) Hashtbl.t ->
+  GlobalNames.mapping ->
   (Ast.lident -> string option) ->
   t
 

lib/GlobalNames.ml

@@ -8,12 +8,12 @@ open Idents
 open Ast
 open PrintAst.Ops
 
-type mapping = (lident, string) Hashtbl.t
+type mapping = (lident, string * bool) Hashtbl.t
 type t = mapping * (string, unit) Hashtbl.t
 
 let dump (env: t) =
-  Hashtbl.iter (fun lident c_name ->
-    KPrint.bprintf "%a --> %s\n" plid lident c_name
+  Hashtbl.iter (fun lident (c_name, nm) ->
+    KPrint.bprintf "%a --> %s%s\n" plid lident c_name (if nm then " (!)" else "")
   ) (fst env);
   Hashtbl.iter (fun c_name _ ->
     KPrint.bprintf "%s is used\n" c_name
@@ -145,15 +145,15 @@ let create () =
   reserve_keywords used_c_names;
   c_of_original, used_c_names
 
-let extend (global: t) (local: t) is_local original_name desired_name =
+let extend (global: t) (local: t) is_local original_name (desired_name, non_modular_renaming) =
   let c_of_original, g_used_c_names = global in
   let _, l_used_c_names = local in
   if Hashtbl.mem c_of_original original_name then
     fatal_error "Duplicate global name: %a" plid original_name;
 
   let unique_c_name = mk_fresh desired_name (fun x ->
     Hashtbl.mem g_used_c_names x || Hashtbl.mem l_used_c_names x) in
-  Hashtbl.add c_of_original original_name unique_c_name;
+  Hashtbl.add c_of_original original_name (unique_c_name, non_modular_renaming && not is_local);
   if is_local then
     Hashtbl.add l_used_c_names unique_c_name ()
   else
@@ -162,7 +162,7 @@ let extend (global: t) (local: t) is_local original_name desired_name =
 
 let lookup (env: t) name =
   let c_of_original, _ = env in
-  Hashtbl.find_opt c_of_original name
+  Option.map fst (Hashtbl.find_opt c_of_original name)
 
 let clone (env: t) =
   let c_of_original, used_c_names = env in
@@ -221,12 +221,12 @@ let pascal_case name =
     done;
     Buffer.contents b
   else
-    String.uppercase_ascii (String.sub name 0 1) ^ 
+    String.uppercase_ascii (String.sub name 0 1) ^
     String.sub name 1 (String.length name - 1)
 
 let camel_case name =
   let name = pascal_case name in
-  String.lowercase_ascii (String.sub name 0 1) ^ 
+  String.lowercase_ascii (String.sub name 0 1) ^
   String.sub name 1 (String.length name - 1)
 
 let strip_leading_underscores name =
@@ -238,37 +238,48 @@ let strip_leading_underscores name =
 
 type kind = Macro | Type | Other
 
+(* Clients feed the result of this to extend -- this is a tentative name that
+   may still generate a collision. *)
 let target_c_name ~attempt_shortening ?(kind=Other) lid =
-  let pre_name =
+  (* A non-modular renaming is one that is influenced by command-line
+     options (e.g. -no-prefix, -bundle ...[rename-prefix], etc.). Such name
+     choices pose difficulties in the verified library + verified client
+     scenario, because the client needs to replicate the same options in order
+     to be able to link against the library. *)
+  let pre_name, non_modular_renaming =
     if skip_prefix lid && not (ineligible lid) then
-      snd lid
+      snd lid, true
     else if attempt_shortening && !Options.short_names && not (ineligible lid) && snd lid <> "main" then
-      snd lid
+      snd lid, false
     else match rename_prefix lid with
     | Some prefix ->
-        prefix ^ "_" ^ snd lid
+        prefix ^ "_" ^ snd lid, true
     | None ->
-        string_of_lident lid
+        string_of_lident lid, false
   in
-  if !Options.microsoft then
-    if pre_name = "main" then
-      pre_name
+  let formatted_name =
+    if !Options.microsoft then
+      if pre_name = "main" then
+        pre_name
+      else
+        match kind with
+        | Other ->
+            pascal_case pre_name
+        | Macro ->
+            strip_leading_underscores pre_name
+        | Type ->
+            String.uppercase_ascii (strip_leading_underscores pre_name)
     else
-      match kind with
-      | Other ->
-          pascal_case pre_name
-      | Macro ->
-          strip_leading_underscores pre_name
-      | Type ->
-          String.uppercase_ascii (strip_leading_underscores pre_name)
-  else
-    pre_name
+      pre_name
+  in
+  let formatted_name = if kind = Macro then String.uppercase_ascii formatted_name else formatted_name in
+  formatted_name, non_modular_renaming
 
 let to_c_name ?kind m lid =
   try
-    Hashtbl.find m lid
+    fst (Hashtbl.find m lid)
   with Not_found ->
     (* Note: this happens for external types which are not retained as DType
        nodes and therefore are not recorded in the initial name-assignment
        phase. *)
-    Idents.to_c_identifier (target_c_name ?kind ~attempt_shortening:false lid)
+    Idents.to_c_identifier (fst (target_c_name ?kind ~attempt_shortening:false lid))

lib/GlobalNames.mli

@@ -3,15 +3,15 @@
 
 type t
 
-type mapping = (Ast.lident, Ast.ident) Hashtbl.t
+type mapping = (Ast.lident, Ast.ident * bool) Hashtbl.t
 
 (** Allocate a new (mutable) table for a given C scope of top-level declarations. *)
 val create: unit -> t
 
 (** `extend t name c_name` tries to associate `c_name` to `name` in the table
  * `t`. If case there is a name conflict or `c_name` is an invalid C identifier,
  * a suitable replacement name based on `c_name` will be chosen. *)
-val extend: t -> t -> bool -> Ast.lident -> string -> string
+val extend: t -> t -> bool -> Ast.lident -> (string * bool) -> string
 
 (** `lookup t name fallback` recalls the C name associated to `name` in `t`. *)
 val lookup: t -> Ast.lident -> string option
@@ -24,7 +24,7 @@ val clone: t -> t
 
 type kind = Macro | Type | Other
 
-val target_c_name: attempt_shortening:bool -> ?kind:kind -> Ast.lident -> string
+val target_c_name: attempt_shortening:bool -> ?kind:kind -> Ast.lident -> string * bool
 
 val to_c_name: ?kind:kind -> mapping -> Ast.lident -> string
 

lib/Inlining.ml

@@ -512,7 +512,7 @@ let cross_call_analysis files =
 (** A whole-program transformation that inlines functions according to... *)
 
 let always_live name =
-  let n = GlobalNames.target_c_name ~attempt_shortening:false name in
+  let n = fst (GlobalNames.target_c_name ~attempt_shortening:false name) in
   n = "main" ||
   String.length n >= 11 &&
   String.sub n 0 11 = "WasmSupport" &&

lib/Options.ml

@@ -44,6 +44,7 @@ let static_header: Bundle.pat list ref = ref []
 let minimal = ref false
 let by_ref: (string list * string) list ref = ref []
 let ctypes: Bundle.pat list ref = ref []
+let record_renamings = ref false
 
 (* wasm = true ==> these two are false *)
 let struct_passing = ref true

lib/Output.ml

@@ -130,12 +130,15 @@ let write_one name prefix program suffix =
     PPrint.ToChannel.pretty 0.95 100 oc doc
   )
 
+let create_subdir d =
+  if !Options.tmpdir = "" then
+    Driver.mkdirp d
+  else
+    Driver.mkdirp (!Options.tmpdir ^ "/" ^ d)
+
 let maybe_create_internal_dir h =
   if List.exists (function (_, C11.Internal _) -> true | _ -> false) h then
-    if !Options.tmpdir = "" then
-      Driver.mkdirp "internal"
-    else
-      Driver.mkdirp (!Options.tmpdir ^ "/internal")
+    create_subdir "internal"
 
 let write_c files internal_headers deps =
   Driver.detect_fstar_if ();
@@ -227,3 +230,17 @@ let write_def m c_files =
       ) decls
     ) c_files
   )
+
+let write_renamings (m: GlobalNames.mapping) =
+  create_subdir "clients";
+  let dst = in_tmp_dir "clients/krmlrenamings.h" in
+  with_open_out_bin dst (fun oc ->
+    Hashtbl.iter (fun original_name (new_name, non_modular_renaming) ->
+      (* Note: there is a slight imprecision here. If the original name WOULD
+         HAVE BEEN renamed because of a name collision, then this renaming map
+         will be incorrect. We would to track two maps in GlobalNames, the
+         actual one, and the "sans the renamings" one, in order to be accurate.
+         Too much work, unlikely to happen. *)
+      if non_modular_renaming then
+        KPrint.bfprintf oc "#define %s %s\n" (Idents.string_of_lident original_name) new_name)
+    m)

lib/Simplify.ml

@@ -1965,7 +1965,7 @@ let debug env =
   ) original_of_c_name
 
 (* Allocate C names avoiding keywords and name collisions. *)
-let allocate_c_names (files: file list): (lident, ident) Hashtbl.t =
+let allocate_c_names (files: file list): GlobalNames.mapping =
   let env = GlobalNames.create (), Hashtbl.create 41 in
   record_toplevel_names#visit_files env files;
   if Options.debug "c-names" then

lib/Structs.ml

@@ -462,7 +462,7 @@ let collect_initializers (files: Ast.file list) =
       inherit [_] map
       method! visit_DFunction _ cc flags n ret name binders body =
         let body =
-          if GlobalNames.target_c_name ~attempt_shortening:false name = "main" then begin
+          if fst (GlobalNames.target_c_name ~attempt_shortening:false name) = "main" then begin
             found := true;
             with_type ret (ESequence [
               with_type TUnit (EApp (

src/Karamel.ml

@@ -249,6 +249,9 @@ Supported options:|}
       List.iter (prepend Options.hand_written) (Parsers.drop s)),
       "  in conjunction with static-header and library";
     "-extract-uints", Arg.Set Options.extract_uints, ""; (* no doc, intentional *)
+    "-record-renamings", Arg.Set Options.record_renamings, " write a map from \
+      old names to new names in KrmlRenamings.h, useful if you're a library and \
+      don't want to impose clients to follow all of your usages of rename-prefix";
     "-header", Arg.Set_string Options.header, " prepend the contents of the given \
       file at the beginning of each .c and .h";
     "-tmpdir", Arg.Set_string Options.tmpdir, " temporary directory for .out, \
@@ -769,7 +772,11 @@ Supported options:|}
     let h_output = Output.write_h headers public_headers deps in
     GenCtypes.write_bindings ml_files;
     GenCtypes.write_gen_module ~public:public_headers ~internal:internal_headers ml_files;
-    if not !arg_skip_makefiles then Output.write_makefile user_ccopts !c_files c_output h_output;
+    if not !arg_skip_makefiles then
+      Output.write_makefile user_ccopts !c_files c_output h_output;
+    if !Options.record_renamings then
+      Output.write_renamings c_name_map;
+
     tick_print true "PrettyPrinting";
 
     if not !Options.silent then begin

test/sepcomp/a/Makefile

@@ -174,6 +174,7 @@ dist/A.h: $(filter-out %prims.krml,$(ALL_KRML_FILES))
 	$(KRML) -tmpdir $(dir $@) -skip-compilation \
 	  $(filter %.krml,$^) \
 	  -warn-error @4@5@18 \
+	  -record-renamings \
 	  -fparentheses \
 	  -static-header A.Base \
 	  -bundle 'FStar.*,LowStar.*,Prims[rename=SHOULDNOTBETHERE]' \