diff --git a/.github/workflows/linux-x64-hierarchic.yaml b/.github/workflows/linux-x64-hierarchic.yaml index 47785c74..045bec80 100644 --- a/.github/workflows/linux-x64-hierarchic.yaml +++ b/.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 diff --git a/lib/Bundles.ml b/lib/Bundles.ml index eae774af..953d3468 100644 --- a/lib/Bundles.ml +++ b/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 diff --git a/lib/CStarToC11.ml b/lib/CStarToC11.ml index f8c9cf9b..f4545166 100644 --- a/lib/CStarToC11.ml +++ b/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 diff --git a/lib/Output.ml b/lib/Output.ml index 0ae20222..47eb9b26 100644 --- a/lib/Output.ml +++ b/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