From f04e889173e8cc2fd52fd40f4d515ac161c1e4ce Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Mon, 27 May 2024 11:26:14 +0200 Subject: [PATCH] Pass the "external module" info along passes --- compiler/desugared/ast.ml | 2 +- compiler/desugared/ast.mli | 2 +- compiler/desugared/from_surface.ml | 26 ++++++++++------- compiler/desugared/name_resolution.ml | 14 +++++++-- compiler/desugared/name_resolution.mli | 1 + compiler/driver.ml | 10 +++---- compiler/lcalc/to_ocaml.ml | 9 +++--- compiler/scalc/ast.ml | 2 +- compiler/scalc/from_lcalc.ml | 2 +- compiler/scopelang/ast.ml | 2 +- compiler/scopelang/ast.mli | 2 +- compiler/shared_ast/definitions.ml | 9 ++++-- compiler/shared_ast/interpreter.ml | 18 ++++++------ compiler/shared_ast/program.ml | 8 +++--- compiler/shared_ast/program.mli | 6 ++-- compiler/surface/ast.ml | 6 ++-- compiler/surface/parser_driver.ml | 39 +++++++++++++++----------- 17 files changed, 94 insertions(+), 64 deletions(-) diff --git a/compiler/desugared/ast.ml b/compiler/desugared/ast.ml index 80bc4638..19ded35b 100644 --- a/compiler/desugared/ast.ml +++ b/compiler/desugared/ast.ml @@ -261,7 +261,7 @@ type modul = { } type program = { - program_module_name : (ModuleName.t * Hash.t) option; + program_module_name : (ModuleName.t * module_intf_id) option; program_ctx : decl_ctx; program_modules : modul ModuleName.Map.t; program_root : modul; diff --git a/compiler/desugared/ast.mli b/compiler/desugared/ast.mli index 9e23793b..88f263b2 100644 --- a/compiler/desugared/ast.mli +++ b/compiler/desugared/ast.mli @@ -139,7 +139,7 @@ type modul = { } type program = { - program_module_name : (ModuleName.t * Hash.t) option; + program_module_name : (ModuleName.t * module_intf_id) option; program_ctx : decl_ctx; program_modules : modul ModuleName.Map.t; (** Contains all submodules of the program, in a flattened structure *) diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index a6af6fee..01d4ff47 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -1742,12 +1742,14 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : Ident.Map.fold (fun _ m acc -> let mctx = ModuleName.Map.find m ctxt.Name_resolution.modules in - let sub = aux mctx in - let mhash = snd (ModuleName.Map.find m program_modules) in - ModuleName.Map.add m (mhash, sub) acc) + let deps = aux mctx in + let hash = snd (ModuleName.Map.find m program_modules) in + ModuleName.Map.add m + { deps; intf_id = { hash; is_external = mctx.is_external } } + acc) mctx.used_modules ModuleName.Map.empty in - M subs + subs in aux ctxt.local in @@ -1772,12 +1774,12 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : } in let program_module_name = - surface.Surface.Ast.program_module_name + surface.Surface.Ast.program_module |> Option.map - @@ fun id -> - let mname = ModuleName.fresh id in + @@ fun { Surface.Ast.module_name; module_external } -> + let mname = ModuleName.fresh module_name in let hash_placeholder = Hash.raw 0 in - mname, hash_placeholder + mname, { hash = hash_placeholder; is_external = module_external } in let desugared = { @@ -1816,6 +1818,10 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) : Ast.program_module_name = (desugared.Ast.program_module_name |> Option.map - @@ fun (mname, _) -> - mname, Ast.Hash.module_binding mname desugared.Ast.program_root); + @@ fun (mname, intf_id) -> + ( mname, + { + intf_id with + hash = Ast.Hash.module_binding mname desugared.Ast.program_root; + } )); } diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index f778f4e6..0352aafc 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -78,6 +78,7 @@ type module_context = { between different enums *) topdefs : TopdefName.t Ident.Map.t; (** Global definitions *) used_modules : ModuleName.t Ident.Map.t; + is_external : bool; } (** Context for name resolution, valid within a given module *) @@ -770,8 +771,10 @@ let rec process_law_structure process_code_block (process_item ~visibility:(if is_meta then Public else Private)) ctxt block + | Surface.Ast.ModuleDef (_, is_external) -> + { ctxt with local = { ctxt.local with is_external } } | Surface.Ast.LawInclude _ | Surface.Ast.LawText _ -> ctxt - | Surface.Ast.ModuleDef _ | Surface.Ast.ModuleUse _ -> ctxt + | Surface.Ast.ModuleUse _ -> ctxt (** {1 Scope uses pass} *) @@ -979,6 +982,7 @@ let empty_module_ctxt = constructor_idmap = Ident.Map.empty; topdefs = Ident.Map.empty; used_modules = Ident.Map.empty; + is_external = false; } let empty_ctxt = @@ -1007,7 +1011,13 @@ let form_context (surface, mod_uses) surface_modules : context = let ctxt = { ctxt with - local = { ctxt.local with used_modules = mod_uses; path = [m] }; + local = + { + ctxt.local with + used_modules = mod_uses; + path = [m]; + is_external = intf.Surface.Ast.intf_modname.module_external; + }; } in let ctxt = diff --git a/compiler/desugared/name_resolution.mli b/compiler/desugared/name_resolution.mli index 918c9133..99356bd1 100644 --- a/compiler/desugared/name_resolution.mli +++ b/compiler/desugared/name_resolution.mli @@ -83,6 +83,7 @@ type module_context = { topdefs : TopdefName.t Ident.Map.t; (** Global definitions *) used_modules : ModuleName.t Ident.Map.t; (** Module aliases and the modules they point to *) + is_external : bool; } (** Context for name resolution, valid within a given module *) diff --git a/compiler/driver.ml b/compiler/driver.ml index 335d46e7..6e0cd14a 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -93,7 +93,7 @@ let load_module_interfaces Surface.Parser_driver.load_interface ?default_module_name (Global.FileName f) in - let modname = ModuleName.fresh intf.intf_modname in + let modname = ModuleName.fresh intf.intf_modname.module_name in let seen = File.Map.add f None seen in let seen, sub_use_map = aux @@ -107,9 +107,9 @@ let load_module_interfaces (seen, Ident.Map.empty) uses in let seen = - match program.Surface.Ast.program_module_name with + match program.Surface.Ast.program_module with | Some m -> - let file = Pos.get_file (Mark.get m) in + let file = Pos.get_file (Mark.get m.module_name) in File.Map.singleton file None | None -> File.Map.empty in @@ -1022,7 +1022,7 @@ module Commands = struct let prg = Surface.Ast. { - program_module_name = None; + program_module = None; program_items = []; program_source_files = []; program_used_modules = @@ -1050,7 +1050,7 @@ module Commands = struct in Format.open_hbox (); Format.pp_print_list ~pp_sep:Format.pp_print_space - (fun ppf (m, _h) -> + (fun ppf (m, _) -> let f = Pos.get_file (Mark.get (ModuleName.get_info m)) in let f = match prefix with diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 1e3431a8..2535dde0 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -718,14 +718,15 @@ let commands = if commands = [] then entry_scopes else commands let check_and_reexport_used_modules fmt ~hashf modules = List.iter - (fun (m, hash) -> + (fun (m, intf_id) -> Format.fprintf fmt "@[let () =@ @[match Runtime_ocaml.Runtime.check_module \ %S \"%a\"@ with@]@,\ | Ok () -> ()@,\ @[| Error h -> failwith \"Hash mismatch for module %a, it may \ need recompiling\"@]@]@," - (ModuleName.to_string m) Hash.format (hashf hash) ModuleName.format m; + (ModuleName.to_string m) Hash.format (hashf intf_id.hash) + ModuleName.format m; Format.fprintf fmt "@[module %a@ = %a@]@," ModuleName.format m ModuleName.format m) modules @@ -788,8 +789,8 @@ let format_program Format.pp_print_cut fmt (); let () = match p.module_name, exec_scope with - | Some (modname, hash), None -> - format_module_registration fmt bnd modname (hashf hash) + | Some (modname, intf_id), None -> + format_module_registration fmt bnd modname (hashf intf_id.hash) | None, Some scope_name -> let scope_body = Program.get_scope_body p scope_name in format_scope_exec p.decl_ctx fmt bnd scope_name scope_body diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index cf27db91..48c2b2da 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -121,5 +121,5 @@ type ctx = { decl_ctx : decl_ctx; modules : VarName.t ModuleName.Map.t } type program = { ctx : ctx; code_items : code_item list; - module_name : (ModuleName.t * Hash.t) option; + module_name : (ModuleName.t * module_intf_id) option; } diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 507802b9..ca4933eb 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -659,7 +659,7 @@ let translate_program ~(config : translation_config) (p : 'm L.program) : A.program = let modules = List.fold_left - (fun acc (m, _hash) -> + (fun acc (m, _) -> let vname = Mark.map (( ^ ) "Module_") (ModuleName.get_info m) in (* The "Module_" prefix is a workaround name clashes for same-name structs and modules, Python in particular mixes everything in one diff --git a/compiler/scopelang/ast.ml b/compiler/scopelang/ast.ml index ff59f580..07a0f6df 100644 --- a/compiler/scopelang/ast.ml +++ b/compiler/scopelang/ast.ml @@ -67,7 +67,7 @@ type 'm scope_decl = { } type 'm program = { - program_module_name : (ModuleName.t * Hash.t) option; + program_module_name : (ModuleName.t * module_intf_id) option; program_ctx : decl_ctx; program_modules : nil scope_decl Mark.pos ScopeName.Map.t ModuleName.Map.t; program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t; diff --git a/compiler/scopelang/ast.mli b/compiler/scopelang/ast.mli index 4f611369..d44f6ef0 100644 --- a/compiler/scopelang/ast.mli +++ b/compiler/scopelang/ast.mli @@ -63,7 +63,7 @@ type 'm scope_decl = { } type 'm program = { - program_module_name : (ModuleName.t * Hash.t) option; + program_module_name : (ModuleName.t * module_intf_id) option; program_ctx : decl_ctx; program_modules : nil scope_decl Mark.pos ScopeName.Map.t ModuleName.Map.t; (* Using [nil] here ensure that program interfaces don't contain any diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 8596a05b..56dd2065 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -668,9 +668,12 @@ type scope_info = { out_struct_fields : StructField.t ScopeVar.Map.t; } +type module_intf_id = { hash : Hash.t; is_external : bool } + +type module_tree_node = { deps : module_tree; intf_id : module_intf_id } + +and module_tree = module_tree_node ModuleName.Map.t (** In practice, this is a DAG: beware of repeated names *) -type module_tree = M of (Hash.t * module_tree) ModuleName.Map.t -[@@caml.unboxed] type visibility = Private | Public @@ -691,5 +694,5 @@ type 'e program = { decl_ctx : decl_ctx; code_items : 'e code_item_list; lang : Global.backend_lang; - module_name : (ModuleName.t * Hash.t) option; + module_name : (ModuleName.t * module_intf_id) option; } diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 634009db..4b4d328d 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -1156,16 +1156,16 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list let evaluate_expr ctx lang e = evaluate_expr ctx lang (addcustom e) let load_runtime_modules ~hashf prg = - let load (m, mod_hash) = - let hash = hashf mod_hash in + let load (mname, intf_id) = + let hash = hashf intf_id.hash in let obj_file = Dynlink.adapt_filename - File.(Pos.get_file (Mark.get (ModuleName.get_info m)) -.- "cmo") + File.(Pos.get_file (Mark.get (ModuleName.get_info mname)) -.- "cmo") in (if not (Sys.file_exists obj_file) then Message.error ~pos_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here") - ~pos:(Mark.get (ModuleName.get_info m)) + ~pos:(Mark.get (ModuleName.get_info mname)) "Compiled OCaml object %a@ not@ found.@ Make sure it has been \ suitably compiled." File.format obj_file @@ -1177,13 +1177,13 @@ let load_runtime_modules ~hashf prg = File.format obj_file Format.pp_print_text (Dynlink.error_message dl_err)); match - Runtime.check_module (ModuleName.to_string m) (Hash.to_string hash) + Runtime.check_module (ModuleName.to_string mname) (Hash.to_string hash) with | Ok () -> () | Error bad_hash -> Message.debug "Module hash mismatch for %a:@ @[Expected: %a@,Found: %a@]" - ModuleName.format m Hash.format hash + ModuleName.format mname Hash.format hash (fun ppf h -> try Hash.format ppf (Hash.of_string h) with Failure _ -> Format.pp_print_string ppf "") @@ -1191,16 +1191,16 @@ let load_runtime_modules ~hashf prg = Message.error "Module %a@ needs@ recompiling:@ %a@ was@ likely@ compiled@ from@ an@ \ older@ version@ or@ with@ incompatible@ flags." - ModuleName.format m File.format obj_file + ModuleName.format mname File.format obj_file | exception Not_found -> Message.error "Module %a@ was loaded from file %a but did not register properly, \ there is something wrong in its code." - ModuleName.format m File.format obj_file + ModuleName.format mname File.format obj_file in let modules_list_topo = Program.modules_to_list prg.decl_ctx.ctx_modules in if modules_list_topo <> [] then Message.debug "Loading shared modules... %a" (Format.pp_print_list ~pp_sep:Format.pp_print_space ModuleName.format) - (List.map fst modules_list_topo); + (List.map (fun (m, _) -> m) modules_list_topo); List.iter load modules_list_topo diff --git a/compiler/shared_ast/program.ml b/compiler/shared_ast/program.ml index f3284336..753a1c74 100644 --- a/compiler/shared_ast/program.ml +++ b/compiler/shared_ast/program.ml @@ -58,7 +58,7 @@ let empty_ctx = ctx_struct_fields = Ident.Map.empty; ctx_enum_constrs = Ident.Map.empty; ctx_scope_index = Ident.Map.empty; - ctx_modules = M ModuleName.Map.empty; + ctx_modules = ModuleName.Map.empty; } let get_scope_body { code_items; _ } scope = @@ -87,11 +87,11 @@ let to_expr p main_scope = res let modules_to_list (mt : module_tree) = - let rec aux acc (M mtree) = + let rec aux acc mtree = ModuleName.Map.fold - (fun mname (subhash, sub) acc -> + (fun mname mnode acc -> if List.exists (fun (m, _) -> ModuleName.equal m mname) acc then acc - else (mname, subhash) :: aux acc sub) + else (mname, mnode.intf_id) :: aux acc mnode.deps) mtree acc in List.rev (aux [] mt) diff --git a/compiler/shared_ast/program.mli b/compiler/shared_ast/program.mli index 6b4b2e38..071b7873 100644 --- a/compiler/shared_ast/program.mli +++ b/compiler/shared_ast/program.mli @@ -15,7 +15,6 @@ License for the specific language governing permissions and limitations under the License. *) -open Catala_utils open Definitions (** {2 Program declaration context helpers} *) @@ -54,5 +53,6 @@ val to_expr : ((_ any, _) gexpr as 'e) program -> ScopeName.t -> 'e boxed val find_scope : ScopeName.t -> 'e code_item_list -> 'e scope_body -val modules_to_list : module_tree -> (ModuleName.t * Hash.t) list -(** Returns a list of used modules, in topological order *) +val modules_to_list : module_tree -> (ModuleName.t * module_intf_id) list +(** Returns a list of used modules, in topological order ; the boolean indicates + if the module is external *) diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index 60f962ff..9a37fde1 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -318,7 +318,7 @@ and law_structure = | CodeBlock of code_block * source_repr * bool (* Metadata if true *) and interface = { - intf_modname : uident Mark.pos; + intf_modname : program_module; intf_code : code_block; (** Invariant: an interface shall only contain [*Decl] elements, or [Topdef] elements with [topdef_expr = None] *) @@ -330,8 +330,10 @@ and module_use = { mod_use_alias : uident Mark.pos; } +and program_module = { module_name : uident Mark.pos; module_external : bool } + and program = { - program_module_name : uident Mark.pos option; + program_module : program_module option; program_items : law_structure list; program_source_files : (string[@opaque]) list; program_used_modules : module_use list; diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index b1474823..672749d3 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -259,18 +259,21 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : List.fold_left (fun acc command -> let join_module_names name_opt = - match acc.Ast.program_module_name, name_opt with + match acc.Ast.program_module, name_opt with | opt, None | None, opt -> opt | Some id1, Some id2 -> Message.error - ~extra_pos:["", Mark.get id1; "", Mark.get id2] + ~extra_pos: + ["", Mark.get id1.module_name; "", Mark.get id2.module_name] "Multiple definitions of the module name" in match command with - | Ast.ModuleDef (id, _) -> + | Ast.ModuleDef (id, is_external) -> { acc with - Ast.program_module_name = join_module_names (Some id); + Ast.program_module = + join_module_names + (Some { module_name = id; module_external = is_external }); Ast.program_items = command :: acc.Ast.program_items; } | Ast.ModuleUse (mod_use_name, alias) -> @@ -288,22 +291,22 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : @@ fun lexbuf -> let includ_program = parse_source lexbuf in let () = - includ_program.Ast.program_module_name + includ_program.Ast.program_module |> Option.iter @@ fun id -> Message.error ~extra_pos: [ "File include", Mark.get inc_file; - "Module declaration", Mark.get id; + "Module declaration", Mark.get id.Ast.module_name; ] "A file that declares a module cannot be used through the raw \ '@{> Include@}'@ directive.@ You should use it as a \ module with@ '@{> Use @{%s@}@}'@ instead." - (Mark.remove id) + (Mark.remove id.Ast.module_name) in { - Ast.program_module_name = acc.program_module_name; + Ast.program_module = acc.program_module; Ast.program_source_files = List.rev_append includ_program.program_source_files acc.Ast.program_source_files; @@ -316,7 +319,7 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : } | Ast.LawHeading (heading, commands') -> let { - Ast.program_module_name; + Ast.program_module; Ast.program_items = commands'; Ast.program_source_files = new_sources; Ast.program_used_modules = new_used_modules; @@ -325,7 +328,7 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : expand_includes source_file commands' in { - Ast.program_module_name = join_module_names program_module_name; + Ast.program_module = join_module_names program_module; Ast.program_source_files = List.rev_append new_sources acc.Ast.program_source_files; Ast.program_items = @@ -336,7 +339,7 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : } | i -> { acc with Ast.program_items = i :: acc.Ast.program_items }) { - Ast.program_module_name = None; + Ast.program_module = None; Ast.program_source_files = []; Ast.program_items = []; Ast.program_used_modules = []; @@ -346,7 +349,7 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : in { Ast.program_lang = language; - Ast.program_module_name = rprg.Ast.program_module_name; + Ast.program_module = rprg.Ast.program_module; Ast.program_source_files = List.rev rprg.Ast.program_source_files; Ast.program_items = List.rev rprg.Ast.program_items; Ast.program_used_modules = List.rev rprg.Ast.program_used_modules; @@ -396,8 +399,8 @@ let with_sedlex_source source_file f = f lexbuf let check_modname program source_file = - match program.Ast.program_module_name, source_file with - | ( Some (mname, pos), + match program.Ast.program_module, source_file with + | ( Some { module_name = mname, pos; _ }, (Global.FileName file | Global.Contents (_, file) | Global.Stdin file) ) when not File.(equal mname Filename.(remove_extension (basename file))) -> Message.error ~pos @@ -413,10 +416,14 @@ let load_interface ?default_module_name source_file = let program = with_sedlex_source source_file parse_source in check_modname program source_file; let modname = - match program.Ast.program_module_name, default_module_name with + match program.Ast.program_module, default_module_name with | Some mname, _ -> mname | None, Some n -> - n, Pos.from_info (Global.input_src_file source_file) 0 0 0 0 + { + module_name = + n, Pos.from_info (Global.input_src_file source_file) 0 0 0 0; + module_external = false; + } | None, None -> Message.error "%a doesn't define a module name. It should contain a '@{> \