CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +03:00
Code Issues Projects Releases Wiki Activity

Pass the "external module" info along passes

Browse Source
This commit is contained in:
Louis Gesbert 2024-05-27 11:26:14 +02:00
parent 709b51beb6
commit f04e889173
17 changed files with 94 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/desugared/ast.ml
View File

@ -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;

2
compiler/desugared/ast.mli
View File

@ -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 *)

26
compiler/desugared/from_surface.ml
View File

@ -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;
} ));
}

14
compiler/desugared/name_resolution.ml
View File

@ -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 =

1
compiler/desugared/name_resolution.mli
View File

@ -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 *)

10
compiler/driver.ml
View File

@ -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

9
compiler/lcalc/to_ocaml.ml
View File

@ -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
"@[<hv 2>let () =@ @[<hov 2>match Runtime_ocaml.Runtime.check_module \
%S \"%a\"@ with@]@,\
| Ok () -> ()@,\
@[<hv 2>| 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 "@[<hv 2>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

2
compiler/scalc/ast.ml
View File

@ -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;
}

2
compiler/scalc/from_lcalc.ml
View File

@ -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

2
compiler/scopelang/ast.ml
View File

@ -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;

2
compiler/scopelang/ast.mli
View File

@ -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

9
compiler/shared_ast/definitions.ml
View File

@ -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;
}

18
compiler/shared_ast/interpreter.ml
View File

@ -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:@ @[<v>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 "<invalid>")
@ -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

8
compiler/shared_ast/program.ml
View File

@ -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)

6
compiler/shared_ast/program.mli
View File

@ -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 *)

6
compiler/surface/ast.ml
View File

@ -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;

39
compiler/surface/parser_driver.ml
View File

@ -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 \
'@{<yellow>> Include@}'@ directive.@ You should use it as a \
module with@ '@{<yellow>> Use @{<blue>%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 '@{<cyan>> \