Merge pull request #525 from FStarLang/protz_dependency_analysis

Revise dependency analysis to be more precise

Author: msprotz

.github/workflows/linux-x64-hierarchic.yaml

@@ -16,7 +16,7 @@ jobs:
         run: |
           echo "CI_INITIAL_TIMESTAMP=$(date '+%s')" >> $GITHUB_ENV
       - name: Check out repo        
-        uses: actions/checkout@v3
+        uses: actions/checkout@v4
       - name: Identify the base FStar branch and the notification channel
         run: |
           echo "FSTAR_BRANCH=$(jq -c -r '.BranchName' .docker/build/config.json)" >> $GITHUB_ENV
@@ -41,7 +41,7 @@ jobs:
           DZOMO_GITHUB_TOKEN: ${{ secrets.DZOMO_GITHUB_TOKEN }}
       - name: Archive build log
         if: ${{ always() }}
-        uses: actions/upload-artifact@v3
+        uses: actions/upload-artifact@v4
         with:
           name: log
           path: log.txt

lib/Bundles.ml

@@ -217,7 +217,23 @@ let make_bundles files =
 (* A more refined version of direct_dependencies (found above), which
    distinguishes between internal and public dependencies. Keeps less dependency
    information, too, since it does not need to generate precise error messages.
-   To be used after Inlining has run. *)
+   To be used after Inlining has run.
+
+   We do not run this on the C grammar (which would presumably be simpler,
+   because by then we would have built both flavors of headers + C files),
+   because it does not distinguish between lids and ids, and also because the
+   grammar is convoluted and makes it hard to access the "name" of a
+   declaration.
+   
+   So instead, we anticipate and rely on the fact that:
+   - to compute the dependencies of the public header, one needs to visit public
+     (not internal, not private) functions and type declarations, and
+     - skip the body of functions unless they are "static header", and
+     - skip the body of type declarations marked as C abstract structs
+   - to compute the dependencies of the internal header, same deal
+   - to compute the dependencies of the C header, same deal except all bodies
+     are visited
+*)
 
 module StringSet = Set.Make(String)
 module LidSet = Idents.LidSet
@@ -227,11 +243,30 @@ type deps = {
   public: StringSet.t;
 }
 
+type all_deps = {
+  h: deps;
+  internal_h: deps;
+  c: deps;
+}
+
 let empty_deps = { internal = StringSet.empty; public = StringSet.empty }
 
 let drop_dinstinction { internal; public } =
   List.of_seq (StringSet.to_seq (StringSet.union internal public))
 
+class record_everything gen_dep = object
+  inherit [_] reduce
+  method plus { internal = i1; public = p1 } { internal = i2; public = p2 } =
+    { internal = StringSet.union i1 i2; public = StringSet.union p1 p2 }
+  method zero = empty_deps
+  method! visit_EQualified _ lid =
+    gen_dep lid
+  method! visit_TQualified _ lid =
+    gen_dep lid
+  method! visit_TApp () lid _ =
+    gen_dep lid
+end
+
 let direct_dependencies_with_internal files file_of =
   (* Set of decls marked as internal *)
   let internal = List.fold_left (fun set (_, decls) ->
@@ -247,29 +282,61 @@ let direct_dependencies_with_internal files file_of =
     let gen_dep (callee: lident) =
       match file_of callee with
       | Some f when f <> fst file && not (Helpers.is_primitive callee) ->
-          (* KPrint.bprintf "In file %s, reference to %a (in file %s)\n" *)
-          (*   (fst file) PrintAst.plid callee f; *)
-          if LidSet.mem callee internal then
+          let is_internal = LidSet.mem callee internal in
+          KPrint.bprintf "In file %s, reference to %a (in %sheader %s)\n"
+            (fst file) PrintAst.plid callee (if is_internal then "internal " else "") f;
+          if is_internal then
             { empty_deps with internal = StringSet.singleton f }
           else
             { empty_deps with public = StringSet.singleton f }
       | _ ->
           empty_deps
     in
-    let deps =
-      (object
-        inherit [_] reduce
-        method plus { internal = i1; public = p1 } { internal = i2; public = p2 } =
-          { internal = StringSet.union i1 i2; public = StringSet.union p1 p2 }
-        method zero = empty_deps
-        method! visit_EQualified _ lid =
-          gen_dep lid
-        method! visit_TQualified _ lid =
-          gen_dep lid
-        method! visit_TApp _ lid _ =
-          gen_dep lid
-      end)#visit_file () file
-    in
+    let is_inline_static lid = List.exists (fun p -> Bundle.pattern_matches_lid p lid) !Options.static_header in
+    let header_deps which = object
+      inherit (record_everything gen_dep) as super
+
+      method! visit_DFunction env cc flags n_cgs n ret name binders body =
+        let concerns_us =
+          match which with
+          | `Public -> not (List.mem Common.Internal flags) && not (List.mem Common.Private flags)
+          | `Internal ->  List.mem Common.Internal flags
+        in
+        if concerns_us then
+          if is_inline_static name then
+            super#visit_DFunction env cc flags n_cgs n ret name binders body
+          else
+            (* ill-typed, but convenient *)
+            super#visit_DFunction env cc flags n_cgs n ret name binders Helpers.eunit
+        else
+          super#zero
+
+      method! visit_DType env name flags n_cgs n def =
+        let concerns_us =
+          match which with
+          | `Public -> not (List.mem Common.Internal flags) && not (List.mem Common.Private flags)
+          | `Internal ->  List.mem Common.Internal flags
+        in
+        let is_c_abstract_struct = List.mem Common.AbstractStruct flags in
+        if concerns_us then
+          if is_c_abstract_struct then
+            super#visit_DType env name flags n_cgs n (Abbrev TUnit)
+          else
+            super#visit_DType env name flags n_cgs n def
+        else
+          super#zero
+    end in
+    let deps = {
+      h = (KPrint.bprintf "PUBLIC %s\n" (fst file); header_deps `Public)#visit_file () file;
+      internal_h = (KPrint.bprintf "INTERNAL %s\n" (fst file); header_deps `Internal)#visit_file () file;
+      c = (KPrint.bprintf "C %s\n" (fst file); new record_everything gen_dep)#visit_file () file;
+    } in
+
+    if not (StringSet.is_empty deps.h.internal) then
+      Warn.fatal_error "Unexpected: %s depends on some internal headers: %s\n"
+        (fst file)
+        (String.concat ", " (List.of_seq (StringSet.to_seq deps.h.internal)));
+       
     StringMap.add (fst file) deps by_file
   ) StringMap.empty files
 

