From 3cb7d88079181363699dd7e09b61fa571fc8253e Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Mon, 8 Jan 2024 08:20:30 +0100 Subject: [PATCH] [generators] add gctx.ml to lose dependency on common.ml --- src/compiler/generate.ml | 4 ++- src/context/common.ml | 19 ++++++++++ src/context/nativeLibraries.ml | 6 +++- src/generators/gctx.ml | 65 ++++++++++++++++++++++++++++++++++ src/generators/genjvm.ml | 65 +++++++++++++++++----------------- 5 files changed, 124 insertions(+), 35 deletions(-) create mode 100644 src/generators/gctx.ml diff --git a/src/compiler/generate.ml b/src/compiler/generate.ml index 1cbcd6df139..b3d724b439d 100644 --- a/src/compiler/generate.ml +++ b/src/compiler/generate.ml @@ -80,7 +80,9 @@ let generate ctx tctx ext actx = Gencs.generate,"cs" | Java -> if Common.defined com Jvm then - Genjvm.generate actx.jvm_flag,"java" + (fun com -> + Genjvm.generate actx.jvm_flag (Common.to_gctx com) + ),"java" else Genjava.generate,"java" | Python -> diff --git a/src/context/common.ml b/src/context/common.ml index b972218db0a..0be89298028 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -412,6 +412,25 @@ type context = { memory_marker : float array; } +let to_gctx com = { + Gctx.platform = com.platform; + defines = com.defines; + basic = com.basic; + debug = com.debug; + file = com.file; + features = com.features; + modules = com.modules; + main = com.main; + types = com.types; + resources = com.resources; + main_class = com.main_class; + native_libs = match com.platform with + | Java -> (com.native_libs.java_libs :> NativeLibraries.native_library_base list) + | Cs -> (com.native_libs.net_libs :> NativeLibraries.native_library_base list) + | Flash -> (com.native_libs.swf_libs :> NativeLibraries.native_library_base list) + | _ -> []; +} + let enter_stage com stage = (* print_endline (Printf.sprintf "Entering stage %s" (s_compiler_stage stage)); *) com.stage <- stage diff --git a/src/context/nativeLibraries.ml b/src/context/nativeLibraries.ml index 0ee95517450..c0769b827b6 100644 --- a/src/context/nativeLibraries.ml +++ b/src/context/nativeLibraries.ml @@ -23,7 +23,7 @@ type native_lib_flags = | FlagIsStd | FlagIsExtern -class virtual ['a,'data] native_library (name : string) (file_path : string) = object(self) +class virtual native_library_base (name : string) (file_path : string) = object(self) val mutable flags : native_lib_flags list = [] method add_flag flag = flags <- flag :: flags @@ -31,6 +31,10 @@ class virtual ['a,'data] native_library (name : string) (file_path : string) = o method get_name = name method get_file_path = file_path +end + +class virtual ['a,'data] native_library (name : string) (file_path : string) = object(self) + inherit native_library_base name file_path method virtual build : path -> pos -> Ast.package option method virtual close : unit diff --git a/src/generators/gctx.ml b/src/generators/gctx.ml new file mode 100644 index 00000000000..62cd56b59f2 --- /dev/null +++ b/src/generators/gctx.ml @@ -0,0 +1,65 @@ +open Globals +open Type + +type t = { + platform : platform; + defines : Define.define; + basic : basic_types; + debug : bool; + file : string; + features : (string,bool) Hashtbl.t; + modules : Type.module_def list; + main : Type.texpr option; + types : Type.module_type list; + resources : (string,string) Hashtbl.t; + main_class : path option; + native_libs : NativeLibraries.native_library_base list; +} + +let raw_defined gctx v = + Define.raw_defined gctx.defines v + +let has_dce gctx = + try + Define.defined_value gctx.defines Define.Dce <> "no" +with Not_found -> + false + +let rec has_feature gctx f = + try + Hashtbl.find gctx.features f + with Not_found -> + if gctx.types = [] then not (has_dce gctx) else + match List.rev (ExtString.String.nsplit f ".") with + | [] -> die "" __LOC__ + | [cl] -> has_feature gctx (cl ^ ".*") + | field :: cl :: pack -> + let r = (try + let path = List.rev pack, cl in + (match List.find (fun t -> t_path t = path && not (Meta.has Meta.RealPath (t_infos t).mt_meta)) gctx.types with + | t when field = "*" -> + not (has_dce gctx) || + (match t with TAbstractDecl a -> Meta.has Meta.ValueUsed a.a_meta | _ -> Meta.has Meta.Used (t_infos t).mt_meta) + | TClassDecl c when (has_class_flag c CExtern) && (gctx.platform <> Js || cl <> "Array" && cl <> "Math") -> + not (has_dce gctx) || Meta.has Meta.Used (try PMap.find field c.cl_statics with Not_found -> PMap.find field c.cl_fields).cf_meta + | TClassDecl c -> + PMap.exists field c.cl_statics || PMap.exists field c.cl_fields + | _ -> + false) + with Not_found -> + false + ) in + Hashtbl.add gctx.features f r; + r + +let get_entry_point gctx = + Option.map (fun path -> + let m = List.find (fun m -> m.m_path = path) gctx.modules in + let c = + match m.m_statics with + | Some c when (PMap.mem "main" c.cl_statics) -> c + | _ -> Option.get (ExtList.List.find_map (fun t -> match t with TClassDecl c when c.cl_path = path -> Some c | _ -> None) m.m_types) + in + let e = Option.get gctx.main in (* must be present at this point *) + (snd path, c, e) + ) gctx.main_class \ No newline at end of file diff --git a/src/generators/genjvm.ml b/src/generators/genjvm.ml index 657c594be02..14b46961062 100644 --- a/src/generators/genjvm.ml +++ b/src/generators/genjvm.ml @@ -19,7 +19,7 @@ open Globals open Ast -open Common +open Gctx open Type open Path open JvmGlobals @@ -58,7 +58,7 @@ end (* Haxe *) type generation_context = { - com : Common.context; + gctx : Gctx.t; out : jvm_output; t_runtime_exception : Type.t; entry_point : (tclass * texpr) option; @@ -505,7 +505,6 @@ class texpr_to_jvm (jm : JvmMethod.builder) (return_type : jsignature option) = object(self) - val com = gctx.com val code = jm#get_code val pool : JvmConstantPool.constant_pool = jc#get_pool @@ -521,7 +520,7 @@ class texpr_to_jvm method vtype t = jsignature_of_type gctx t - method mknull t = com.basic.tnull (follow t) + method mknull t = gctx.gctx.basic.tnull (follow t) (* locals *) @@ -988,13 +987,13 @@ class texpr_to_jvm store(); let ev = mk (TLocal v) v.v_type null_pos in let el = List.rev_map (fun case -> - let f e' = mk (TBinop(OpEq,ev,e')) com.basic.tbool e'.epos in + let f e' = mk (TBinop(OpEq,ev,e')) gctx.gctx.basic.tbool e'.epos in let e_cond = match case.case_patterns with | [] -> die "" __LOC__ | [e] -> f e | e :: el -> List.fold_left (fun eacc e -> - mk (TBinop(OpBoolOr,eacc,f e)) com.basic.tbool e.epos + mk (TBinop(OpBoolOr,eacc,f e)) gctx.gctx.basic.tbool e.epos ) (f e) el in (e_cond,case.case_expr) @@ -2109,7 +2108,7 @@ class texpr_to_jvm | TParenthesis e1 | TMeta(_,e1) -> self#texpr ret e1 | TFor(v,e1,e2) -> - self#texpr ret (Texpr.for_remap com.basic v e1 e2 e.epos) + self#texpr ret (Texpr.for_remap gctx.gctx.basic v e1 e2 e.epos) | TEnumIndex e1 -> self#texpr rvalue_any e1; jm#invokevirtual java_enum_path "ordinal" (method_sig [] (Some TInt)) @@ -2560,9 +2559,9 @@ class tclass_to_jvm gctx c = object(self) | None -> if c.cl_path = (["haxe"],"Resource") && cf.cf_name = "content" then begin let el = Hashtbl.fold (fun name _ acc -> - Texpr.Builder.make_string gctx.com.basic name null_pos :: acc - ) gctx.com.resources [] in - let e = mk (TArrayDecl el) (gctx.com.basic.tarray gctx.com.basic.tstring) null_pos in + Texpr.Builder.make_string gctx.gctx.basic name null_pos :: acc + ) gctx.gctx.resources [] in + let e = mk (TArrayDecl el) (gctx.gctx.basic.tarray gctx.gctx.basic.tstring) null_pos in default e; end; | Some e when mtype <> MStatic -> @@ -2603,7 +2602,7 @@ class tclass_to_jvm gctx c = object(self) let jsig = method_sig [array_sig string_sig] None in let jm = jc#spawn_method "main" jsig [MPublic;MStatic] in let _,load,_ = jm#add_local "args" (TArray(string_sig,None)) VarArgument in - if has_feature gctx.com "haxe.root.Sys.args" then begin + if has_feature gctx.gctx "haxe.root.Sys.args" then begin load(); jm#putstatic (["haxe";"root"],"Sys") "_args" (TArray(string_sig,None)) end; @@ -2838,7 +2837,7 @@ let generate_enum gctx en = jm_values#new_native_array (object_path_sig jc_enum#get_this_path) fl; jm_values#return; (* Add __meta__ TODO: do this via annotations instead? *) - begin match Texpr.build_metadata gctx.com.basic (TEnumDecl en) with + begin match Texpr.build_metadata gctx.gctx.basic (TEnumDecl en) with | None -> () | Some e -> @@ -3000,7 +2999,7 @@ module Preprocessor = struct | _ -> () ) m.m_types - ) gctx.com.modules; + ) gctx.gctx.modules; (* preprocess classes *) List.iter (fun mt -> match mt with @@ -3008,24 +3007,24 @@ module Preprocessor = struct if not (has_class_flag c CInterface) then gctx.preprocessor#preprocess_class c else check_single_method_interface gctx c; | _ -> () - ) gctx.com.types; + ) gctx.gctx.types; (* find typedef-interface implementations *) List.iter (fun mt -> match mt with | TClassDecl c when not (has_class_flag c CInterface) && not (has_class_flag c CExtern) -> gctx.typedef_interfaces#process_class c; | _ -> () - ) gctx.com.types + ) gctx.gctx.types end -let generate jvm_flag com = - let path = FilePath.parse com.file in - let jar_name,entry_point = match get_entry_point com with +let generate jvm_flag gctx = + let path = FilePath.parse gctx.file in + let jar_name,entry_point = match get_entry_point gctx with | Some (jarname,cl,expr) -> jarname, Some (cl,expr) | None -> "jar",None in let compression_level = try - int_of_string (Define.defined_value com.defines Define.JvmCompressionLevel) + int_of_string (Define.defined_value gctx.defines Define.JvmCompressionLevel) with _ -> 6 in @@ -3038,10 +3037,10 @@ let generate jvm_flag com = | Some _ -> begin match path.directory with | None -> - "./",create_jar ("./" ^ com.file) + "./",create_jar ("./" ^ gctx.file) | Some dir -> mkdir_from_path dir; - add_trailing_slash dir,create_jar com.file + add_trailing_slash dir,create_jar gctx.file end | None -> match path.directory with | Some dir -> @@ -3050,25 +3049,25 @@ let generate jvm_flag com = | None -> failwith "Please specify an output file name" end else begin - let jar_name = if com.debug then jar_name ^ "-Debug" else jar_name in - let jar_dir = add_trailing_slash com.file in + let jar_name = if gctx.debug then jar_name ^ "-Debug" else jar_name in + let jar_dir = add_trailing_slash gctx.file in let jar_path = Printf.sprintf "%s%s.jar" jar_dir jar_name in jar_dir,create_jar jar_path end in let anon_identification = new tanon_identification haxe_dynamic_object_path in let dynamic_level = try - int_of_string (Define.defined_value com.defines Define.JvmDynamicLevel) + int_of_string (Define.defined_value gctx.defines Define.JvmDynamicLevel) with _ -> 1 in if dynamic_level < 0 || dynamic_level > 2 then failwith "Invalid value for -D jvm.dynamic-level: Must be >=0 and <= 2"; let gctx = { - com = com; + gctx = gctx; out = out; - t_runtime_exception = TInst(resolve_class com (["java";"lang"],"RuntimeException"),[]); + t_runtime_exception = TInst(resolve_class gctx (["java";"lang"],"RuntimeException"),[]); entry_point = entry_point; - t_exception = TInst(resolve_class com (["java";"lang"],"Exception"),[]); - t_throwable = TInst(resolve_class com (["java";"lang"],"Throwable"),[]); + t_exception = TInst(resolve_class gctx (["java";"lang"],"Exception"),[]); + t_throwable = TInst(resolve_class gctx (["java";"lang"],"Throwable"),[]); anon_identification = anon_identification; preprocessor = Obj.magic (); typedef_interfaces = Obj.magic (); @@ -3078,12 +3077,12 @@ let generate jvm_flag com = default_export_config = { export_debug = true; }; - detail_times = Common.raw_defined com "jvm_times"; + detail_times = Gctx.raw_defined gctx "jvm_times"; timer = new Timer.timer ["generate";"java"]; jar_compression_level = compression_level; dynamic_level = dynamic_level; } in - gctx.preprocessor <- new preprocessor com.basic (jsignature_of_type gctx); + gctx.preprocessor <- new preprocessor gctx.gctx.basic (jsignature_of_type gctx); gctx.typedef_interfaces <- new typedef_interfaces gctx.preprocessor#get_infos anon_identification; gctx.typedef_interfaces#add_interface_rewrite (["haxe";"root"],"Iterator") (["java";"util"],"Iterator") true; let class_paths = ExtList.List.filter_map (fun java_lib -> @@ -3100,13 +3099,13 @@ let generate jvm_flag com = close_out ch_out; Some (Printf.sprintf "lib/%s \n" name) end - ) com.native_libs.java_libs in + ) gctx.gctx.native_libs in Hashtbl.iter (fun name v -> let filename = StringHelper.escape_res_name name ['/';'-'] in gctx.out#add_entry v filename; - ) com.resources; + ) gctx.gctx.resources; let generate_real_types () = - List.iter (generate_module_type gctx) com.types; + List.iter (generate_module_type gctx) gctx.gctx.types; in let generate_typed_interfaces () = Hashtbl.iter (fun _ c -> generate_module_type gctx (TClassDecl c)) gctx.typedef_interfaces#get_interfaces;