diff options
| -rw-r--r-- | bytecomp/translobj.ml | 7 | ||||
| -rw-r--r-- | driver/compenv.ml | 1 | ||||
| -rw-r--r-- | driver/main.ml | 1 | ||||
| -rw-r--r-- | driver/main_args.ml | 12 | ||||
| -rw-r--r-- | driver/main_args.mli | 4 | ||||
| -rw-r--r-- | driver/optmain.ml | 1 | ||||
| -rw-r--r-- | tools/ocamlcp.ml | 1 | ||||
| -rw-r--r-- | tools/ocamloptp.ml | 1 | ||||
| -rw-r--r-- | toplevel/topmain.ml | 1 | ||||
| -rw-r--r-- | typing/env.ml | 18 | ||||
| -rw-r--r-- | typing/env.mli | 6 | ||||
| -rw-r--r-- | typing/typemod.ml | 8 | ||||
| -rw-r--r-- | utils/clflags.ml | 1 | ||||
| -rw-r--r-- | utils/clflags.mli | 1 |
14 files changed, 58 insertions, 5 deletions
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index c6a958cfc3..7f0d8577eb 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 5990a65647..6196707643 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 2d5bb394fd..cbb6459993 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 d21ec66521..aba306b54a 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 9372d85dea..67a6c681d2 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 84e07183bb..d04ad76b19 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 82b0174a87..bca5ae63c5 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 23a439a11b..6d730f2c3c 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 3091ca0d2a..0f3ac66f9d 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 e7d15ca13b..9e7791168c 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 5abf11a449..888869ebfc 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 600be4a1a9..a7749d7a09 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 b44b7491f3..829393a00d 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 038c3aacba..876776acdb 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 |