lib/CStarToC11.ml

@@ -1522,19 +1522,18 @@ let mk_headers (map: GlobalNames.mapping)
   ) [] files in
   List.rev headers
 
-let drop_empty_headers deps headers: Bundles.deps Bundles.StringMap.t =
+let drop_empty_headers deps headers: Bundles.all_deps Bundles.StringMap.t =
   let open Bundles in
   (* Refine dependencies to ignore now-gone empty headers. *)
-  let not_dropped_internal f = List.exists (function
-    | (name, C.Internal _) when f = name -> true
-    | _ -> false
-  ) headers in
-  let not_dropped_public f = List.exists (function
-    | (name, Public _) when f = name -> true
-    | _ -> false
-  ) headers in
-  StringMap.map (fun { internal; public } -> {
+  let kept_internal = List.filter_map (function (name, C.Internal _) -> Some name | _ -> None) headers in
+  let kept_public = List.filter_map (function (name, C.Public _) -> Some name | _ -> None) headers in
+  let not_dropped_internal f = List.mem f kept_internal in
+  let not_dropped_public f = List.mem f kept_public in
+  let filter_dep { internal; public } = {
     internal = StringSet.filter not_dropped_internal internal;
     public = StringSet.filter not_dropped_public public
-  }) deps
+  } in
+  StringMap.map (fun { h; internal_h; c } ->
+    { h = filter_dep h; internal_h = filter_dep internal_h; c = filter_dep c }
+  ) deps
 

lib/Output.ml

@@ -140,14 +140,15 @@ let maybe_create_internal_dir h =
   if List.exists (function (_, C11.Internal _) -> true | _ -> false) h then
     create_subdir "internal"
 
-let write_c files internal_headers deps =
+let write_c files internal_headers (deps: Bundles.all_deps Bundles.StringMap.t) =
   Driver.detect_fstar_if ();
   Driver.detect_karamel_if ();
   List.map (fun file ->
     let name, program = file in
-    let deps = Bundles.StringMap.find name deps in
-    let deps = List.of_seq (Bundles.StringSet.to_seq deps.Bundles.internal) in
-    let deps = List.map (fun f -> "internal/" ^ f) deps in
+    let all_deps = Bundles.StringMap.find name deps in
+    let internal_deps = List.of_seq (Bundles.StringSet.to_seq all_deps.Bundles.c.Bundles.internal) in
+    let public_deps = List.of_seq (Bundles.StringSet.to_seq all_deps.Bundles.c.Bundles.public) in
+    let deps = List.map (fun f -> "internal/" ^ f) internal_deps @ public_deps in
     let includes = includes_for ~is_c:true name deps in
     let header = string (header ()) ^^ hardline ^^ hardline in
     let internal = if Bundles.StringSet.mem name internal_headers then "internal/" else "" in
@@ -170,10 +171,14 @@ let write_c files internal_headers deps =
     name
   ) files
 
-let write_h files public_headers deps =
+let write_h files public_headers (deps: Bundles.all_deps Bundles.StringMap.t) =
   List.map (fun file ->
     let name, program = file in
-    let { Bundles.public; internal } = Bundles.StringMap.find name deps in
+    let all_deps = Bundles.StringMap.find name deps in
+    let { Bundles.public; internal } = match program with
+      | C11.Internal _ -> all_deps.Bundles.internal_h
+      | C11.Public _ -> all_deps.Bundles.h
+    in
     let public = List.of_seq (Bundles.StringSet.to_seq public) in
     let internal = List.of_seq (Bundles.StringSet.to_seq internal) in
     let original_name = name in