diff --git a/lib/Inlining.ml b/lib/Inlining.ml index 47d9b3f7..607c5be0 100644 --- a/lib/Inlining.ml +++ b/lib/Inlining.ml @@ -223,10 +223,18 @@ let cross_call_analysis files = inlining: inlining; wasm_mutable: bool; wasm_needs_getter: bool; + abstract_struct: bool; } end in let open T in + let pvis b = function + | Private -> Buffer.add_string b "Private" + | Internal -> Buffer.add_string b "Internal" + | Public -> Buffer.add_string b "Public" + | Workspace -> Buffer.add_string b "Workspace" + in + (* We associate to each declaration some initial information. Three fields may change after initially filling the map: - visibility may go upward along the visibility lattice (this is only a @@ -238,14 +246,19 @@ let cross_call_analysis files = let info_map = Helpers.build_map files (fun map d -> let f = flags_of_decl d in let name = lid_of_decl d in + let abstract_struct = List.mem Common.AbstractStruct f in let visibility = - if List.mem Common.Private f then - Private - else if List.mem Common.Internal f then + if List.mem Common.Internal f || abstract_struct then + (* C abstract structs start at internal, since their body is going to be in the internal + header. *) Internal + else if List.mem Common.Private f then + Private else Public in + if Options.debug "visibility-fixpoint" then + KPrint.bprintf "[initial visibility] %a: %a\n" plid name pvis visibility; let inlining = let is_static_inline = Helpers.is_static_header name in let is_inline = List.mem Common.Inline f || List.mem Common.MustInline f in @@ -269,7 +282,7 @@ let cross_call_analysis files = in let wasm_needs_getter = false in let callers = LidSet.empty in - Hashtbl.add map (lid_of_decl d) { visibility; inlining; wasm_mutable; wasm_needs_getter; callers } + Hashtbl.add map (lid_of_decl d) { visibility; inlining; wasm_mutable; wasm_needs_getter; callers; abstract_struct } ) in (* We keep track of the declarations we have seen so far. Since the @@ -277,13 +290,6 @@ let cross_call_analysis files = another function indicates that there is mutual recursion. *) let seen = ref LidSet.empty in - let pvis b = function - | Private -> Buffer.add_string b "Private" - | Internal -> Buffer.add_string b "Internal" - | Public -> Buffer.add_string b "Public" - | Workspace -> Buffer.add_string b "Workspace" - in - (* T.Visibility forms a trivial lattice where Private <= Internal <= Public *) let lub: visibility -> visibility -> visibility = max in @@ -301,6 +307,10 @@ let cross_call_analysis files = let record_call_from_to caller callee = try let info = Hashtbl.find info_map callee in + if Options.debug "visibility-fixpoint" then + KPrint.bprintf "[visibility-fixpoint] recording cross-call from %a (%s) to %a (%s)\n" + plid caller (Option.value ~default:"" (file_of caller)) + plid callee (Option.value ~default:"" (file_of callee)); Hashtbl.replace info_map callee { info with callers = LidSet.add caller info.callers } with Not_found -> (* External type currently modeled as an lid without a definition (sigh) *) @@ -492,7 +502,7 @@ let cross_call_analysis files = (visit true)#visit_expr_w () e | DExternal (_, _, _, _, _, t, _) -> (visit false)#visit_typ () t - | DType (_, _, _, _, d) -> + | DType (_, _flags, _, _, d) -> (visit false)#visit_type_def () d end; seen := LidSet.add lid !seen @@ -513,7 +523,13 @@ let cross_call_analysis files = if not (Hashtbl.mem info_map lid) then Warn.fatal_error "No equation for %a" plid lid; let info = Hashtbl.find info_map lid in - LidSet.fold (fun caller v -> lub v (valuation caller)) info.callers info.visibility + let adjust caller = + if (Hashtbl.find info_map caller).abstract_struct then + Internal + else + valuation caller + in + LidSet.fold (fun caller v -> lub v (adjust caller)) info.callers info.visibility ) in (* Adjust definitions based on `info_map` updated with fixpoint *) @@ -521,13 +537,21 @@ let cross_call_analysis files = f, List.map (fun d -> let lid = lid_of_decl d in let info = Hashtbl.find info_map lid in + let old_vis = info.visibility in + (* Fixpoint computation *) let info = { info with visibility = valuation (lid_of_decl d) } in + (* C abstract structs are treated as internal for the purposes of visibility computation, + but the convention is that they end up being marked as public for CStarToC11 to do the + right thing. (This may need fixing.) *) + let info = { info with visibility = if info.abstract_struct then Public else info.visibility } in if Options.debug "visibility-fixpoint" then - KPrint.bprintf "[adjustment]: %a: %a, wasm: mut %b getter %b\n" - plid lid pvis info.visibility info.wasm_mutable info.wasm_needs_getter; + KPrint.bprintf "[adjustment]: %a: %a --> %a, wasm: mut %b getter %b\n" + plid lid pvis old_vis pvis info.visibility info.wasm_mutable info.wasm_needs_getter; + let remove_if cond flag flags = if cond then List.filter ((<>) flag) flags else flags in let add_if cond flag flags = if cond && not (List.mem flag flags) then flag :: flags else flags in let adjust flags = + let flags = remove_if (info.inlining = Nope) Common.Inline flags in let flags = remove_if (info.inlining = Nope) Common.MustInline flags in let flags = remove_if (info.visibility <> Private) Common.Private flags in diff --git a/lib/Monomorphization.ml b/lib/Monomorphization.ml index cd124f9f..d4c8365c 100644 --- a/lib/Monomorphization.ml +++ b/lib/Monomorphization.ml @@ -248,7 +248,7 @@ let monomorphize_data_types map = object(self) (* Current file, for warning purposes. *) val mutable current_file = "" (* Possibly populated with something relevant *) - val mutable best_hint: node * lident = (dummy_lid, [], []), dummy_lid + val mutable best_hint: node * lident * flag list = (dummy_lid, [], []), dummy_lid, [] (* For forward references, a map from lid to its pending monomorphizations (type arguments) *) val pending_monomorphizations: (lident, (typ list * cg list)) Hashtbl.t = Hashtbl.create 41 @@ -314,15 +314,15 @@ let monomorphize_data_types map = object(self) let lid, ts, cgs = n in if ts = [] && cgs = [] then lid, [] - else if fst best_hint = n then - snd best_hint, [] + else if fst3 best_hint = n then + snd3 best_hint, [] else let name, flags = NameGen.gen_lid lid ts (Cg cgs) in if Options.debug "monomorphization" then KPrint.bprintf "No hint provided for %a\n current best hint: %a -> %a\n picking: %a\n" ptyp (fold_tapp (lid, ts, [])) - ptyp (fold_tapp (fst best_hint)) - plid (snd best_hint) + ptyp (fold_tapp (fst3 best_hint)) + plid (snd3 best_hint) plid name; name, flags @@ -345,6 +345,7 @@ let monomorphize_data_types map = object(self) if Options.debug "data-types-traversal" then KPrint.bprintf "visiting %a: Not_found\n" ptyp (fold_tapp n); let chosen_lid, flag = self#lid_of n in + let flag = if fst3 best_hint = n then thd3 best_hint @ flag else flag in if lid = tuple_lid then begin Hashtbl.add state n (Gray, chosen_lid, false); let args = List.map (self#visit_typ under_ref) args in @@ -450,16 +451,16 @@ let monomorphize_data_types map = object(self) if Options.debug "data-types-traversal" then KPrint.bprintf "decl %a\n" plid (lid_of_decl d); match d with - | DType (lid, _, 0, 0, Abbrev (TTuple args)) when not !Options.keep_tuples && not (Hashtbl.mem state (tuple_lid, args, [])) -> + | DType (lid, flags, 0, 0, Abbrev (TTuple args)) when not !Options.keep_tuples && not (Hashtbl.mem state (tuple_lid, args, [])) -> Hashtbl.remove map lid; if Options.debug "monomorphization" then KPrint.bprintf "%a abbreviation for %a\n" plid lid ptyp (TApp (tuple_lid, args)); - best_hint <- (tuple_lid, args, []), lid; + best_hint <- (tuple_lid, args, []), lid, flags; ignore (self#visit_node false (tuple_lid, args, [])); Hashtbl.add seen_declarations lid (); self#clear () - | DType (lid, _, 0, 0, Abbrev ((TApp _ | TCgApp _) as t)) when not (Hashtbl.mem state (flatten_tapp t)) -> + | DType (lid, flags, 0, 0, Abbrev ((TApp _ | TCgApp _) as t)) when not (Hashtbl.mem state (flatten_tapp t)) -> (* We have not yet monomorphized this type, and conveniently, we have a type abbreviation that provides us with a name hint! We simply ditch the type abbreviation and replace it with a monomorphization @@ -478,9 +479,9 @@ let monomorphize_data_types map = object(self) let abbrev_for_gc_type = Hashtbl.mem map hd && List.mem Common.GcType (fst (Hashtbl.find map hd)) in if abbrev_for_gc_type then - best_hint <- (hd, args, cgs), (fst lid, snd lid ^ "_gc") + best_hint <- (hd, args, cgs), (fst lid, snd lid ^ "_gc"), flags else - best_hint <- (hd, args, cgs), lid; + best_hint <- (hd, args, cgs), lid, flags; ignore (self#visit_node false (hd, args, cgs));