From a10790a4e22d5a3ce9d5726f32ec6aa5ca6a10d7 Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Mon, 5 Feb 2024 10:03:35 +0100 Subject: [PATCH] Typer cleanup continued (#11548) * remove @:enumConstructorParam * remove init_class_done see if this breaks anything * clone for expr * make ctx.pass immutable * ctx.e can be immutable too * add failing test to show everyone that it's broken * fix it * only need g for delays * lose server dependency on typer * evacuate some things from typecore.ml * small cleanup * add g.root_typer This gives us a nice context tree structure * remove more { ctx with and assert order * less mutability and cloning * even less cloning * fix allow_inline again --- src/compiler/displayProcessing.ml | 4 +- src/compiler/server.ml | 80 ++++---- src/context/display/displayEmitter.ml | 2 +- src/context/display/displayTexpr.ml | 6 +- src/context/display/importHandling.ml | 2 +- src/context/display/syntaxExplorer.ml | 2 +- src/context/typecore.ml | 261 +++++++------------------- src/core/naming.ml | 53 ++++++ src/typing/finalization.ml | 4 +- src/typing/functionArguments.ml | 6 +- src/typing/generic.ml | 19 +- src/typing/instanceBuilder.ml | 2 +- src/typing/macroContext.ml | 21 +-- src/typing/strictMeta.ml | 36 +++- src/typing/typeload.ml | 21 ++- src/typing/typeloadCacheHook.ml | 31 +++ src/typing/typeloadCheck.ml | 40 ++-- src/typing/typeloadFields.ml | 78 ++++---- src/typing/typeloadFunction.ml | 18 +- src/typing/typeloadModule.ml | 101 +++++----- src/typing/typeloadParse.ml | 8 +- src/typing/typer.ml | 6 +- src/typing/typerEntry.ml | 5 +- 23 files changed, 400 insertions(+), 406 deletions(-) create mode 100644 src/typing/typeloadCacheHook.ml diff --git a/src/compiler/displayProcessing.ml b/src/compiler/displayProcessing.ml index d2dde9cef58..7e345a0f8e6 100644 --- a/src/compiler/displayProcessing.ml +++ b/src/compiler/displayProcessing.ml @@ -239,7 +239,7 @@ let load_display_file_standalone (ctx : Typecore.typer) file = let dir = ExtString.String.join (if path.backslash then "\\" else "/") parts in com.class_paths#add (new ClassPath.directory_class_path dir User) end; - ignore(TypeloadModule.type_module ctx (pack,name) file ~dont_check_path:true decls null_pos) + ignore(TypeloadModule.type_module ctx.com ctx.g (pack,name) file ~dont_check_path:true decls null_pos) let load_display_content_standalone (ctx : Typecore.typer) input = let com = ctx.com in @@ -247,7 +247,7 @@ let load_display_content_standalone (ctx : Typecore.typer) input = let p = {pfile = file; pmin = 0; pmax = 0} in let parsed = TypeloadParse.parse_file_from_string com file p input in let pack,decls = TypeloadParse.handle_parser_result com p parsed in - ignore(TypeloadModule.type_module ctx (pack,"?DISPLAY") file ~dont_check_path:true decls p) + ignore(TypeloadModule.type_module ctx.com ctx.g (pack,"?DISPLAY") file ~dont_check_path:true decls p) (* 4. Display processing before typing *) diff --git a/src/compiler/server.ml b/src/compiler/server.ml index e664d8691a7..62629092446 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -3,13 +3,13 @@ open Common open CompilationCache open Timer open Type -open Typecore open DisplayProcessingGlobals open Ipaddr open Json open CompilationContext open MessageReporting open HxbData +open TypeloadCacheHook exception Dirty of module_skip_reason exception ServerError of string @@ -162,10 +162,9 @@ let stat dir = (Unix.stat (Path.remove_trailing_slash dir)).Unix.st_mtime (* Gets a list of changed directories for the current compilation. *) -let get_changed_directories sctx (ctx : Typecore.typer) = +let get_changed_directories sctx com = let t = Timer.timer ["server";"module cache";"changed dirs"] in let cs = sctx.cs in - let com = ctx.Typecore.com in let sign = Define.get_signature com.defines in let dirs = try (* First, check if we already have determined changed directories for current compilation. *) @@ -229,16 +228,15 @@ let get_changed_directories sctx (ctx : Typecore.typer) = (* Checks if module [m] can be reused from the cache and returns None in that case. Otherwise, returns [Some m'] where [m'] is the module responsible for [m] not being reusable. *) -let check_module sctx ctx m_path m_extra p = - let com = ctx.Typecore.com in +let check_module sctx com m_path m_extra p = let cc = CommonCache.get_cache com in let content_changed m_path file = - let fkey = ctx.com.file_keys#get file in + let fkey = com.file_keys#get file in try let cfile = cc#find_file fkey in (* We must use the module path here because the file path is absolute and would cause positions in the parsed declarations to differ. *) - let new_data = TypeloadParse.parse_module ctx m_path p in + let new_data = TypeloadParse.parse_module com m_path p in cfile.c_decls <> snd new_data with Not_found -> true @@ -259,7 +257,7 @@ let check_module sctx ctx m_path m_extra p = let unknown_state_modules = ref [] in let rec check m_path m_extra = let check_module_path () = - let directories = get_changed_directories sctx ctx in + let directories = get_changed_directories sctx com in match m_extra.m_kind with | MFake | MImport -> () (* don't get classpath *) | MExtern -> @@ -285,18 +283,12 @@ let check_module sctx ctx m_path m_extra p = | MMacro when com.is_macro_context -> check_module_shadowing directories m_path m_extra | MMacro -> - (* - Creating another context while the previous one is incomplete means we have an infinite loop in the compiler. - Most likely because of circular dependencies in base modules (e.g. `StdTypes` or `String`) - Prevents spending another 5 hours for debugging. - @see https://github.com/HaxeFoundation/haxe/issues/8174 - *) - if not ctx.g.complete && ctx.com.is_macro_context then - raise (ServerError ("Infinite loop in Haxe server detected. " - ^ "Probably caused by shadowing a module of the standard library. " - ^ "Make sure shadowed module does not pull macro context.")); - let mctx = MacroContext.get_macro_context ctx in - check_module_shadowing (get_changed_directories sctx mctx) m_path m_extra + begin match com.get_macros() with + | None -> + () + | Some mcom -> + check_module_shadowing (get_changed_directories sctx mcom) m_path m_extra + end in let has_policy policy = List.mem policy m_extra.m_check_policy || match policy with | NoCheckShadowing | NoCheckFileTimeModification when !ServerConfig.do_not_check_modules && !Parser.display_mode <> DMNone -> true @@ -309,7 +301,7 @@ let check_module sctx ctx m_path m_extra p = ServerMessage.unchanged_content com "" file; end else begin ServerMessage.not_cached com "" m_path; - if m_extra.m_kind = MFake then Hashtbl.remove Typecore.fake_modules (Path.UniqueKey.lazy_key m_extra.m_file); + if m_extra.m_kind = MFake then Hashtbl.remove fake_modules (Path.UniqueKey.lazy_key m_extra.m_file); raise (Dirty (FileChanged file)) end end @@ -395,7 +387,7 @@ let check_module sctx ctx m_path m_extra p = state class hxb_reader_api_server - (ctx : Typecore.typer) + (com : Common.context) (cc : context_cache) = object(self) @@ -410,7 +402,7 @@ class hxb_reader_api_server } method add_module (m : module_def) = - ctx.com.module_lut#add m.m_path m + com.module_lut#add m.m_path m method resolve_type (pack : string list) (mname : string) (tname : string) = let path = (pack,mname) in @@ -422,7 +414,7 @@ class hxb_reader_api_server | GoodModule m -> m | BinaryModule mc -> - let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in + let reader = new HxbReader.hxb_reader path com.hxb_reader_stats in let f_next chunks until = let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in let r = reader#read_chunks_until (self :> HxbReaderApi.hxb_reader_api) chunks until in @@ -434,7 +426,7 @@ class hxb_reader_api_server (* We try to avoid reading expressions as much as possible, so we only do this for our current display file if we're in display mode. *) let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in - if is_display_file || ctx.com.display.dms_full_typing then ignore(f_next chunks EOM); + if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM); m | BadModule reason -> die (Printf.sprintf "Unexpected BadModule %s" (s_type_path path)) __LOC__ @@ -443,7 +435,7 @@ class hxb_reader_api_server method find_module (m_path : path) = try - GoodModule (ctx.com.module_lut#find m_path) + GoodModule (com.module_lut#find m_path) with Not_found -> try let mc = cc#get_hxb_module m_path in begin match mc.mc_extra.m_cache_state with @@ -454,13 +446,13 @@ class hxb_reader_api_server NoModule method basic_types = - ctx.com.basic + com.basic method get_var_id (i : int) = i method read_expression_eagerly (cf : tclass_field) = - ctx.com.display.dms_full_typing + com.display.dms_full_typing end let handle_cache_bound_objects com cbol = @@ -475,12 +467,11 @@ let handle_cache_bound_objects com cbol = (* Adds module [m] and all its dependencies (recursively) from the cache to the current compilation context. *) -let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) = - let com = ctx.Typecore.com in +let rec add_modules sctx com (m : module_def) (from_binary : bool) (p : pos) = let own_sign = CommonCache.get_cache_sign com in let rec add_modules tabs m0 m = - if m.m_extra.m_added < ctx.com.compilation_step then begin - m.m_extra.m_added <- ctx.com.compilation_step; + if m.m_extra.m_added < com.compilation_step then begin + m.m_extra.m_added <- com.compilation_step; (match m0.m_extra.m_kind, m.m_extra.m_kind with | MCode, MMacro | MMacro, MCode -> (* this was just a dependency to check : do not add to the context *) @@ -501,7 +492,7 @@ let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) = let m2 = try com.module_lut#find mpath with Not_found -> - match type_module sctx ctx mpath p with + match type_module sctx com mpath p with | GoodModule m -> m | BinaryModule mc -> @@ -521,9 +512,8 @@ let rec add_modules sctx ctx (m : module_def) (from_binary : bool) (p : pos) = (* Looks up the module referred to by [mpath] in the cache. If it exists, a check is made to determine if it's still valid. If this function returns None, the module is re-typed. *) -and type_module sctx (ctx:Typecore.typer) mpath p = +and type_module sctx com mpath p = let t = Timer.timer ["server";"module cache"] in - let com = ctx.Typecore.com in let cc = CommonCache.get_cache com in let skip m_path reason = ServerMessage.skipping_dep com "" (m_path,(Printer.s_module_skip_reason reason)); @@ -531,17 +521,17 @@ and type_module sctx (ctx:Typecore.typer) mpath p = in let add_modules from_binary m = let tadd = Timer.timer ["server";"module cache";"add modules"] in - add_modules sctx ctx m from_binary p; + add_modules sctx com m from_binary p; tadd(); GoodModule m in - let check_module sctx ctx m_path m_extra p = + let check_module sctx m_path m_extra p = let tcheck = Timer.timer ["server";"module cache";"check"] in - let r = check_module sctx ctx mpath m_extra p in + let r = check_module sctx com mpath m_extra p in tcheck(); r in - let find_module_in_cache ctx cc m_path p = + let find_module_in_cache cc m_path p = try let m = cc#find_module m_path in begin match m.m_extra.m_cache_state with @@ -558,11 +548,11 @@ and type_module sctx (ctx:Typecore.typer) mpath p = NoModule in (* Should not raise anything! *) - let m = match find_module_in_cache ctx cc mpath p with + let m = match find_module_in_cache cc mpath p with | GoodModule m -> (* "Good" here is an assumption, it only means that the module wasn't explicitly invalidated in the cache. The true cache state will be known after check_module. *) - begin match check_module sctx ctx mpath m.m_extra p with + begin match check_module sctx mpath m.m_extra p with | None -> add_modules false m; | Some reason -> @@ -571,10 +561,10 @@ and type_module sctx (ctx:Typecore.typer) mpath p = | BinaryModule mc -> (* Similarly, we only know that a binary module wasn't explicitly tainted. Decode it only after checking dependencies. This means that the actual decoding never has any reason to fail. *) - begin match check_module sctx ctx mpath mc.mc_extra p with + begin match check_module sctx mpath mc.mc_extra p with | None -> let reader = new HxbReader.hxb_reader mpath com.hxb_reader_stats in - let api = (new hxb_reader_api_server ctx cc :> HxbReaderApi.hxb_reader_api) in + let api = (new hxb_reader_api_server com cc :> HxbReaderApi.hxb_reader_api) in let f_next chunks until = let t_hxb = Timer.timer ["server";"module cache";"hxb read"] in let r = reader#read_chunks_until api chunks until in @@ -585,7 +575,7 @@ and type_module sctx (ctx:Typecore.typer) mpath p = (* We try to avoid reading expressions as much as possible, so we only do this for our current display file if we're in display mode. *) let is_display_file = DisplayPosition.display_position#is_in_file (Path.UniqueKey.lazy_key m.m_extra.m_file) in - if is_display_file || ctx.com.display.dms_full_typing then ignore(f_next chunks EOM); + if is_display_file || com.display.dms_full_typing then ignore(f_next chunks EOM); add_modules true m; | Some reason -> skip mpath reason @@ -759,7 +749,7 @@ let do_connect ip port args = if !has_error then exit 1 let enable_cache_mode sctx = - TypeloadModule.type_module_hook := type_module sctx; + type_module_hook := type_module sctx; ServerCompilationContext.ensure_macro_setup sctx; TypeloadParse.parse_hook := parse_file sctx.cs diff --git a/src/context/display/displayEmitter.ml b/src/context/display/displayEmitter.ml index 58b50c7d25f..2b8e7d0fc1b 100644 --- a/src/context/display/displayEmitter.ml +++ b/src/context/display/displayEmitter.ml @@ -169,7 +169,7 @@ let check_display_metadata ctx meta = List.iter (fun e -> if display_position#enclosed_in (pos e) then begin let e = preprocess_expr ctx.com e in - delay ctx PTypeField (fun _ -> ignore(type_expr ctx e WithType.value)); + delay ctx.g PTypeField (fun _ -> ignore(type_expr ctx e WithType.value)); end ) args ) meta diff --git a/src/context/display/displayTexpr.ml b/src/context/display/displayTexpr.ml index 777ba93ef24..bdd8e72b7a4 100644 --- a/src/context/display/displayTexpr.ml +++ b/src/context/display/displayTexpr.ml @@ -63,7 +63,7 @@ let actually_check_display_field ctx c cff p = let display_modifier = Typeload.check_field_access ctx cff in let fctx = TypeloadFields.create_field_context ctx cctx cff true display_modifier in let cf = TypeloadFields.init_field (ctx,cctx,fctx) cff in - flush_pass ctx PTypeField ("check_display_field",(fst c.cl_path @ [snd c.cl_path;fst cff.cff_name])); + flush_pass ctx.g PTypeField ("check_display_field",(fst c.cl_path @ [snd c.cl_path;fst cff.cff_name])); ignore(follow cf.cf_type) let check_display_field ctx sc c cf = @@ -173,10 +173,10 @@ let check_display_file ctx cs = let m = try ctx.com.module_lut#find path with Not_found -> - begin match !TypeloadModule.type_module_hook ctx path null_pos with + begin match !TypeloadCacheHook.type_module_hook ctx.com path null_pos with | NoModule | BadModule _ -> raise Not_found | BinaryModule mc -> - let api = (new TypeloadModule.hxb_reader_api_typeload ctx TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in + let api = (new TypeloadModule.hxb_reader_api_typeload ctx.com ctx.g TypeloadModule.load_module' p :> HxbReaderApi.hxb_reader_api) in let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in let m = reader#read_chunks api mc.mc_chunks in m diff --git a/src/context/display/importHandling.ml b/src/context/display/importHandling.ml index 69a9e9f16c3..d0ac35235ff 100644 --- a/src/context/display/importHandling.ml +++ b/src/context/display/importHandling.ml @@ -296,4 +296,4 @@ let init_using ctx path p = ctx.m.import_resolution#add (module_type_resolution mt None p) ) (List.rev types); (* delay the using since we need to resolve typedefs *) - delay_late ctx PConnectField (fun () -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) + delay_late ctx.g PConnectField (fun () -> ctx.m.module_using <- filter_classes types @ ctx.m.module_using) diff --git a/src/context/display/syntaxExplorer.ml b/src/context/display/syntaxExplorer.ml index bc6c1328cc3..2a7b2bd4978 100644 --- a/src/context/display/syntaxExplorer.ml +++ b/src/context/display/syntaxExplorer.ml @@ -177,7 +177,7 @@ let explore_uncached_modules tctx cs symbols = begin try let m = tctx.g.do_load_module tctx (cfile.c_package,module_name) null_pos in (* We have to flush immediately so we catch exceptions from weird modules *) - Typecore.flush_pass tctx Typecore.PFinal ("final",cfile.c_package @ [module_name]); + Typecore.flush_pass tctx.g Typecore.PFinal ("final",cfile.c_package @ [module_name]); m :: acc with _ -> acc diff --git a/src/context/typecore.ml b/src/context/typecore.ml index b0db1b0ff73..a530d735fe5 100644 --- a/src/context/typecore.ml +++ b/src/context/typecore.ml @@ -125,6 +125,7 @@ type typer_globals = { mutable build_count : int; mutable t_dynamic_def : Type.t; mutable delayed_display : DisplayTypes.display_exception_kind option; + root_typer : typer; (* api *) do_macro : typer -> macro_mode -> path -> string -> expr list -> pos -> macro_result; do_load_macro : typer -> bool -> path -> string -> pos -> ((string * bool * t) list * t * tclass * Type.tclass_field); @@ -138,11 +139,11 @@ type typer_globals = { (* typer_expr holds information that is specific to a (function) expresssion, whereas typer_field is shared by local TFunctions. *) and typer_expr = { + curfun : current_fun; + in_function : bool; mutable ret : t; - mutable curfun : current_fun; mutable opened : anon_status ref list; mutable monomorphs : monomorphs; - mutable in_function : bool; mutable in_loop : bool; mutable bypass_accessor : int; mutable with_type_stack : WithType.t list; @@ -182,21 +183,33 @@ and monomorphs = { mutable perfunction : (tmono * pos) list; } +let pass_name = function + | PBuildModule -> "build-module" + | PBuildClass -> "build-class" + | PConnectField -> "connect-field" + | PTypeField -> "type-field" + | PCheckConstraint -> "check-constraint" + | PForce -> "force" + | PFinal -> "final" + module TyperManager = struct - let create com g m c f e pass params allow_inline allow_transform = { - com = com; - g = g; - t = com.basic; - m = m; - c = c; - f = f; - e = e; - pass = pass; - allow_inline; - allow_transform; - type_params = params; - memory_marker = memory_marker; - } + let create ctx m c f e pass params = + if pass < ctx.pass then die (Printf.sprintf "Bad context clone from %s(%s) to %s(%s)" (s_type_path ctx.m.curmod.m_path) (pass_name ctx.pass) (s_type_path m.curmod.m_path) (pass_name pass)) __LOC__; + let new_ctx = { + com = ctx.com; + g = ctx.g; + t = ctx.com.basic; + m = m; + c = c; + f = f; + e = e; + pass = pass; + allow_inline = ctx.allow_inline; + allow_transform = ctx.allow_transform; + type_params = params; + memory_marker = memory_marker; + } in + new_ctx let create_ctx_c c = { @@ -224,12 +237,12 @@ module TyperManager = struct in_call_args = false; } - let create_ctx_e () = + let create_ctx_e curfun in_function = { + curfun; + in_function; ret = t_dynamic; - curfun = FunStatic; opened = []; - in_function = false; monomorphs = { perfunction = []; }; @@ -240,50 +253,48 @@ module TyperManager = struct macro_depth = 0; } - let create_for_module com g m = - let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - let e = create_ctx_e () in - create com g m c f e PBuildModule [] true true + let clone_for_module ctx m = + let ctx = create ctx m ctx.c ctx.f ctx.e PBuildModule [] in + ctx.allow_transform <- true; + ctx.allow_inline <- true; + ctx let clone_for_class ctx c = let c = create_ctx_c c in - let f = create_ctx_f null_field in - let e = create_ctx_e () in let params = match c.curclass.cl_kind with KAbstractImpl a -> a.a_params | _ -> c.curclass.cl_params in - create ctx.com ctx.g ctx.m c f e PBuildClass params ctx.allow_inline ctx.allow_transform + create ctx ctx.m c ctx.f ctx.e PBuildClass params let clone_for_enum ctx en = let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx.com ctx.g ctx.m c f e PBuildModule en.e_params ctx.allow_inline ctx.allow_transform + create ctx ctx.m c ctx.f ctx.e PBuildClass en.e_params let clone_for_typedef ctx td = let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx.com ctx.g ctx.m c f e PBuildModule td.t_params ctx.allow_inline ctx.allow_transform + create ctx ctx.m c ctx.f ctx.e PBuildClass td.t_params let clone_for_abstract ctx a = let c = create_ctx_c null_class in - let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx.com ctx.g ctx.m c f e PBuildModule a.a_params ctx.allow_inline ctx.allow_transform + create ctx ctx.m c ctx.f ctx.e PBuildClass a.a_params let clone_for_field ctx cf params = let f = create_ctx_f cf in - let e = create_ctx_e () in - create ctx.com ctx.g ctx.m ctx.c f e PBuildClass params ctx.allow_inline ctx.allow_transform + create ctx ctx.m ctx.c f ctx.e PBuildClass params let clone_for_enum_field ctx params = let f = create_ctx_f null_field in - let e = create_ctx_e () in - create ctx.com ctx.g ctx.m ctx.c f e PBuildClass params ctx.allow_inline ctx.allow_transform + create ctx ctx.m ctx.c f ctx.e PBuildClass params + + let clone_for_expr ctx curfun in_function = + let e = create_ctx_e curfun in_function in + create ctx ctx.m ctx.c ctx.f e PTypeField ctx.type_params + + let clone_for_type_params ctx params = + create ctx ctx.m ctx.c ctx.f ctx.e ctx.pass params - let clone_for_expr ctx = - let e = create_ctx_e () in - create ctx.com ctx.g ctx.m ctx.c ctx.f e PTypeField ctx.type_params ctx.allow_inline ctx.allow_transform + let clone_for_type_parameter_expression ctx = + let f = create_ctx_f ctx.f.curfield in + let e = create_ctx_e ctx.e.curfun false in + create ctx ctx.m ctx.c f e PTypeField ctx.type_params end type field_host = @@ -323,13 +334,6 @@ type dot_path_part = { case : dot_path_part_case; pos : pos } - -type find_module_result = - | GoodModule of module_def - | BadModule of module_skip_reason - | BinaryModule of HxbData.module_cache - | NoModule - let make_build_info kind path params extern apply = { build_kind = kind; build_path = path; @@ -355,15 +359,6 @@ let type_generic_function_ref : (typer -> field_access -> (unit -> texpr) field_ let create_context_ref : (Common.context -> ((unit -> unit) * typer) option -> typer) ref = ref (fun _ -> assert false) -let pass_name = function - | PBuildModule -> "build-module" - | PBuildClass -> "build-class" - | PConnectField -> "connect-field" - | PTypeField -> "type-field" - | PCheckConstraint -> "check-constraint" - | PForce -> "force" - | PFinal -> "final" - let warning ?(depth=0) ctx w msg p = let options = (Warning.from_meta ctx.c.curclass.cl_meta) @ (Warning.from_meta ctx.f.curfield.cf_meta) in match Warning.get_mode w options with @@ -456,58 +451,8 @@ let add_local ctx k n t p = ctx.f.locals <- PMap.add n v ctx.f.locals; v -let display_identifier_error ctx ?prepend_msg msg p = - let prepend = match prepend_msg with Some s -> s ^ " " | _ -> "" in - display_error ctx.com (prepend ^ msg) p - -let check_identifier_name ?prepend_msg ctx name kind p = - if starts_with name '$' then - display_identifier_error ctx ?prepend_msg ((StringHelper.capitalize kind) ^ " names starting with a dollar are not allowed: \"" ^ name ^ "\"") p - else if not (Lexer.is_valid_identifier name) then - display_identifier_error ctx ?prepend_msg ("\"" ^ (StringHelper.s_escape name) ^ "\" is not a valid " ^ kind ^ " name.") p - -let check_field_name ctx name p = - match name with - | "new" -> () (* the only keyword allowed in field names *) - | _ -> check_identifier_name ctx name "field" p - -let check_uppercase_identifier_name ?prepend_msg ctx name kind p = - if String.length name = 0 then - display_identifier_error ?prepend_msg ctx ((StringHelper.capitalize kind) ^ " name must not be empty.") p - else if Ast.is_lower_ident name then - display_identifier_error ?prepend_msg ctx ((StringHelper.capitalize kind) ^ " name should start with an uppercase letter: \"" ^ name ^ "\"") p - else - check_identifier_name ?prepend_msg ctx name kind p - -let check_module_path ctx (pack,name) p = - let full_path = StringHelper.s_escape (if pack = [] then name else (String.concat "." pack) ^ "." ^ name) in - check_uppercase_identifier_name ~prepend_msg:("Module \"" ^ full_path ^ "\" does not have a valid name.") ctx name "module" p; - try - List.iter (fun part -> Path.check_package_name part) pack; - with Failure msg -> - display_error_ext ctx.com (make_error - ~sub:[make_error (Custom msg) p] - (Custom ("\"" ^ (StringHelper.s_escape (String.concat "." pack)) ^ "\" is not a valid package name:")) - p - ) - -let check_local_variable_name ctx name origin p = - match name with - | "this" -> () (* TODO: vars named `this` should technically be VGenerated, not VUser *) - | _ -> - let s_var_origin origin = - match origin with - | TVOLocalVariable -> "variable" - | TVOArgument -> "function argument" - | TVOForVariable -> "for variable" - | TVOPatternVariable -> "pattern variable" - | TVOCatchVariable -> "catch variable" - | TVOLocalFunction -> "function" - in - check_identifier_name ctx name (s_var_origin origin) p - let add_local_with_origin ctx origin n t p = - check_local_variable_name ctx n origin p; + Naming.check_local_variable_name ctx.com n origin p; add_local ctx (VUser origin) n t p let gen_local_prefix = "`" @@ -521,50 +466,50 @@ let is_gen_local v = match v.v_kind with | _ -> false -let delay ctx p f = +let delay g p f = let p = Obj.magic p in - let tasks = ctx.g.delayed.(p) in + let tasks = g.delayed.(p) in tasks.tasks <- f :: tasks.tasks; - if p < ctx.g.delayed_min_index then - ctx.g.delayed_min_index <- p + if p < g.delayed_min_index then + g.delayed_min_index <- p -let delay_late ctx p f = +let delay_late g p f = let p = Obj.magic p in - let tasks = ctx.g.delayed.(p) in + let tasks = g.delayed.(p) in tasks.tasks <- tasks.tasks @ [f]; - if p < ctx.g.delayed_min_index then - ctx.g.delayed_min_index <- p + if p < g.delayed_min_index then + g.delayed_min_index <- p -let delay_if_mono ctx p t f = match follow t with +let delay_if_mono g p t f = match follow t with | TMono _ -> - delay ctx p f + delay g p f | _ -> f() -let rec flush_pass ctx p where = +let rec flush_pass g p where = let rec loop i = if i > (Obj.magic p) then () else begin - let tasks = ctx.g.delayed.(i) in + let tasks = g.delayed.(i) in match tasks.tasks with | f :: l -> tasks.tasks <- l; f(); - flush_pass ctx p where + flush_pass g p where | [] -> (* Done with this pass (for now), update min index to next one *) let i = i + 1 in - ctx.g.delayed_min_index <- i; + g.delayed_min_index <- i; loop i end in - loop ctx.g.delayed_min_index + loop g.delayed_min_index let make_pass ctx f = f -let enter_field_typing_pass ctx info = - flush_pass ctx PConnectField info +let enter_field_typing_pass g info = + flush_pass g PConnectField info let make_lazy ?(force=true) ctx t_proc f where = let r = ref (lazy_available t_dynamic) in @@ -581,24 +526,6 @@ let make_lazy ?(force=true) ctx t_proc f where = if force then delay ctx PForce (fun () -> ignore(lazy_type r)); r -let fake_modules = Hashtbl.create 0 -let create_fake_module ctx file = - let key = ctx.com.file_keys#get file in - let file = Path.get_full_path file in - let mdep = (try Hashtbl.find fake_modules key with Not_found -> - let mdep = { - m_id = alloc_mid(); - m_path = (["$DEP"],file); - m_types = []; - m_statics = None; - m_extra = module_extra file (Define.get_signature ctx.com.defines) (file_time file) MFake ctx.com.compilation_step []; - } in - Hashtbl.add fake_modules key mdep; - mdep - ) in - ctx.com.module_lut#add mdep.m_path mdep; - mdep - let is_removable_field com f = not (has_class_field_flag f CfOverride) && ( has_class_field_flag f CfExtern || has_class_field_flag f CfGeneric @@ -618,16 +545,6 @@ let is_forced_inline c cf = let needs_inline ctx c cf = cf.cf_kind = Method MethInline && ctx.allow_inline && (ctx.g.doinline || is_forced_inline c cf) -let clone_type_parameter map path ttp = - let c = ttp.ttp_class in - let c = {c with cl_path = path} in - let def = Option.map map ttp.ttp_default in - let constraints = match ttp.ttp_constraints with - | None -> None - | Some constraints -> Some (lazy (List.map map (Lazy.force constraints))) - in - mk_type_param c ttp.ttp_host def constraints - (** checks if we can access to a given class field using current context *) let can_access ctx c cf stat = if (has_class_field_flag cf CfPublic) then @@ -763,40 +680,6 @@ let merge_core_doc ctx mt = end | _ -> ()) -let field_to_type_path com e = - let rec loop e pack name = match e with - | EField(e,f,_),p when Char.lowercase_ascii (String.get f 0) <> String.get f 0 -> (match name with - | [] | _ :: [] -> - loop e pack (f :: name) - | _ -> (* too many name paths *) - display_error com ("Unexpected " ^ f) p; - raise Exit) - | EField(e,f,_),_ -> - loop e (f :: pack) name - | EConst(Ident f),_ -> - let pack, name, sub = match name with - | [] -> - let fchar = String.get f 0 in - if Char.uppercase_ascii fchar = fchar then - pack, f, None - else begin - display_error com "A class name must start with an uppercase letter" (snd e); - raise Exit - end - | [name] -> - f :: pack, name, None - | [name; sub] -> - f :: pack, name, Some sub - | _ -> - die "" __LOC__ - in - { tpackage=pack; tname=name; tparams=[]; tsub=sub } - | _,pos -> - display_error com "Unexpected expression when building strict meta" pos; - raise Exit - in - loop e [] [] - let safe_mono_close ctx m p = try Monomorph.close m diff --git a/src/core/naming.ml b/src/core/naming.ml index 2a3b3641768..844a4a4fa8a 100644 --- a/src/core/naming.ml +++ b/src/core/naming.ml @@ -1,6 +1,8 @@ open Globals open Ast open Type +open Common +open Error (** retrieve string from @:native metadata or raise Not_found *) let get_native_name meta = @@ -84,3 +86,54 @@ let apply_native_paths t = ()) with Not_found -> () + + +let display_identifier_error com ?prepend_msg msg p = + let prepend = match prepend_msg with Some s -> s ^ " " | _ -> "" in + Common.display_error com (prepend ^ msg) p + +let check_identifier_name ?prepend_msg com name kind p = + if starts_with name '$' then + display_identifier_error com ?prepend_msg ((StringHelper.capitalize kind) ^ " names starting with a dollar are not allowed: \"" ^ name ^ "\"") p + else if not (Lexer.is_valid_identifier name) then + display_identifier_error com ?prepend_msg ("\"" ^ (StringHelper.s_escape name) ^ "\" is not a valid " ^ kind ^ " name.") p + +let check_field_name com name p = + match name with + | "new" -> () (* the only keyword allowed in field names *) + | _ -> check_identifier_name com name "field" p + +let check_uppercase_identifier_name ?prepend_msg com name kind p = + if String.length name = 0 then + display_identifier_error ?prepend_msg com ((StringHelper.capitalize kind) ^ " name must not be empty.") p + else if Ast.is_lower_ident name then + display_identifier_error ?prepend_msg com ((StringHelper.capitalize kind) ^ " name should start with an uppercase letter: \"" ^ name ^ "\"") p + else + check_identifier_name ?prepend_msg com name kind p + +let check_module_path com (pack,name) p = + let full_path = StringHelper.s_escape (if pack = [] then name else (String.concat "." pack) ^ "." ^ name) in + check_uppercase_identifier_name ~prepend_msg:("Module \"" ^ full_path ^ "\" does not have a valid name.") com name "module" p; + try + List.iter (fun part -> Path.check_package_name part) pack; + with Failure msg -> + display_error_ext com (make_error + ~sub:[make_error (Custom msg) p] + (Custom ("\"" ^ (StringHelper.s_escape (String.concat "." pack)) ^ "\" is not a valid package name:")) + p + ) + +let check_local_variable_name com name origin p = + match name with + | "this" -> () (* TODO: vars named `this` should technically be VGenerated, not VUser *) + | _ -> + let s_var_origin origin = + match origin with + | TVOLocalVariable -> "variable" + | TVOArgument -> "function argument" + | TVOForVariable -> "for variable" + | TVOPatternVariable -> "pattern variable" + | TVOCatchVariable -> "catch variable" + | TVOLocalFunction -> "function" + in + check_identifier_name com name (s_var_origin origin) p \ No newline at end of file diff --git a/src/typing/finalization.ml b/src/typing/finalization.ml index 61953a43f75..67189a59a15 100644 --- a/src/typing/finalization.ml +++ b/src/typing/finalization.ml @@ -79,7 +79,7 @@ let get_main ctx types = Some main let finalize ctx = - flush_pass ctx PFinal ("final",[]); + flush_pass ctx.g PFinal ("final",[]); match ctx.com.callbacks#get_after_typing with | [] -> () @@ -91,7 +91,7 @@ let finalize ctx = () | new_types -> List.iter (fun f -> f new_types) fl; - flush_pass ctx PFinal ("final",[]); + flush_pass ctx.g PFinal ("final",[]); loop all_types in loop [] diff --git a/src/typing/functionArguments.ml b/src/typing/functionArguments.ml index f7251a69ca3..0c478ae48c6 100644 --- a/src/typing/functionArguments.ml +++ b/src/typing/functionArguments.ml @@ -99,8 +99,8 @@ object(self) v.v_meta <- (Meta.This,[],null_pos) :: v.v_meta; loop ((v,None) :: acc) false syntax typed | ((_,pn),opt,m,_,_) :: syntax,(name,eo,t) :: typed -> - delay ctx PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); - if not is_extern then check_local_variable_name ctx name TVOArgument pn; + delay ctx.g PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); + if not is_extern then Naming.check_local_variable_name ctx.com name TVOArgument pn; let eo = type_function_arg_value ctx t eo do_display in let v = make_local name (VUser TVOArgument) t m pn in if do_display && DisplayPosition.display_position#enclosed_in pn then @@ -121,7 +121,7 @@ object(self) | syntax,(name,_,t) :: typed when is_abstract_this -> loop false syntax typed | ((_,pn),opt,m,_,_) :: syntax,(name,eo,t) :: typed -> - delay ctx PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); + delay ctx.g PTypeField (fun() -> self#check_rest (typed = []) eo opt t pn); ignore(type_function_arg_value ctx t eo do_display); loop false syntax typed | [],[] -> diff --git a/src/typing/generic.ml b/src/typing/generic.ml index 30e59364c07..a0eebd9e8c3 100644 --- a/src/typing/generic.ml +++ b/src/typing/generic.ml @@ -26,7 +26,8 @@ let make_generic ctx ps pt debug p = begin match c.cl_kind with | KExpr e -> let name = ident_safe (Ast.Printer.s_expr e) in - let e = type_expr {ctx with f = {ctx.f with locals = PMap.empty}} e WithType.value in + let ctx = TyperManager.clone_for_type_parameter_expression ctx in + let e = type_expr ctx e WithType.value in name,(t,Some e) | _ -> ((ident_safe (s_type_path_underscore c.cl_path)) ^ (loop_tl top tl),(t,None)) @@ -231,6 +232,16 @@ let build_instances ctx t p = in loop t +let clone_type_parameter map path ttp = + let c = ttp.ttp_class in + let c = {c with cl_path = path} in + let def = Option.map map ttp.ttp_default in + let constraints = match ttp.ttp_constraints with + | None -> None + | Some constraints -> Some (lazy (List.map map (Lazy.force constraints))) + in + mk_type_param c ttp.ttp_host def constraints + let clone_type_parameter gctx mg path ttp = let ttp = clone_type_parameter (generic_substitute_type gctx) path ttp in ttp.ttp_class.cl_module <- mg; @@ -288,8 +299,10 @@ let build_generic_class ctx c p tl = m_statics = None; m_extra = module_extra (s_type_path (pack,name)) m.m_extra.m_sign 0. MFake gctx.ctx.com.compilation_step m.m_extra.m_check_policy; } in + let ctx = TyperManager.clone_for_module ctx.g.root_typer (TypeloadModule.make_curmod ctx.com ctx.g mg) in gctx.mg <- Some mg; let cg = mk_class mg (pack,name) c.cl_pos c.cl_name_pos in + let ctx = TyperManager.clone_for_class ctx c in cg.cl_meta <- List.filter (fun (m,_,_) -> match m with | Meta.Access | Allow | Final @@ -337,7 +350,7 @@ let build_generic_class ctx c p tl = | None -> (* There can be cases like #11152 where cf_expr isn't ready yet. It should be safe to delay this to the end of the PTypeField pass. *) - delay_late ctx PTypeField (fun () -> match cf_old.cf_expr with + delay_late ctx.g PTypeField (fun () -> match cf_old.cf_expr with | Some e -> update_expr e | None -> @@ -355,7 +368,7 @@ let build_generic_class ctx c p tl = t in let t = spawn_monomorph ctx.e p in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let t0 = f() in unify_raise t0 t p; link_dynamic t0 t; diff --git a/src/typing/instanceBuilder.ml b/src/typing/instanceBuilder.ml index 5d86ee883b9..8d0eeee7d3f 100644 --- a/src/typing/instanceBuilder.ml +++ b/src/typing/instanceBuilder.ml @@ -74,7 +74,7 @@ let get_build_info ctx mtype p = if ctx.pass > PBuildClass then ignore(c.cl_build()); let build f s tl = let t = spawn_monomorph ctx.e p in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let tf = f tl in unify_raise tf t p; link_dynamic t tf; diff --git a/src/typing/macroContext.ml b/src/typing/macroContext.ml index 225c211339d..65b831ad254 100644 --- a/src/typing/macroContext.ml +++ b/src/typing/macroContext.ml @@ -57,24 +57,21 @@ let macro_timer com l = let typing_timer ctx need_type f = let t = Timer.timer ["typing"] in - let old = ctx.com.error_ext and oldlocals = ctx.f.locals in + let old = ctx.com.error_ext in let restore_report_mode = disable_report_mode ctx.com in - (* - disable resumable errors... unless we are in display mode (we want to reach point of completion) - *) - (* if ctx.com.display.dms_kind = DMNone then ctx.com.error <- (fun e -> raise_error e); *) (* TODO: review this... *) + let restore_field_state = TypeloadFunction.save_field_state ctx in ctx.com.error_ext <- (fun err -> raise_error { err with err_from_macro = true }); let ctx = if need_type && ctx.pass < PTypeField then begin - enter_field_typing_pass ctx ("typing_timer",[] (* TODO: ? *)); - TyperManager.clone_for_expr ctx + enter_field_typing_pass ctx.g ("typing_timer",[]); + TyperManager.clone_for_expr ctx ctx.e.curfun false end else ctx in let exit() = t(); ctx.com.error_ext <- old; - ctx.f.locals <- oldlocals; + restore_field_state (); restore_report_mode (); in try @@ -465,7 +462,7 @@ let make_macro_api ctx mctx p = in let add is_macro ctx = let mdep = Option.map_default (fun s -> TypeloadModule.load_module ctx (parse_path s) pos) ctx.m.curmod mdep in - let mnew = TypeloadModule.type_module ctx ~dont_check_path:(has_native_meta) m (Path.UniqueKey.lazy_path mdep.m_extra.m_file) [tdef,pos] pos in + let mnew = TypeloadModule.type_module ctx.com ctx.g ~dont_check_path:(has_native_meta) m (Path.UniqueKey.lazy_path mdep.m_extra.m_file) [tdef,pos] pos in mnew.m_extra.m_kind <- if is_macro then MMacro else MFake; add_dependency mnew mdep; ctx.com.module_nonexistent_lut#clear; @@ -495,7 +492,7 @@ let make_macro_api ctx mctx p = let m = ctx.com.module_lut#find mpath in ignore(TypeloadModule.type_types_into_module ctx.com ctx.g m types pos) with Not_found -> - let mnew = TypeloadModule.type_module ctx mpath (Path.UniqueKey.lazy_path ctx.m.curmod.m_extra.m_file) types pos in + let mnew = TypeloadModule.type_module ctx.com ctx.g mpath (Path.UniqueKey.lazy_path ctx.m.curmod.m_extra.m_file) types pos in mnew.m_extra.m_kind <- MFake; add_dependency mnew ctx.m.curmod; ctx.com.module_nonexistent_lut#clear; @@ -508,7 +505,7 @@ let make_macro_api ctx mctx p = ctx.m.curmod.m_extra.m_deps <- old_deps; m ) in - add_dependency m (create_fake_module ctx file); + add_dependency m (TypeloadCacheHook.create_fake_module ctx.com file); ); MacroApi.current_module = (fun() -> ctx.m.curmod @@ -554,7 +551,7 @@ let make_macro_api ctx mctx p = List.iter (fun path -> ImportHandling.init_using ctx path null_pos ) usings; - flush_pass ctx PConnectField ("with_imports",[] (* TODO: ? *)); + flush_pass ctx.g PConnectField ("with_imports",[] (* TODO: ? *)); f() in let restore () = diff --git a/src/typing/strictMeta.ml b/src/typing/strictMeta.ml index 4acc0cf44f3..7ed54be3742 100644 --- a/src/typing/strictMeta.ml +++ b/src/typing/strictMeta.ml @@ -124,6 +124,40 @@ let make_meta ctx texpr extra = | _ -> display_error ctx.com "Unexpected expression" texpr.epos; die "" __LOC__ +let field_to_type_path com e = + let rec loop e pack name = match e with + | EField(e,f,_),p when Char.lowercase_ascii (String.get f 0) <> String.get f 0 -> (match name with + | [] | _ :: [] -> + loop e pack (f :: name) + | _ -> (* too many name paths *) + display_error com ("Unexpected " ^ f) p; + raise Exit) + | EField(e,f,_),_ -> + loop e (f :: pack) name + | EConst(Ident f),_ -> + let pack, name, sub = match name with + | [] -> + let fchar = String.get f 0 in + if Char.uppercase_ascii fchar = fchar then + pack, f, None + else begin + display_error com "A class name must start with an uppercase letter" (snd e); + raise Exit + end + | [name] -> + f :: pack, name, None + | [name; sub] -> + f :: pack, name, Some sub + | _ -> + die "" __LOC__ + in + { tpackage=pack; tname=name; tparams=[]; tsub=sub } + | _,pos -> + display_error com "Unexpected expression when building strict meta" pos; + raise Exit + in + loop e [] [] + let get_strict_meta ctx meta params pos = let pf = ctx.com.platform in let changed_expr, fields_to_check, ctype = match params with @@ -172,7 +206,7 @@ let get_strict_meta ctx meta params pos = raise Exit in let t = Typeload.load_complex_type ctx false (ctype,pos) in - flush_pass ctx PBuildClass "get_strict_meta"; + flush_pass ctx.g PBuildClass "get_strict_meta"; let texpr = type_expr ctx changed_expr NoValue in let with_type_expr = (ECheckType( (EConst (Ident "null"), pos), (ctype,null_pos) ), pos) in let extra = handle_fields ctx fields_to_check with_type_expr in diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml index bfba81c88ac..5a2c33f0a52 100644 --- a/src/typing/typeload.ml +++ b/src/typing/typeload.ml @@ -279,7 +279,8 @@ let check_param_constraints ctx t map ttp p = in match follow t with | TInst({cl_kind = KExpr e},_) -> - let e = type_expr {ctx with f = {ctx.f with locals = PMap.empty}} e (WithType.with_type ti) in + let ctx = TyperManager.clone_for_type_parameter_expression ctx in + let e = type_expr ctx e (WithType.with_type ti) in begin try unify_raise e.etype ti p with Error { err_message = Unify _ } -> fail() end | _ -> @@ -390,7 +391,7 @@ let rec load_params ctx info params p = let t = apply_params info.build_params params t in maybe_build_instance ctx t ParamNormal p; in - delay ctx PCheckConstraint (fun () -> + delay ctx.g PCheckConstraint (fun () -> DynArray.iter (fun (t,c,p) -> check_param_constraints ctx t map c p ) checks @@ -471,7 +472,7 @@ and load_complex_type' ctx allow_display (t,p) = ) tl in let tr = Monomorph.create() in let t = TMono tr in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let ta = make_extension_type ctx tl in Monomorph.bind tr ta; ta @@ -512,7 +513,7 @@ and load_complex_type' ctx allow_display (t,p) = ) tl in let tr = Monomorph.create() in let t = TMono tr in - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> Monomorph.bind tr (match il with | [i] -> mk_extension i @@ -616,7 +617,7 @@ and load_complex_type' ctx allow_display (t,p) = | None -> () | Some cf -> - delay ctx PBuildClass (fun () -> DisplayEmitter.display_field ctx (AnonymousStructure a) CFSMember cf cf.cf_name_pos); + delay ctx.g PBuildClass (fun () -> DisplayEmitter.display_field ctx (AnonymousStructure a) CFSMember cf cf.cf_name_pos); end; TAnon a | CTFunction (args,r) -> @@ -635,7 +636,7 @@ and load_complex_type ctx allow_display (t,pn) = load_complex_type' ctx allow_display (t,pn) with Error ({ err_message = Module_not_found(([],name)) } as err) -> if Diagnostics.error_in_diagnostics_run ctx.com err.err_pos then begin - delay ctx PForce (fun () -> DisplayToplevel.handle_unresolved_identifier ctx name err.err_pos true); + delay ctx.g PForce (fun () -> DisplayToplevel.handle_unresolved_identifier ctx name err.err_pos true); t_dynamic end else if ignore_error ctx.com && not (DisplayPosition.display_position#enclosed_in pn) then t_dynamic @@ -739,13 +740,13 @@ and type_type_params ctx host path p tpl = tp,type_type_param ctx host path p tp ) tpl in let params = List.map snd param_pairs in - let ctx = { ctx with type_params = params @ ctx.type_params } in + let ctx = TyperManager.clone_for_type_params ctx (params @ ctx.type_params) in List.iter (fun (tp,ttp) -> begin match tp.tp_default with | None -> () | Some ct -> - let r = make_lazy ctx ttp.ttp_type (fun r -> + let r = make_lazy ctx.g ttp.ttp_type (fun r -> let t = load_complex_type ctx true ct in begin match host with | TPHType -> @@ -785,7 +786,7 @@ and type_type_params ctx host path p tpl = List.iter loop constr; constr ) in - delay ctx PConnectField (fun () -> ignore (Lazy.force constraints)); + delay ctx.g PConnectField (fun () -> ignore (Lazy.force constraints)); ttp.ttp_constraints <- Some constraints; ) param_pairs; params @@ -819,7 +820,7 @@ let load_core_class ctx c = | _ -> c.cl_path in let t = load_type_def' ctx2 (fst c.cl_module.m_path) (snd c.cl_module.m_path) (snd tpath) null_pos in - flush_pass ctx2 PFinal ("core_final",(fst c.cl_path @ [snd c.cl_path])); + flush_pass ctx2.g PFinal ("core_final",(fst c.cl_path @ [snd c.cl_path])); match t with | TClassDecl ccore | TAbstractDecl {a_impl = Some ccore} -> ccore diff --git a/src/typing/typeloadCacheHook.ml b/src/typing/typeloadCacheHook.ml new file mode 100644 index 00000000000..b9be6a15346 --- /dev/null +++ b/src/typing/typeloadCacheHook.ml @@ -0,0 +1,31 @@ +open Globals +open TType +open Common +open TFunctions + +type find_module_result = + | GoodModule of module_def + | BadModule of module_skip_reason + | BinaryModule of HxbData.module_cache + | NoModule + +let type_module_hook : (Common.context -> path -> pos -> find_module_result) ref = ref (fun _ _ _ -> NoModule) + +let fake_modules = Hashtbl.create 0 + +let create_fake_module com file = + let key = com.file_keys#get file in + let file = Path.get_full_path file in + let mdep = (try Hashtbl.find fake_modules key with Not_found -> + let mdep = { + m_id = alloc_mid(); + m_path = (["$DEP"],file); + m_types = []; + m_statics = None; + m_extra = module_extra file (Define.get_signature com.defines) (file_time file) MFake com.compilation_step []; + } in + Hashtbl.add fake_modules key mdep; + mdep + ) in + com.module_lut#add mdep.m_path mdep; + mdep \ No newline at end of file diff --git a/src/typing/typeloadCheck.ml b/src/typing/typeloadCheck.ml index 6532c9e99f3..5369903fb96 100644 --- a/src/typing/typeloadCheck.ml +++ b/src/typing/typeloadCheck.ml @@ -47,7 +47,7 @@ let is_generic_parameter ctx c = with Not_found -> false -let valid_redefinition ctx map1 map2 f1 t1 f2 t2 = (* child, parent *) +let valid_redefinition map1 map2 f1 t1 f2 t2 = (* child, parent *) let valid t1 t2 = Type.unify t1 t2; if is_null t1 <> is_null t2 || ((follow t1) == t_dynamic && (follow t2) != t_dynamic) then raise (Unify_error [Cannot_unify (t1,t2)]); @@ -186,7 +186,7 @@ let check_override_field ctx p rctx = display_error ctx.com ("Field " ^ i ^ " has different property access than in superclass") p); if (has_class_field_flag rctx.cf_old CfFinal) then display_error ctx.com ("Cannot override final method " ^ i) p; try - valid_redefinition ctx rctx.map rctx.map rctx.cf_new rctx.cf_new.cf_type rctx.cf_old rctx.t_old; + valid_redefinition rctx.map rctx.map rctx.cf_new rctx.cf_new.cf_type rctx.cf_old rctx.t_old; with Unify_error l -> (* TODO construct error with sub *) @@ -332,7 +332,7 @@ let check_global_metadata ctx meta f_add mpath tpath so = let add = ((field_mode && to_fields) || (not field_mode && to_types)) && (match_path recursive sl1 sl2) in if add then f_add m ) ctx.com.global_metadata; - if ctx.m.is_display_file then delay ctx PCheckConstraint (fun () -> DisplayEmitter.check_display_metadata ctx meta) + if ctx.m.is_display_file then delay ctx.g PCheckConstraint (fun () -> DisplayEmitter.check_display_metadata ctx meta) module Inheritance = struct let is_basic_class_path path = match path with @@ -351,9 +351,9 @@ module Inheritance = struct end | t -> raise_typing_error (Printf.sprintf "Should extend by using a class, found %s" (s_type_kind t)) p - let rec check_interface ctx missing c intf params = + let rec check_interface com g missing c intf params = List.iter (fun (i2,p2) -> - check_interface ctx missing c i2 (List.map (apply_params intf.cl_params params) p2) + check_interface com g missing c i2 (List.map (apply_params intf.cl_params params) p2) ) intf.cl_implements; let p = c.cl_name_pos in let check_field f = @@ -363,7 +363,7 @@ module Inheritance = struct let cf = {f with cf_overloads = []; cf_type = apply_params intf.cl_params params f.cf_type} in begin try let cf' = PMap.find cf.cf_name c.cl_fields in - ctx.com.overload_cache#remove (c.cl_path,f.cf_name); + com.overload_cache#remove (c.cl_path,f.cf_name); cf'.cf_overloads <- cf :: cf'.cf_overloads with Not_found -> TClass.add_field c cf @@ -378,13 +378,13 @@ module Inheritance = struct let map2, t2, f2 = class_field_no_interf c f.cf_name in let t2, f2 = if f2.cf_overloads <> [] || has_class_field_flag f2 CfOverload then - let overloads = get_overloads ctx.com c f.cf_name in + let overloads = get_overloads com c f.cf_name in is_overload := true; List.find (fun (t1,f1) -> Overloads.same_overload_args t t1 f f1) overloads else t2, f2 in - delay ctx PForce (fun () -> + delay g PForce (fun () -> ignore(follow f2.cf_type); (* force evaluation *) let p = f2.cf_name_pos in let mkind = function @@ -393,19 +393,19 @@ module Inheritance = struct | MethMacro -> 2 in if (has_class_field_flag f CfPublic) && not (has_class_field_flag f2 CfPublic) && not (Meta.has Meta.CompilerGenerated f.cf_meta) then - display_error ctx.com ("Field " ^ f.cf_name ^ " should be public as requested by " ^ s_type_path intf.cl_path) p + display_error com ("Field " ^ f.cf_name ^ " should be public as requested by " ^ s_type_path intf.cl_path) p else if not (unify_kind ~strict:false f2.cf_kind f.cf_kind) || not (match f.cf_kind, f2.cf_kind with Var _ , Var _ -> true | Method m1, Method m2 -> mkind m1 = mkind m2 | _ -> false) then - display_error ctx.com ("Field " ^ f.cf_name ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p + display_error com ("Field " ^ f.cf_name ^ " has different property access than in " ^ s_type_path intf.cl_path ^ " (" ^ s_kind f2.cf_kind ^ " should be " ^ s_kind f.cf_kind ^ ")") p else try let map1 = TClass.get_map_function intf params in - valid_redefinition ctx map1 map2 f2 t2 f (apply_params intf.cl_params params f.cf_type) + valid_redefinition map1 map2 f2 t2 f (apply_params intf.cl_params params f.cf_type) with Unify_error l -> if not (Meta.has Meta.CsNative c.cl_meta && (has_class_flag c CExtern)) then begin (* TODO construct error with sub *) - display_error ctx.com ("Field " ^ f.cf_name ^ " has different type than in " ^ s_type_path intf.cl_path) p; - display_error ~depth:1 ctx.com (compl_msg "Interface field is defined here") f.cf_pos; - display_error ~depth:1 ctx.com (compl_msg (error_msg (Unify l))) p; + display_error com ("Field " ^ f.cf_name ^ " has different type than in " ^ s_type_path intf.cl_path) p; + display_error ~depth:1 com (compl_msg "Interface field is defined here") f.cf_pos; + display_error ~depth:1 com (compl_msg (error_msg (Unify l))) p; end ) with Not_found -> @@ -418,7 +418,7 @@ module Inheritance = struct add_class_field_flag cf CfExtern; add_class_field_flag cf CfOverride; end else if not (has_class_flag c CInterface) then begin - if Diagnostics.error_in_diagnostics_run ctx.com c.cl_pos then + if Diagnostics.error_in_diagnostics_run com c.cl_pos then DynArray.add missing (f,t) else begin let msg = if !is_overload then @@ -428,7 +428,7 @@ module Inheritance = struct else ("Field " ^ f.cf_name ^ " needed by " ^ s_type_path intf.cl_path ^ " is missing") in - display_error ctx.com msg p + display_error com msg p end end in @@ -445,7 +445,7 @@ module Inheritance = struct | _ -> List.iter (fun (intf,params) -> let missing = DynArray.create () in - check_interface ctx missing c intf params; + check_interface ctx.com ctx.g missing c intf params; if DynArray.length missing > 0 then begin let l = DynArray.to_list missing in let diag = { @@ -544,7 +544,7 @@ module Inheritance = struct we do want to check them at SOME point. So we use this pending list which was maybe designed for this purpose. However, we STILL have to delay the check because at the time pending is handled, the class is not built yet. See issue #10847. *) - pending := (fun () -> delay ctx PConnectField check_interfaces_or_delay) :: !pending + pending := (fun () -> delay ctx.g PConnectField check_interfaces_or_delay) :: !pending | _ when ctx.com.display.dms_full_typing -> check_interfaces ctx c | _ -> @@ -557,7 +557,7 @@ module Inheritance = struct if not (has_class_flag csup CInterface) then raise_typing_error (Printf.sprintf "Cannot extend by using a class (%s extends %s)" (s_type_path c.cl_path) (s_type_path csup.cl_path)) p; c.cl_implements <- (csup,params) :: c.cl_implements; if not !has_interf then begin - if not is_lib then delay ctx PConnectField check_interfaces_or_delay; + if not is_lib then delay ctx.g PConnectField check_interfaces_or_delay; has_interf := true; end end else begin @@ -579,7 +579,7 @@ module Inheritance = struct if not (has_class_flag intf CInterface) then raise_typing_error "You can only implement an interface" p; c.cl_implements <- (intf, params) :: c.cl_implements; if not !has_interf && not is_lib && not (Meta.has (Meta.Custom "$do_not_check_interf") c.cl_meta) then begin - delay ctx PConnectField check_interfaces_or_delay; + delay ctx.g PConnectField check_interfaces_or_delay; has_interf := true; end; (fun () -> diff --git a/src/typing/typeloadFields.ml b/src/typing/typeloadFields.ml index 200470095e2..0a2465b99e2 100644 --- a/src/typing/typeloadFields.ml +++ b/src/typing/typeloadFields.ml @@ -240,7 +240,7 @@ let ensure_struct_init_constructor ctx c ast_fields p = cf.cf_meta <- [Meta.CompilerGenerated,[],null_pos; Meta.InheritDoc,[],null_pos]; cf.cf_kind <- Method MethNormal; c.cl_constructor <- Some cf; - delay ctx PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf) + delay ctx.g PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf) let transform_abstract_field com this_t a_t a f = let stat = List.mem_assoc AStatic f.cff_access in @@ -416,7 +416,7 @@ let build_module_def ctx mt meta fvars fbuild = | _ -> t_infos mt in (* Delay for #10107, but use delay_late to make sure base classes run before their children do. *) - delay_late ctx PConnectField (fun () -> + delay_late ctx.g PConnectField (fun () -> ti.mt_using <- (filter_classes types) @ ti.mt_using ) with Exit -> @@ -440,7 +440,7 @@ let build_module_def ctx mt meta fvars fbuild = let inherit_using (c,_) = ti.mt_using <- ti.mt_using @ (t_infos (TClassDecl c)).mt_using in - delay_late ctx PConnectField (fun () -> + delay_late ctx.g PConnectField (fun () -> Option.may inherit_using csup; List.iter inherit_using interfaces; ); @@ -607,7 +607,6 @@ let transform_field (ctx,cctx) c f fields p = f let type_var_field ctx t e stat do_display p = - if stat then ctx.e.curfun <- FunStatic else ctx.e.curfun <- FunMember; let e = if do_display then Display.preprocess_expr ctx.com e else e in let e = type_expr ctx e (WithType.with_type t) in let e = AbstractCast.cast_or_unify ctx t e p in @@ -674,7 +673,7 @@ module TypeBinding = struct in let force_macro display = (* force macro system loading of this class in order to get completion *) - delay ctx PTypeField (fun() -> + delay ctx.g PTypeField (fun() -> try ignore(ctx.g.do_macro ctx MDisplay c.cl_path cf.cf_name [] p) with @@ -744,7 +743,7 @@ module TypeBinding = struct let c = cctx.tclass in let t = cf.cf_type in let p = cf.cf_pos in - let ctx = TyperManager.clone_for_expr ctx_f in + let ctx = TyperManager.clone_for_expr ctx_f (if fctx.is_static then FunStatic else FunMember) false in if (has_class_flag c CInterface) then unexpected_expression ctx.com fctx "Initialization on field of interface" (pos e); cf.cf_meta <- ((Meta.Value,[e],null_pos) :: cf.cf_meta); let check_cast e = @@ -759,10 +758,10 @@ module TypeBinding = struct mk_cast e cf.cf_type e.epos end in - let r = make_lazy ~force:false ctx t (fun r -> + let r = make_lazy ~force:false ctx.g t (fun r -> (* type constant init fields (issue #1956) *) if not ctx.g.return_partial_type || (match fst e with EConst _ -> true | _ -> false) then begin - enter_field_typing_pass ctx ("bind_var_expression",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); + enter_field_typing_pass ctx.g ("bind_var_expression",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing field %s.%s\n" (s_type_path c.cl_path) cf.cf_name); let e = type_var_field ctx t e fctx.is_static fctx.is_display_field p in let maybe_run_analyzer e = match e.eexpr with @@ -835,18 +834,12 @@ module TypeBinding = struct | Some e -> bind_var_expression ctx cctx fctx cf e - let bind_method ctx_f cctx fctx cf t args ret e p = + let bind_method ctx_f cctx fctx fmode cf t args ret e p = let c = cctx.tclass in - let ctx = TyperManager.clone_for_expr ctx_f in + let ctx = TyperManager.clone_for_expr ctx_f fmode true in let bind r = incr stats.s_methods_typed; if (Meta.has (Meta.Custom ":debug.typing") (c.cl_meta @ cf.cf_meta)) then ctx.com.print (Printf.sprintf "Typing method %s.%s\n" (s_type_path c.cl_path) cf.cf_name); - let fmode = (match cctx.abstract with - | Some _ -> - if fctx.is_abstract_member then FunMemberAbstract else FunStatic - | None -> - if fctx.field_kind = CfrConstructor then FunConstructor else if fctx.is_static then FunStatic else FunMember - ) in begin match ctx.com.platform with | Java when is_java_native_function ctx cf.cf_meta cf.cf_pos -> if e <> None then @@ -870,7 +863,7 @@ module TypeBinding = struct | _ -> (fun () -> ()) in - let e = TypeloadFunction.type_function ctx args ret fmode e fctx.is_display_field p in + let e = TypeloadFunction.type_function ctx args ret e fctx.is_display_field p in f_check(); (* Disabled for now, see https://github.com/HaxeFoundation/haxe/issues/3033 *) (* List.iter (fun (v,_) -> @@ -894,7 +887,7 @@ module TypeBinding = struct if not ctx.g.return_partial_type then bind r; t in - let r = make_lazy ~force:false ctx t maybe_bind "type_fun" in + let r = make_lazy ~force:false ctx.g t maybe_bind "type_fun" in bind_type ctx cctx fctx cf r p end @@ -958,7 +951,7 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = fctx.expr_presence_matters <- true; end in let handle_from () = - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> (* the return type of a from-function must be the abstract, not the underlying type *) if not fctx.is_macro then (try type_eq EqStrict ret ta with Unify_error l -> raise_typing_error_ext (make_error (Unify l) p)); match t with @@ -998,7 +991,7 @@ let check_abstract (ctx,cctx,fctx) a c cf fd t ret p = let is_multitype_cast = Meta.has Meta.MultiType a.a_meta && not fctx.is_abstract_member in if is_multitype_cast && not (Meta.has Meta.MultiType cf.cf_meta) then cf.cf_meta <- (Meta.MultiType,[],null_pos) :: cf.cf_meta; - let r = make_lazy ctx t (fun r -> + let r = make_lazy ctx.g t (fun r -> let args = if is_multitype_cast then begin let ctor = try PMap.find "_new" c.cl_statics @@ -1334,27 +1327,28 @@ let create_method (ctx,cctx,fctx) c f fd p = () ) parent; generate_args_meta ctx.com (Some c) (fun meta -> cf.cf_meta <- meta :: cf.cf_meta) fd.f_args; - begin match cctx.abstract with - | Some a -> - check_abstract (ctx,cctx,fctx) a c cf fd t ret p; - | _ -> - () - end; + let fmode = match cctx.abstract with + | Some a -> + check_abstract (ctx,cctx,fctx) a c cf fd t ret p; + if fctx.is_abstract_member then FunMemberAbstract else FunStatic + | _ -> + if fctx.field_kind = CfrConstructor then FunConstructor else if fctx.is_static then FunStatic else FunMember + in init_meta_overloads ctx (Some c) cf; ctx.f.curfield <- cf; if fctx.do_bind then - TypeBinding.bind_method ctx cctx fctx cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) + TypeBinding.bind_method ctx cctx fctx fmode cf t args ret fd.f_expr (match fd.f_expr with Some e -> snd e | None -> f.cff_pos) else begin if fctx.is_display_field then begin - delay ctx PTypeField (fun () -> + delay ctx.g PTypeField (fun () -> (* We never enter type_function so we're missing out on the argument processing there. Let's do it here. *) - let ctx = TyperManager.clone_for_expr ctx in + let ctx = TyperManager.clone_for_expr ctx fmode true in ignore(args#for_expr ctx) ); check_field_display ctx fctx c cf; end else - delay ctx PTypeField (fun () -> - let ctx = TyperManager.clone_for_expr ctx in + delay ctx.g PTypeField (fun () -> + let ctx = TyperManager.clone_for_expr ctx fmode true in args#verify_extern ctx ); if fd.f_expr <> None then begin @@ -1413,7 +1407,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = (* Now that we know there is a field, we have to delay the actual unification even further. The reason is that unification could resolve TLazy, which would then cause field typing before we're done with our PConnectField pass. This could cause interface fields to not be generated in time. *) - delay ctx PForce (fun () -> + delay ctx.g PForce (fun () -> try (match f2.cf_kind with | Method MethMacro -> @@ -1465,7 +1459,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = with Not_found -> () in - let delay_check = delay ctx PConnectField in + let delay_check = delay ctx.g PConnectField in let get = (match get with | "null",_ -> AccNo | "dynamic",_ -> AccCall @@ -1473,7 +1467,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = | "default",_ -> AccNormal | "get",pget -> let get = "get_" ^ name in - if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pget then delay ctx PConnectField (fun () -> display_accessor get pget); + if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pget then delay ctx.g PConnectField (fun () -> display_accessor get pget); if not cctx.is_lib then delay_check (fun() -> check_method get t_get true); AccCall | _,pget -> @@ -1492,7 +1486,7 @@ let create_property (ctx,cctx,fctx) c f (get,set,t,eo) p = | "default",_ -> AccNormal | "set",pset -> let set = "set_" ^ name in - if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pset then delay ctx PConnectField (fun () -> display_accessor set pset); + if fctx.is_display_field && DisplayPosition.display_position#enclosed_in pset then delay ctx.g PConnectField (fun () -> display_accessor set pset); if not cctx.is_lib then delay_check (fun() -> check_method set t_set false); AccCall | _,pset -> @@ -1527,7 +1521,7 @@ let init_field (ctx,cctx,fctx) f = let name = fst f.cff_name in TypeloadCheck.check_global_metadata ctx f.cff_meta (fun m -> f.cff_meta <- m :: f.cff_meta) c.cl_module.m_path c.cl_path (Some name); let p = f.cff_pos in - if not (has_class_flag c CExtern) && not (Meta.has Meta.Native f.cff_meta) then Typecore.check_field_name ctx name p; + if not (has_class_flag c CExtern) && not (Meta.has Meta.Native f.cff_meta) then Naming.check_field_name ctx.com name p; List.iter (fun acc -> match (fst acc, f.cff_kind) with | AFinal, FProp _ when not (has_class_flag c CExtern) && ctx.com.platform <> Java -> invalid_modifier_on_property ctx.com fctx (Ast.s_placed_access acc) (snd acc) @@ -1563,7 +1557,7 @@ let init_field (ctx,cctx,fctx) f = in (if (fctx.is_static || fctx.is_macro && ctx.com.is_macro_context) then add_class_field_flag cf CfStatic); if Meta.has Meta.InheritDoc cf.cf_meta then - delay ctx PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf); + delay ctx.g PTypeField (fun() -> InheritDoc.build_class_field_doc ctx (Some c) cf); cf let check_overload ctx f fs is_extern_class = @@ -1616,7 +1610,7 @@ let finalize_class cctx = List.iter (fun (ctx,r) -> (match r with | None -> () - | Some r -> delay ctx PTypeField (fun() -> ignore(lazy_type r))) + | Some r -> delay ctx.g PTypeField (fun() -> ignore(lazy_type r))) ) cctx.delayed_expr let check_functional_interface ctx c = @@ -1647,13 +1641,13 @@ let init_class ctx_c cctx c p herits fields = let com = ctx_c.com in if cctx.is_class_debug then print_endline ("Created class context: " ^ dump_class_context cctx); let fields = build_fields (ctx_c,cctx) c fields in - if cctx.is_core_api && com.display.dms_check_core_api then delay ctx_c PForce (fun() -> init_core_api ctx_c c); + if cctx.is_core_api && com.display.dms_check_core_api then delay ctx_c.g PForce (fun() -> init_core_api ctx_c c); if not cctx.is_lib then begin - delay ctx_c PForce (fun() -> check_overloads ctx_c c); + delay ctx_c.g PForce (fun() -> check_overloads ctx_c c); begin match c.cl_super with | Some(csup,tl) -> if (has_class_flag csup CAbstract) && not (has_class_flag c CAbstract) then - delay ctx_c PForce (fun () -> TypeloadCheck.Inheritance.check_abstract_class ctx_c c csup tl); + delay ctx_c.g PForce (fun () -> TypeloadCheck.Inheritance.check_abstract_class ctx_c c csup tl); | None -> () end @@ -1768,7 +1762,7 @@ let init_class ctx_c cctx c p herits fields = end; c.cl_ordered_statics <- List.rev c.cl_ordered_statics; c.cl_ordered_fields <- List.rev c.cl_ordered_fields; - delay ctx_c PConnectField (fun () -> match follow c.cl_type with + delay ctx_c.g PConnectField (fun () -> match follow c.cl_type with | TAnon an -> an.a_fields <- c.cl_statics | _ -> diff --git a/src/typing/typeloadFunction.ml b/src/typing/typeloadFunction.ml index 9e8b073b3c6..536e14cf0af 100644 --- a/src/typing/typeloadFunction.ml +++ b/src/typing/typeloadFunction.ml @@ -36,13 +36,11 @@ let save_field_state ctx = let type_function_params ctx fd host fname p = Typeload.type_type_params ctx host ([],fname) p fd.f_params -let type_function ctx (args : function_arguments) ret fmode e do_display p = - ctx.e.in_function <- true; - ctx.e.curfun <- fmode; +let type_function ctx (args : function_arguments) ret e do_display p = ctx.e.ret <- ret; ctx.e.opened <- []; ctx.e.monomorphs.perfunction <- []; - enter_field_typing_pass ctx ("type_function",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); + enter_field_typing_pass ctx.g ("type_function",fst ctx.c.curclass.cl_path @ [snd ctx.c.curclass.cl_path;ctx.f.curfield.cf_name]); args#bring_into_context ctx; let e = match e with | None -> @@ -53,7 +51,7 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = *) EBlock [],p else - if fmode = FunMember && has_class_flag ctx.c.curclass CAbstract then + if ctx.e.curfun = FunMember && has_class_flag ctx.c.curclass CAbstract then raise_typing_error "Function body or abstract modifier required" p else raise_typing_error "Function body required" p @@ -110,10 +108,10 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = with Not_found -> None in - let e = if fmode <> FunConstructor then + let e = if ctx.e.curfun <> FunConstructor then e else begin - delay ctx PForce (fun () -> TypeloadCheck.check_final_vars ctx e); + delay ctx.g PForce (fun () -> TypeloadCheck.check_final_vars ctx e); match has_super_constr() with | Some (was_forced,t_super) -> (try @@ -163,9 +161,9 @@ let type_function ctx (args : function_arguments) ret fmode e do_display p = if is_position_debug then print_endline ("typing:\n" ^ (Texpr.dump_with_pos "" e)); e -let type_function ctx args ret fmode e do_display p = +let type_function ctx args ret e do_display p = let save = save_field_state ctx in - Std.finally save (type_function ctx args ret fmode e do_display) p + Std.finally save (type_function ctx args ret e do_display) p let add_constructor ctx_c c force_constructor p = if c.cl_constructor <> None then () else @@ -177,7 +175,7 @@ let add_constructor ctx_c c force_constructor p = cf.cf_params <- cfsup.cf_params; cf.cf_meta <- List.filter (fun (m,_,_) -> m = Meta.CompilerGenerated) cfsup.cf_meta; let t = spawn_monomorph ctx_c.e p in - let r = make_lazy ctx_c t (fun r -> + let r = make_lazy ctx_c.g t (fun r -> let ctx = TyperManager.clone_for_field ctx_c cf cf.cf_params in ignore (follow cfsup.cf_type); (* make sure it's typed *) List.iter (fun cf -> ignore (follow cf.cf_type)) cf.cf_overloads; diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index cc8a2c0d1a9..906492bcfa7 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -87,7 +87,7 @@ module ModuleLevel = struct let p = snd decl in let check_type_name type_name meta = let module_name = snd m.m_path in - if type_name <> module_name && not (Meta.has Meta.Native meta) then Typecore.check_uppercase_identifier_name ctx_m type_name "type" p; + if type_name <> module_name && not (Meta.has Meta.Native meta) then Naming.check_uppercase_identifier_name ctx_m.com type_name "type" p; in let acc = (match fst decl with | EImport _ | EUsing _ -> @@ -152,7 +152,7 @@ module ModuleLevel = struct t_meta = d.d_meta; } in (* failsafe in case the typedef is not initialized (see #3933) *) - delay ctx_m PBuildModule (fun () -> + delay ctx_m.g PBuildModule (fun () -> match t.t_type with | TMono r -> (match r.tm_type with None -> Monomorph.bind r com.basic.tvoid | _ -> ()) | _ -> () @@ -405,7 +405,7 @@ module TypeLevel = struct with TypeloadCheck.Build_canceled state -> c.cl_build <- make_pass ctx_c build; let rebuild() = - delay_late ctx_c PBuildClass (fun() -> ignore(c.cl_build())); + delay_late ctx_c.g PBuildClass (fun() -> ignore(c.cl_build())); in (match state with | Built -> die "" __LOC__ @@ -424,11 +424,11 @@ module TypeLevel = struct build() in c.cl_build <- make_pass ctx_m build; - delay ctx_m PBuildClass (fun() -> ignore(c.cl_build())); + delay ctx_m.g PBuildClass (fun() -> ignore(c.cl_build())); if Meta.has Meta.InheritDoc c.cl_meta then - delay ctx_m PConnectField (fun() -> InheritDoc.build_class_doc ctx_m c); + delay ctx_m.g PConnectField (fun() -> InheritDoc.build_class_doc ctx_m c); if (ctx_m.com.platform = Java || ctx_m.com.platform = Cs) && not (has_class_flag c CExtern) then - delay ctx_m PTypeField (fun () -> + delay ctx_m.g PTypeField (fun () -> let metas = StrictMeta.check_strict_meta ctx_m c.cl_meta in if metas <> [] then c.cl_meta <- metas @ c.cl_meta; let rec run_field cf = @@ -498,16 +498,16 @@ module TypeLevel = struct incr index; names := (fst c.ec_name) :: !names; if Meta.has Meta.InheritDoc f.ef_meta then - delay ctx_en PConnectField (fun() -> InheritDoc.build_enum_field_doc ctx_en f); + delay ctx_en.g PConnectField (fun() -> InheritDoc.build_enum_field_doc ctx_en f); ) (!constructs); e.e_names <- List.rev !names; e.e_extern <- e.e_extern; unify ctx_en (TType(enum_module_type e,[])) e.e_type p; if !is_flat then e.e_meta <- (Meta.FlatEnum,[],null_pos) :: e.e_meta; if Meta.has Meta.InheritDoc e.e_meta then - delay ctx_en PConnectField (fun() -> InheritDoc.build_enum_doc ctx_en e); + delay ctx_en.g PConnectField (fun() -> InheritDoc.build_enum_doc ctx_en e); if (ctx_en.com.platform = Java || ctx_en.com.platform = Cs) && not e.e_extern then - delay ctx_en PTypeField (fun () -> + delay ctx_en.g PTypeField (fun () -> let metas = StrictMeta.check_strict_meta ctx_en e.e_meta in e.e_meta <- metas @ e.e_meta; PMap.iter (fun _ ef -> @@ -547,7 +547,7 @@ module TypeLevel = struct | _ -> () in - let r = make_lazy ctx_td tt (fun r -> + let r = make_lazy ctx_td.g tt (fun r -> check_rec tt; tt ) "typedef_rec_check" in @@ -562,7 +562,7 @@ module TypeLevel = struct | _ -> die "" __LOC__); TypeloadFields.build_module_def ctx_td (TTypeDecl t) t.t_meta (fun _ -> []) (fun _ -> ()); if ctx_td.com.platform = Cs && t.t_meta <> [] then - delay ctx_td PTypeField (fun () -> + delay ctx_td.g PTypeField (fun () -> let metas = StrictMeta.check_strict_meta ctx_td t.t_meta in if metas <> [] then t.t_meta <- metas @ t.t_meta; ) @@ -586,7 +586,7 @@ module TypeLevel = struct let t = load_complex_type ctx_a true t in let t = if not (Meta.has Meta.CoreType a.a_meta) then begin if !is_type then begin - let r = make_lazy ctx_a t (fun r -> + let r = make_lazy ctx_a.g t (fun r -> (try (if from then Type.unify t a.a_this else Type.unify a.a_this t) with Unify_error _ -> raise_typing_error "You can only declare from/to with compatible types" pos); t ) "constraint" in @@ -607,7 +607,7 @@ module TypeLevel = struct if a.a_impl = None then raise_typing_error "Abstracts with underlying type must have an implementation" a.a_pos; if Meta.has Meta.CoreType a.a_meta then raise_typing_error "@:coreType abstracts cannot have an underlying type" p; let at = load_complex_type ctx_a true t in - delay ctx_a PForce (fun () -> + delay ctx_a.g PForce (fun () -> let rec loop stack t = match follow t with | TAbstract(a,_) when not (Meta.has Meta.CoreType a.a_meta) -> @@ -634,7 +634,7 @@ module TypeLevel = struct raise_typing_error "Abstract is missing underlying type declaration" a.a_pos end; if Meta.has Meta.InheritDoc a.a_meta then - delay ctx_a PConnectField (fun() -> InheritDoc.build_abstract_doc ctx_a a) + delay ctx_a.g PConnectField (fun() -> InheritDoc.build_abstract_doc ctx_a a) (* In this pass, we can access load and access other modules types, but we cannot follow them or access their structure @@ -697,7 +697,7 @@ let make_curmod com g m = Creates a module context for [m] and types [tdecls] using it. *) let type_types_into_module com g m tdecls p = - let ctx_m = TyperManager.create_for_module com g (make_curmod com g m) in + let ctx_m = TyperManager.clone_for_module g.root_typer (make_curmod com g m) in let decls,tdecls = ModuleLevel.create_module_types ctx_m m tdecls p in let types = List.map fst decls in (* During the initial module_lut#add in type_module, m has no m_types yet by design. @@ -715,48 +715,47 @@ let type_types_into_module com g m tdecls p = (* setup module types *) List.iter (TypeLevel.init_module_type ctx_m) tdecls; (* Make sure that we actually init the context at some point (issue #9012) *) - delay ctx_m PConnectField (fun () -> ctx_m.m.import_resolution#resolve_lazies); + delay ctx_m.g PConnectField (fun () -> ctx_m.m.import_resolution#resolve_lazies); ctx_m (* Creates a new module and types [tdecls] into it. *) -let type_module ctx_from mpath file ?(dont_check_path=false) ?(is_extern=false) tdecls p = - let m = ModuleLevel.make_module ctx_from.com ctx_from.g mpath file p in - ctx_from.com.module_lut#add m.m_path m; - let tdecls = ModuleLevel.handle_import_hx ctx_from.com ctx_from.g m tdecls p in - let ctx_m = type_types_into_module ctx_from.com ctx_from.g m tdecls p in - if is_extern then m.m_extra.m_kind <- MExtern else if not dont_check_path then Typecore.check_module_path ctx_m m.m_path p; +let type_module com g mpath file ?(dont_check_path=false) ?(is_extern=false) tdecls p = + let m = ModuleLevel.make_module com g mpath file p in + com.module_lut#add m.m_path m; + let tdecls = ModuleLevel.handle_import_hx com g m tdecls p in + let ctx_m = type_types_into_module com g m tdecls p in + if is_extern then m.m_extra.m_kind <- MExtern else if not dont_check_path then Naming.check_module_path ctx_m.com m.m_path p; m (* let type_module ctx mpath file ?(is_extern=false) tdecls p = let timer = Timer.timer ["typing";"type_module"] in Std.finally timer (type_module ctx mpath file ~is_extern tdecls) p *) -let type_module_hook = ref (fun _ _ _ -> NoModule) - class hxb_reader_api_typeload - (ctx : typer) - (load_module : typer -> path -> pos -> module_def) + (com : context) + (g : typer_globals) + (load_module : context -> typer_globals -> path -> pos -> module_def) (p : pos) = object(self) method make_module (path : path) (file : string) = - let m = ModuleLevel.make_module ctx.com ctx.g path file p in + let m = ModuleLevel.make_module com g path file p in m.m_extra.m_processed <- 1; m method add_module (m : module_def) = - ctx.com.module_lut#add m.m_path m + com.module_lut#add m.m_path m method resolve_type (pack : string list) (mname : string) (tname : string) = - let m = load_module ctx (pack,mname) p in + let m = load_module com g (pack,mname) p in List.find (fun t -> snd (t_path t) = tname) m.m_types method resolve_module (path : path) = - load_module ctx path p + load_module com g path p method basic_types = - ctx.com.basic + com.basic method get_var_id (i : int) = (* The v_id in .hxb has no relation to this context, make a new one. *) @@ -765,22 +764,22 @@ class hxb_reader_api_typeload !uid method read_expression_eagerly (cf : tclass_field) = - ctx.com.is_macro_context || match cf.cf_kind with + com.is_macro_context || match cf.cf_kind with | Var _ -> true | Method _ -> - delay ctx PTypeField (fun () -> ignore(follow cf.cf_type)); + delay g PTypeField (fun () -> ignore(follow cf.cf_type)); false end -let rec load_hxb_module ctx path p = +let rec load_hxb_module com g path p = let read file bytes = try - let api = (new hxb_reader_api_typeload ctx load_module' p :> HxbReaderApi.hxb_reader_api) in - let reader = new HxbReader.hxb_reader path ctx.com.hxb_reader_stats in + let api = (new hxb_reader_api_typeload com g load_module' p :> HxbReaderApi.hxb_reader_api) in + let reader = new HxbReader.hxb_reader path com.hxb_reader_stats in let read = reader#read api bytes in let m = read EOT in - delay ctx PConnectField (fun () -> + delay g PConnectField (fun () -> ignore(read EOM); ); m @@ -790,7 +789,7 @@ let rec load_hxb_module ctx path p = Printf.eprintf " => %s\n%s\n" msg stack; raise e in - let target = Common.platform_name_macro ctx.com in + let target = Common.platform_name_macro com in let rec loop l = match l with | hxb_lib :: l -> begin match hxb_lib#get_bytes target path with @@ -802,35 +801,35 @@ let rec load_hxb_module ctx path p = | [] -> raise Not_found in - loop ctx.com.hxb_libs + loop com.hxb_libs -and load_module' ctx m p = +and load_module' com g m p = try (* Check current context *) - ctx.com.module_lut#find m + com.module_lut#find m with Not_found -> (* Check cache *) - match !type_module_hook ctx m p with + match !TypeloadCacheHook.type_module_hook com m p with | GoodModule m -> m | BinaryModule _ -> die "" __LOC__ (* The server builds those *) | NoModule | BadModule _ -> try - load_hxb_module ctx m p + load_hxb_module com g m p with Not_found -> let raise_not_found () = raise_error_msg (Module_not_found m) p in - if ctx.com.module_nonexistent_lut#mem m then raise_not_found(); - if ctx.g.load_only_cached_modules then raise_not_found(); + if com.module_nonexistent_lut#mem m then raise_not_found(); + if g.load_only_cached_modules then raise_not_found(); let is_extern = ref false in let file, decls = try (* Try parsing *) - let rfile,decls = TypeloadParse.parse_module ctx m p in + let rfile,decls = TypeloadParse.parse_module com m p in rfile.file,decls with Not_found -> (* Nothing to parse, try loading extern type *) let rec loop = function | [] -> - ctx.com.module_nonexistent_lut#add m true; + com.module_nonexistent_lut#add m true; raise_not_found() | (file,load) :: l -> match load m p with @@ -838,15 +837,15 @@ and load_module' ctx m p = | Some (_,a) -> file, a in is_extern := true; - loop ctx.com.load_extern_type + loop com.load_extern_type in let is_extern = !is_extern in - type_module ctx m file ~is_extern decls p + type_module com g m file ~is_extern decls p let load_module ctx m p = - let m2 = load_module' ctx m p in + let m2 = load_module' ctx.com ctx.g m p in add_dependency ~skip_postprocess:true ctx.m.curmod m2; - if ctx.pass = PTypeField then flush_pass ctx PConnectField ("load_module",fst m @ [snd m]); + if ctx.pass = PTypeField then flush_pass ctx.g PConnectField ("load_module",fst m @ [snd m]); m2 (* let load_module ctx m p = diff --git a/src/typing/typeloadParse.ml b/src/typing/typeloadParse.ml index eef20a8e975..238ab8ade5b 100644 --- a/src/typing/typeloadParse.ml +++ b/src/typing/typeloadParse.ml @@ -296,14 +296,14 @@ let parse_module' com m p = let pack,decls = parse_module_file com rfile p in rfile,remap,pack,decls -let parse_module ctx m p = - let rfile,remap,pack,decls = parse_module' ctx.com m p in +let parse_module com m p = + let rfile,remap,pack,decls = parse_module' com m p in if pack <> !remap then begin let spack m = if m = [] then "`package;`" else "`package " ^ (String.concat "." m) ^ ";`" in if p == null_pos then - display_error ctx.com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p + display_error com ("Invalid commandline class : " ^ s_type_path m ^ " should be " ^ s_type_path (pack,snd m)) p else - display_error ctx.com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin} + display_error com (spack pack ^ " in " ^ rfile.file ^ " should be " ^ spack (fst m)) {p with pmax = p.pmin} end; rfile, if !remap <> fst m then (* build typedefs to redirect to real package *) diff --git a/src/typing/typer.ml b/src/typing/typer.ml index 25e48f28733..9f74c11e891 100644 --- a/src/typing/typer.ml +++ b/src/typing/typer.ml @@ -737,7 +737,7 @@ and type_vars ctx vl p = add_local ctx VGenerated n t_dynamic pv, None (* TODO: What to do with this... *) ) vl in List.iter (fun (v,_) -> - delay_if_mono ctx PTypeField v.v_type (fun() -> + delay_if_mono ctx.g PTypeField v.v_type (fun() -> if ExtType.is_void (follow v.v_type) then raise_typing_error "Variables of type Void are not allowed" v.v_pos ) @@ -1234,7 +1234,7 @@ and type_local_function ctx_from kind f with_type p = | FunMemberAbstractLocal -> FunMemberAbstractLocal | _ -> FunMemberClassLocal in - let ctx = TyperManager.clone_for_expr ctx_from in + let ctx = TyperManager.clone_for_expr ctx_from curfun true in let old_tp = ctx.type_params in ctx.type_params <- params @ ctx.type_params; if not inline then ctx.e.in_loop <- false; @@ -1338,7 +1338,7 @@ and type_local_function ctx_from kind f with_type p = if params <> [] then v.v_extra <- Some (var_extra params None); Some v ) in - let e = TypeloadFunction.type_function ctx args rt curfun f.f_expr ctx.f.in_display p in + let e = TypeloadFunction.type_function ctx args rt f.f_expr ctx.f.in_display p in ctx.type_params <- old_tp; let tf = { tf_args = args#for_expr ctx; diff --git a/src/typing/typerEntry.ml b/src/typing/typerEntry.ml index 72ae8d3bf57..f088234bd33 100644 --- a/src/typing/typerEntry.ml +++ b/src/typing/typerEntry.ml @@ -7,7 +7,7 @@ open Resolution open Error let create com macros = - let ctx = { + let rec ctx = { com = com; t = com.basic; g = { @@ -36,6 +36,7 @@ let create com macros = do_format_string = format_string; do_load_core_class = Typeload.load_core_class; delayed_display = None; + root_typer = ctx; }; m = { curmod = null_module; @@ -52,7 +53,7 @@ let create com macros = get_build_infos = (fun() -> None); }; f = TyperManager.create_ctx_f null_field; - e = TyperManager.create_ctx_e (); + e = TyperManager.create_ctx_e FunStatic false; pass = PBuildModule; allow_inline = true; allow_transform = true;