summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/translobj.ml7
-rw-r--r--driver/compenv.ml1
-rw-r--r--driver/main.ml1
-rw-r--r--driver/main_args.ml12
-rw-r--r--driver/main_args.mli4
-rw-r--r--driver/optmain.ml1
-rw-r--r--tools/ocamlcp.ml1
-rw-r--r--tools/ocamloptp.ml1
-rw-r--r--toplevel/topmain.ml1
-rw-r--r--typing/env.ml18
-rw-r--r--typing/env.mli6
-rw-r--r--typing/typemod.ml8
-rw-r--r--utils/clflags.ml1
-rw-r--r--utils/clflags.mli1
14 files changed, 58 insertions, 5 deletions
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index c6a958cfc..7f0d8577e 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -93,12 +93,19 @@ let prim_makearray =
{ prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true;
prim_native_name = ""; prim_native_float = false }
+(* Also use it for required globals *)
let transl_label_init expr =
let expr =
Hashtbl.fold
(fun c id expr -> Llet(Alias, id, Lconst c, expr))
consts expr
in
+ let expr =
+ List.fold_right
+ (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
+ (Env.get_required_globals ()) expr
+ in
+ Env.reset_required_globals ();
reset_labels ();
expr
diff --git a/driver/compenv.ml b/driver/compenv.ml
index 5990a6564..619670764 100644
--- a/driver/compenv.ml
+++ b/driver/compenv.ml
@@ -167,6 +167,7 @@ let read_OCAMLPARAM ppf position =
| "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
| "nodynlink" -> clear "nodynlink" [ dlcode ] v
| "short-paths" -> clear "short-paths" [ real_paths ] v
+ | "trans-mod" -> set "trans-mod" [ transparent_modules ] v
| "pp" -> preprocessor := Some v
| "runtime-variant" -> runtime_variant := v
diff --git a/driver/main.ml b/driver/main.ml
index 2d5bb394f..cbb645999 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -112,6 +112,7 @@ module Options = Main_args.Make_bytecomp_options (struct
let _short_paths = unset real_paths
let _strict_sequence = set strict_sequence
let _thread = set use_threads
+ let _trans_mod = set transparent_modules
let _vmthread = set use_vmthreads
let _unsafe = set fast
let _use_prims s = use_prims := s
diff --git a/driver/main_args.ml b/driver/main_args.ml
index d21ec6652..aba306b54 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -265,6 +265,10 @@ let mk_thread f =
" Generate code that supports the system threads library"
;;
+let mk_trans_mod f =
+ "-trans-mod", Arg.Unit f,
+ " Make typing and linking only depend on normalized paths"
+
let mk_unsafe f =
"-unsafe", Arg.Unit f,
" Do not compile bounds checking on array and string access"
@@ -465,6 +469,7 @@ module type Bytecomp_options = sig
val _runtime_variant : string -> unit
val _short_paths : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _thread : unit -> unit
val _vmthread : unit -> unit
val _unsafe : unit -> unit
@@ -508,6 +513,7 @@ module type Bytetop_options = sig
val _short_paths : unit -> unit
val _stdin: unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _unsafe : unit -> unit
val _version : unit -> unit
val _vnum : unit -> unit
@@ -566,6 +572,7 @@ module type Optcomp_options = sig
val _shared : unit -> unit
val _short_paths : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _thread : unit -> unit
val _unsafe : unit -> unit
val _v : unit -> unit
@@ -622,6 +629,7 @@ module type Opttop_options = sig
val _short_paths : unit -> unit
val _stdin : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _unsafe : unit -> unit
val _version : unit -> unit
val _vnum : unit -> unit
@@ -702,6 +710,7 @@ struct
mk_runtime_variant F._runtime_variant;
mk_short_paths F._short_paths;
mk_strict_sequence F._strict_sequence;
+ mk_trans_mod F._trans_mod;
mk_thread F._thread;
mk_unsafe F._unsafe;
mk_use_runtime F._use_runtime;
@@ -749,6 +758,7 @@ struct
mk_short_paths F._short_paths;
mk_stdin F._stdin;
mk_strict_sequence F._strict_sequence;
+ mk_trans_mod F._trans_mod;
mk_unsafe F._unsafe;
mk_version F._version;
mk_vnum F._vnum;
@@ -811,6 +821,7 @@ struct
mk_shared F._shared;
mk_short_paths F._short_paths;
mk_strict_sequence F._strict_sequence;
+ mk_trans_mod F._trans_mod;
mk_thread F._thread;
mk_unsafe F._unsafe;
mk_v F._v;
@@ -869,6 +880,7 @@ module Make_opttop_options (F : Opttop_options) = struct
mk_short_paths F._short_paths;
mk_stdin F._stdin;
mk_strict_sequence F._strict_sequence;
+ mk_trans_mod F._trans_mod;
mk_unsafe F._unsafe;
mk_version F._version;
mk_vnum F._vnum;
diff --git a/driver/main_args.mli b/driver/main_args.mli
index 9372d85de..67a6c681d 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -50,6 +50,7 @@ module type Bytecomp_options =
val _runtime_variant : string -> unit
val _short_paths : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _thread : unit -> unit
val _vmthread : unit -> unit
val _unsafe : unit -> unit
@@ -94,6 +95,7 @@ module type Bytetop_options = sig
val _short_paths : unit -> unit
val _stdin : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _unsafe : unit -> unit
val _version : unit -> unit
val _vnum : unit -> unit
@@ -152,6 +154,7 @@ module type Optcomp_options = sig
val _shared : unit -> unit
val _short_paths : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _thread : unit -> unit
val _unsafe : unit -> unit
val _v : unit -> unit
@@ -208,6 +211,7 @@ module type Opttop_options = sig
val _short_paths : unit -> unit
val _stdin : unit -> unit
val _strict_sequence : unit -> unit
+ val _trans_mod : unit -> unit
val _unsafe : unit -> unit
val _version : unit -> unit
val _vnum : unit -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 84e07183b..d04ad76b1 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -110,6 +110,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _runtime_variant s = runtime_variant := s
let _short_paths = clear real_paths
let _strict_sequence = set strict_sequence
+ let _trans_mod = set transparent_modules
let _shared () = shared := true; dlcode := true
let _S = set keep_asm_file
let _thread = set use_threads
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 82b0174a8..bca5ae63c 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -79,6 +79,7 @@ module Options = Main_args.Make_bytecomp_options (struct
let _runtime_variant s = option_with_arg "-runtime-variant" s
let _short_paths = option "-short-paths"
let _strict_sequence = option "-strict-sequence"
+ let _trans_mod = option "-trans-mod"
let _thread () = option "-thread" ()
let _vmthread () = option "-vmthread" ()
let _unsafe = option "-unsafe"
diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 23a439a11..6d730f2c3 100644
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -84,6 +84,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _strict_sequence = option "-strict-sequence"
let _shared = option "-shared"
let _thread = option "-thread"
+ let _trans_mod = option "-trans-mod"
let _unsafe = option "-unsafe"
let _v = option "-v"
let _version = option "-version"
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 3091ca0d2..0f3ac66f9 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -79,6 +79,7 @@ module Options = Main_args.Make_bytetop_options (struct
let _short_paths = clear real_paths
let _stdin () = file_argument ""
let _strict_sequence = set strict_sequence
+ let _trans_mod = set transparent_modules
let _unsafe = set fast
let _version () = print_version ()
let _vnum () = print_version_num ()
diff --git a/typing/env.ml b/typing/env.ml
index e7d15ca13..9e7791168 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -329,7 +329,7 @@ let read_pers_struct modname filename =
ps_flags = flags } in
if ps.ps_name <> modname then
error (Illegal_renaming(modname, ps.ps_name, filename));
- (*check_consistency filename ps.ps_crcs;*)
+ if not !Clflags.transparent_modules then check_consistency ps;
List.iter
(function Rectypes ->
if not !Clflags.recursive_types then
@@ -486,6 +486,14 @@ let find_module path env =
raise Not_found
end
+let required_globals = ref []
+let reset_required_globals () = required_globals := []
+let get_required_globals () = !required_globals
+let add_required_global id =
+ if Ident.global id && not !Clflags.transparent_modules
+ && not (List.exists (Ident.same id) !required_globals)
+ then required_globals := id :: !required_globals
+
let rec normalize_path lax env path =
let path =
match path with
@@ -496,7 +504,13 @@ let rec normalize_path lax env path =
| _ -> path
in
try match find_module path env with
- {md_type=Mty_alias path} -> normalize_path lax env path
+ {md_type=Mty_alias path1} ->
+ let path' = normalize_path lax env path1 in
+ if lax || !Clflags.transparent_modules then path' else
+ let id = Path.head path in
+ if Ident.global id && not (Ident.same id (Path.head path'))
+ then add_required_global id;
+ path'
| _ -> path
with Not_found when lax
|| (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
diff --git a/typing/env.mli b/typing/env.mli
index 5abf11a44..888869ebf 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -64,7 +64,11 @@ val is_functor_arg: Path.t -> t -> bool
val normalize_path: Location.t option -> t -> Path.t -> Path.t
(* Normalize the path to a concrete value or module.
If the option is None, allow returning dangling paths.
- Otherwise raise a Missing_module error. *)
+ Otherwise raise a Missing_module error, and may add forgotten
+ head as required global. *)
+val reset_required_globals: unit -> unit
+val get_required_globals: unit -> Ident.t list
+val add_required_global: Ident.t -> unit
val has_local_constraints: t -> bool
val add_gadt_instance_level: int -> t -> t
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 600be4a1a..a7749d7a0 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -961,8 +961,9 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc } in
let md =
- if alias && not (Env.is_functor_arg path env) then md else
- match (Env.find_module path env).md_type with
+ if alias && not (Env.is_functor_arg path env) then
+ (Env.add_required_global (Path.head path); md)
+ else match (Env.find_module path env).md_type with
Mty_alias p1 when not alias ->
let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
let mty = Includemod.expand_module_alias env [] p1 in
@@ -1250,6 +1251,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let sg =
match modl.mod_desc with
Tmod_ident (p, _) when not (Env.is_functor_arg p env) ->
+ Env.add_required_global (Path.head p);
let pos = ref 0 in
List.map
(function
@@ -1301,6 +1303,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
str, sg, final_env
let type_toplevel_phrase env s =
+ Env.reset_required_globals ();
type_structure ~toplevel:true false None env s Location.none
(*let type_module_alias = type_module ~alias:true true false None*)
let type_module = type_module true false None
@@ -1441,6 +1444,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
Cmt_format.set_saved_types [];
try
Typecore.reset_delayed_checks ();
+ Env.reset_required_globals ();
let (str, sg, finalenv) =
type_structure initial_env ast (Location.in_file sourcefile) in
let simple_sg = simplify_signature sg in
diff --git a/utils/clflags.ml b/utils/clflags.ml
index b44b7491f..829393a00 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -58,6 +58,7 @@ and dllpaths = ref ([] : string list) (* -dllpath *)
and make_package = ref false (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
and error_size = ref 500 (* -error-size *)
+and transparent_modules = ref false (* -trans-mod *)
let dump_source = ref false (* -dsource *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_typedtree = ref false (* -dtypedtree *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index 038c3aacb..876776acd 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -55,6 +55,7 @@ val dllpaths : string list ref
val make_package : bool ref
val for_package : string option ref
val error_size : int ref
+val transparent_modules : bool ref
val dump_source : bool ref
val dump_parsetree : bool ref
val dump_typedtree : bool ref
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-23 00:14:41 +0000