diff --git a/src/compiler/args.ml b/src/compiler/args.ml index 4b6a17841e1..e708f011e55 100644 --- a/src/compiler/args.ml +++ b/src/compiler/args.ml @@ -48,6 +48,7 @@ let parse_args com = let actx = { classes = [([],"Std")]; xml_out = None; + hxb_out = None; json_out = None; cmds = []; config_macros = []; @@ -125,6 +126,9 @@ let parse_args com = ("Compilation",["-p";"--class-path"],["-cp"],Arg.String (fun path -> com.class_path <- Path.add_trailing_slash path :: com.class_path ),"","add a directory to find source files"); + ("Compilation",["--binary-class-path"],["-bcp"],Arg.String (fun path -> + com.binary_class_path <- Path.add_trailing_slash path :: com.binary_class_path + ),"","add a directory to find binary source files"); ("Compilation",["-m";"--main"],["-main"],Arg.String (fun cl -> if com.main_class <> None then raise (Arg.Bad "Multiple --main classes specified"); let cpath = Path.parse_type_path cl in @@ -266,6 +270,9 @@ let parse_args com = ("Services",["--json"],[],Arg.String (fun file -> actx.json_out <- Some file ),"","generate JSON types description"); + ("Services",["--hxb"],[], Arg.String (fun dir -> + actx.hxb_out <- Some dir; + ),"", "generate haxe binary representation in target directory"); ("Optimization",["--no-output"],[], Arg.Unit (fun() -> actx.no_output <- true),"","compiles but does not generate any file"); ("Debug",["--times"],[], Arg.Unit (fun() -> Timer.measure_times := true),"","measure compilation times"); ("Optimization",["--no-inline"],[],Arg.Unit (fun () -> diff --git a/src/compiler/compilationContext.ml b/src/compiler/compilationContext.ml index 0e18bce18d1..f15acd9c2ac 100644 --- a/src/compiler/compilationContext.ml +++ b/src/compiler/compilationContext.ml @@ -10,6 +10,7 @@ type server_mode = type arg_context = { mutable classes : Globals.path list; mutable xml_out : string option; + mutable hxb_out : string option; mutable json_out : string option; mutable cmds : string list; mutable config_macros : string list; @@ -45,6 +46,7 @@ and compilation_context = { type compilation_callbacks = { before_anything : compilation_context -> unit; after_target_init : compilation_context -> unit; + after_save : compilation_context -> unit; after_compilation : compilation_context -> unit; } diff --git a/src/compiler/compiler.ml b/src/compiler/compiler.ml index ceb60f839a0..fd3bdbf5d0d 100644 --- a/src/compiler/compiler.ml +++ b/src/compiler/compiler.ml @@ -365,6 +365,12 @@ let compile ctx actx callbacks = let (tctx,display_file_dot_path) = do_type ctx mctx actx display_file_dot_path macro_cache_enabled in DisplayProcessing.handle_display_after_typing ctx tctx display_file_dot_path; finalize_typing ctx tctx; + com.callbacks#add_after_save (fun () -> + (* TODO use hxb cache for hxb output *) + callbacks.after_save ctx; + Generate.check_hxb_output com actx; + ); + com.callbacks#add_before_save (fun () -> Generate.check_hxb_output com actx); if is_diagnostics com then filter ctx tctx (fun () -> DisplayProcessing.handle_display_after_finalization ctx tctx display_file_dot_path) else begin diff --git a/src/compiler/generate.ml b/src/compiler/generate.ml index 1cbcd6df139..393bb9f67bd 100644 --- a/src/compiler/generate.ml +++ b/src/compiler/generate.ml @@ -1,5 +1,7 @@ open Globals open CompilationContext +open TType +open Tanon_identification let check_auxiliary_output com actx = begin match actx.xml_out with @@ -19,6 +21,64 @@ let check_auxiliary_output com actx = Genjson.generate com.types file end +let export_hxb root m = + match m.m_extra.m_kind with + | MCode | MMacro | MFake -> begin + (* Printf.eprintf "Export module %s\n" (s_type_path m.m_path); *) + let anon_identification = new tanon_identification ([],"") in + let writer = new HxbWriter.hxb_writer anon_identification in + writer#write_module m; + let ch = IO.output_bytes() in + writer#export ch; + let bytes_cp = IO.close_out ch in + let l = (root :: fst m.m_path @ [snd m.m_path]) in + let ch_file = Path.create_file true ".hxb" [] l in + output_bytes ch_file bytes_cp; + close_out ch_file + end + | _ -> () + +let check_hxb_output com actx = + begin match actx.hxb_out with + | None -> () + | Some path -> + (* TODO move somewhere else *) + let clean_files path = + let rec iter_files pack dir path = try + let file = Unix.readdir dir in + + if file <> "." && file <> ".." then begin + let filepath = path ^ "/" ^ file in + if (Unix.stat filepath).st_kind = S_DIR then + let pack = pack @ [file] in + iter_files (pack) (Unix.opendir filepath) filepath; + try Unix.rmdir filepath with Unix.Unix_error (ENOTEMPTY,_,_) -> (); + else + Sys.remove filepath + end; + + iter_files pack dir path + with | End_of_file | Unix.Unix_error _ -> + Unix.closedir dir + in + iter_files [] (Unix.opendir path) path + in + + let export com = + let path = Path.add_trailing_slash (path ^ Path.path_sep ^ (Common.platform_name_macro com)) in + Common.log com ("Generating hxb to " ^ path); + Printf.eprintf "Generating hxb to %s\n" path; + Path.mkdir_from_path path; + clean_files path; + let t = Timer.timer ["generate";"hxb"] in + Printf.eprintf "%d modules, %d types\n" (List.length com.modules) (List.length com.types); + List.iter (export_hxb path) com.modules; + t(); + in + + export com; + Option.may export (com.get_macros()); + end let parse_swf_header ctx h = match ExtString.String.nsplit h ":" with | [width; height; fps] -> diff --git a/src/compiler/hxb/hxbData.ml b/src/compiler/hxb/hxbData.ml new file mode 100644 index 00000000000..c885a61422c --- /dev/null +++ b/src/compiler/hxb/hxbData.ml @@ -0,0 +1,57 @@ +exception HxbFailure of string + +type chunk_kind = + | STRI (* string pool *) + | DOCS (* doc pool *) + | HHDR (* module header *) + | TYPF (* forward types *) + | CLSR (* class reference array *) + | ABSR (* abstract reference array *) + | TPDR (* typedef reference array *) + | ENMR (* enum reference array *) + | CLSD (* class definition *) + | ABSD (* abstract definition *) + | CFLD (* class fields *) + | TPDD (* typedef definition *) + | ENMD (* enum definition *) + | EFLD (* enum fields *) + | HEND (* the end *) + +let string_of_chunk_kind = function + | STRI -> "STRI" + | DOCS -> "DOCS" + | HHDR -> "HHDR" + | TYPF -> "TYPF" + | CLSR -> "CLSR" + | ABSR -> "ABSR" + | TPDR -> "TPDR" + | ENMR -> "ENMR" + | CLSD -> "CLSD" + | ABSD -> "ABSD" + | CFLD -> "CFLD" + | TPDD -> "TPDD" + | ENMD -> "ENMD" + | EFLD -> "EFLD" + | HEND -> "HEND" + +let chunk_kind_of_string = function + | "STRI" -> STRI + | "DOCS" -> DOCS + | "HHDR" -> HHDR + | "TYPF" -> TYPF + | "CLSR" -> CLSR + | "ABSR" -> ABSR + | "TPDR" -> TPDR + | "ENMR" -> ENMR + | "CLSD" -> CLSD + | "ABSD" -> ABSD + | "CFLD" -> CFLD + | "TPDD" -> TPDD + | "ENMD" -> ENMD + | "EFLD" -> EFLD + | "HEND" -> HEND + | name -> raise (HxbFailure ("Invalid chunk name: " ^ name)) + +let error (s : string) = + Printf.eprintf "[error] %s\n" s; + raise (HxbFailure s) diff --git a/src/compiler/hxb/hxbReader.ml b/src/compiler/hxb/hxbReader.ml new file mode 100644 index 00000000000..b7db11693e4 --- /dev/null +++ b/src/compiler/hxb/hxbReader.ml @@ -0,0 +1,1656 @@ +open Globals +open Ast +open Type +open HxbData + +(* Debug utils *) +let no_color = false +let c_reset = if no_color then "" else "\x1b[0m" +let c_bold = if no_color then "" else "\x1b[1m" +let c_dim = if no_color then "" else "\x1b[2m" +let todo = "\x1b[33m[TODO]" ^ c_reset +let todo_error = "\x1b[31m[TODO] error:" ^ c_reset + +let debug_msg msg = + prerr_endline msg + +let print_stacktrace () = + let stack = Printexc.get_callstack 10 in + let lines = Printf.sprintf "%s\n" (Printexc.raw_backtrace_to_string stack) in + match (ExtString.String.split_on_char '\n' lines) with + | (_ :: (_ :: lines)) -> prerr_endline (Printf.sprintf "%s" (ExtString.String.join "\n" lines)) + | _ -> die "" __LOC__ + +class hxb_reader + (* (com : Common.context) *) + (make_module : path -> string -> module_def) + (add_module : module_def -> unit) + (resolve_type : string -> string list -> string -> string -> module_type) + (flush_fields : unit -> unit) += object(self) + + val mutable m = null_module + val mutable ch = IO.input_bytes Bytes.empty + val mutable string_pool = Array.make 0 "" + val mutable doc_pool = Array.make 0 "" + + val mutable classes = Array.make 0 null_class + val mutable abstracts = Array.make 0 null_abstract + val mutable enums = Array.make 0 null_enum + val mutable typedefs = Array.make 0 null_typedef + val mutable anons = Array.make 0 null_tanon + val mutable anon_fields = Array.make 0 null_field + + val vars = Hashtbl.create 0 + val mutable type_type_parameters = Array.make 0 (mk_type_param "" t_dynamic None) + val field_type_parameters = Hashtbl.create 0 + val mutable local_type_parameters = Array.make 0 (mk_type_param "" t_dynamic None) + + method resolve_type sign pack mname tname = + try resolve_type sign pack mname tname with + | Not_found -> error (Printf.sprintf "Cannot resolve type %s" (s_type_path ((pack @ [mname]),tname))) + + val mutable tvoid = None + method get_tvoid = + match tvoid with + | Some tvoid -> tvoid + | None -> + let t = type_of_module_type (self#resolve_type m.m_extra.m_sign [] "StdTypes" "Void") in + tvoid <- Some t; + t + + (* Primitives *) + + method read_u8 = + IO.read_byte ch + + method read_u32 = + IO.read_real_i32 ch + + method read_i16 = + IO.read_i16 ch + + method read_f64 = + IO.read_double ch + + method read_uleb128 = + let b = self#read_u8 in + if b >= 0x80 then + (b land 0x7F) lor ((self#read_uleb128) lsl 7) + else + b + + method read_leb128 = + let rec read acc shift = + let b = self#read_u8 in + let acc = ((b land 0x7F) lsl shift) lor acc in + if b >= 0x80 then + read acc (shift + 7) + else + (b, acc, shift + 7) + in + let last, acc, shift = read 0 0 in + let res = (if (last land 0x40) <> 0 then + acc lor ((lnot 0) lsl shift) + else + acc) in + res + + method read_bool = + self#read_u8 <> 0 + + method read_from_string_pool pool = + let l = self#read_uleb128 in + try pool.(l) with e -> + prerr_endline (Printf.sprintf " Failed getting string #%d" l); + raise e + + method read_string = + self#read_from_string_pool string_pool + + method read_raw_string = + let l = self#read_uleb128 in + Bytes.unsafe_to_string (IO.nread ch l) + + (* Basic compounds *) + + method read_list : 'a . (unit -> 'a) -> 'a list = fun f -> + let l = self#read_uleb128 in + let a = Array.init l (fun _ -> f ()) in + Array.to_list a + + method read_option : 'a . (unit -> 'a) -> 'a option = fun f -> + match self#read_u8 with + | 0 -> + None + | _ -> + Some (f()) + + method read_path = + let pack = self#read_list (fun () -> self#read_string) in + let name = self#read_string in + (pack,name) + + method read_full_path = + let pack = self#read_list (fun () -> self#read_string) in + let mname = self#read_string in + let tname = self#read_string in + (* prerr_endline (Printf.sprintf " Read full path %s" (ExtString.String.join "." (pack @ [mname; tname]))); *) + (pack,mname,tname) + + method read_documentation = + let doc_own = self#read_option (fun () -> + self#read_from_string_pool doc_pool + ) in + let doc_inherited = self#read_list (fun () -> + self#read_from_string_pool doc_pool + ) in + {doc_own;doc_inherited} + + method read_pos = + let file = self#read_string in + let min = self#read_leb128 in + let max = self#read_leb128 in + let pos = { + pfile = file; + pmin = min; + pmax = max; + } in + (* prerr_endline (Printf.sprintf "Read pos: %s" (Printer.s_pos pos)); *) + (* MessageReporting.display_source_at com pos; *) + pos + + method read_metadata_entry : metadata_entry = + let name = self#read_string in + let p = self#read_pos in + let el = self#read_list (fun () -> self#read_expr) in + (Meta.from_string name,el,p) + + method read_metadata = + self#read_list (fun () -> self#read_metadata_entry) + + (* References *) + + method read_class_ref = + let i = self#read_uleb128 in + try classes.(i) with e -> + prerr_endline (Printf.sprintf "[%s] %s reading class ref %i" (s_type_path m.m_path) todo_error i); + raise e + + method read_abstract_ref = + let i = self#read_uleb128 in + try abstracts.(i) with e -> + prerr_endline (Printf.sprintf "[%s] %s reading abstract ref %i" (s_type_path m.m_path) todo_error i); + raise e + + method read_enum_ref = + let i = self#read_uleb128 in + try enums.(i) with e -> + prerr_endline (Printf.sprintf "[%s] %s reading enum ref %i" (s_type_path m.m_path) todo_error i); + raise e + + method read_typedef_ref = + let i = self#read_uleb128 in + try typedefs.(i) with e -> + prerr_endline (Printf.sprintf "[%s] %s reading typedef ref %i" (s_type_path m.m_path) todo_error i); + raise e + + method read_field_ref fields = + let name = self#read_string in + try PMap.find name fields with e -> + prerr_endline (Printf.sprintf "[%s] %s reading field %s" (s_type_path m.m_path) todo_error name); + prerr_endline (Printf.sprintf " Available fields: %s" (PMap.fold (fun f acc -> acc ^ " " ^ f.cf_name) fields "")); + print_stacktrace (); + null_field + + method read_enum_field_ref en = + let name = self#read_string in + try PMap.find name en.e_constrs with e -> + prerr_endline (Printf.sprintf " %s reading enum field ref for %s.%s" todo_error (s_type_path en.e_path) name); + prerr_endline (Printf.sprintf " Available fields: %s" (PMap.fold (fun ef acc -> acc ^ " " ^ ef.ef_name) en.e_constrs "")); + null_enum_field + + method read_anon_ref = + match IO.read_byte ch with + | 0 -> + let index = self#read_uleb128 in + (try anons.(index) with e -> + trace (Printf.sprintf "[%s] %s reading anon (0) ref %i" (s_type_path m.m_path) todo_error index); + raise e + ) + | 1 -> + let index = self#read_uleb128 in + let an = (try anons.(index) with e -> + trace (Printf.sprintf "[%s] %s reading anon (1) ref %i" (s_type_path m.m_path) todo_error index); + trace (Printexc.to_string e); + raise e + ) in + self#read_anon an + | _ -> + assert false + + method read_anon_field_ref = + match IO.read_byte ch with + | 0 -> + let index = self#read_uleb128 in + (try anon_fields.(index) with e -> + prerr_endline (Printf.sprintf "[%s] %s reading anon field (0) ref %i" (s_type_path m.m_path) todo_error index); + raise e + ) + | 1 -> + let index = self#read_uleb128 in + (try begin + let cf = self#read_class_field true in + anon_fields.(index) <- cf; + cf + end with e -> + prerr_endline (Printf.sprintf "[%s] %s reading anon field (1) ref %i" (s_type_path m.m_path) todo_error index); + raise e + ) + | _ -> + assert false + + (* Expr *) + + method get_binop i = match i with + | 0 -> OpAdd + | 1 -> OpMult + | 2 -> OpDiv + | 3 -> OpSub + | 4 -> OpAssign + | 5 -> OpEq + | 6 -> OpNotEq + | 7 -> OpGt + | 8 -> OpGte + | 9 -> OpLt + | 10 -> OpLte + | 11 -> OpAnd + | 12 -> OpOr + | 13 -> OpXor + | 14 -> OpBoolAnd + | 15 -> OpBoolOr + | 16 -> OpShl + | 17 -> OpShr + | 18 -> OpUShr + | 19 -> OpMod + | 20 -> OpInterval + | 21 -> OpArrow + | 22 -> OpIn + | 23 -> OpNullCoal + | _ -> OpAssignOp (self#get_binop (i - 30)) + + method get_unop i = match i with + | 0 -> Increment,Prefix + | 1 -> Decrement,Prefix + | 2 -> Not,Prefix + | 3 -> Neg,Prefix + | 4 -> NegBits,Prefix + | 5 -> Spread,Prefix + | 6 -> Increment,Postfix + | 7 -> Decrement,Postfix + | 8 -> Not,Postfix + | 9 -> Neg,Postfix + | 10 -> NegBits,Postfix + | 11 -> Spread,Postfix + | _ -> assert false + + method read_placed_name = + let s = self#read_string in + let p = self#read_pos in + (s,p) + + method read_type_path = + let pack = self#read_list (fun () -> self#read_string) in + let name = self#read_string in + let tparams = self#read_list (fun () -> self#read_type_param_or_const) in + let tsub = self#read_option (fun () -> self#read_string) in + { + tpackage = pack; + tname = name; + tparams = tparams; + tsub = tsub; + } + + method read_placed_type_path = + let tp = self#read_type_path in + let pfull = self#read_pos in + let ppath = self#read_pos in + { + path = tp; + pos_full = pfull; + pos_path = ppath; + } + + method read_type_param = + let pn = self#read_placed_name in + let ttp = self#read_list (fun () -> self#read_type_param) in + let tho = self#read_option (fun () -> self#read_type_hint) in + let def = self#read_option (fun () -> self#read_type_hint) in + let meta = self#read_metadata in + { + tp_name = pn; + tp_params = ttp; + tp_constraints = tho; + tp_meta = meta; + tp_default = def; + } + + method read_type_param_or_const = + match IO.read_byte ch with + | 0 -> TPType (self#read_type_hint) + | 1 -> TPExpr (self#read_expr) + | _ -> assert false + + method read_func_arg = + let pn = self#read_placed_name in + let b = self#read_bool in + let meta = self#read_metadata in + let tho = self#read_option (fun () -> self#read_type_hint) in + let eo = self#read_option (fun () -> self#read_expr) in + (pn,b,meta,tho,eo) + + method read_func = + let params = self#read_list (fun () -> self#read_type_param) in + let args = self#read_list (fun () -> self#read_func_arg) in + let tho = self#read_option (fun () -> self#read_type_hint) in + let eo = self#read_option (fun () -> self#read_expr) in + { + f_params = params; + f_args = args; + f_type = tho; + f_expr = eo; + } + + method read_complex_type = + match IO.read_byte ch with + | 0 -> CTPath (self#read_placed_type_path) + | 1 -> + let thl = self#read_list (fun () -> self#read_type_hint) in + let th = self#read_type_hint in + CTFunction(thl,th) + | 2 -> CTAnonymous (self#read_list (fun () -> self#read_cfield)) + | 3 -> CTParent (self#read_type_hint) + | 4 -> + let ptp = self#read_list (fun () -> self#read_placed_type_path) in + let cffl = self#read_list (fun () -> self#read_cfield) in + CTExtend(ptp,cffl) + | 5 -> CTOptional (self#read_type_hint) + | 6 -> + let pn = self#read_placed_name in + let th = self#read_type_hint in + CTNamed(pn,th) + | 7 -> CTIntersection (self#read_list (fun () -> self#read_type_hint)) + | _ -> assert false + + method read_type_hint = + let ct = self#read_complex_type in + let p = self#read_pos in + (ct,p) + + method read_access = + match self#read_u8 with + | 0 -> APublic + | 1 -> APrivate + | 2 -> AStatic + | 3 -> AOverride + | 4 -> ADynamic + | 5 -> AInline + | 6 -> AMacro + | 7 -> AFinal + | 8 -> AExtern + | 9 -> AAbstract + | 10 -> AOverload + | 11 -> AEnum + | _ -> assert false + + method read_placed_access = + let ac = self#read_access in + let p = self#read_pos in + (ac,p) + + method read_cfield_kind = + match self#read_u8 with + | 0 -> + let tho = self#read_option (fun () -> self#read_type_hint) in + let eo = self#read_option (fun () -> self#read_expr) in + FVar(tho,eo) + | 1 -> FFun (self#read_func) + | 2 -> + let pn1 = self#read_placed_name in + let pn2 = self#read_placed_name in + let tho = self#read_option (fun () -> self#read_type_hint) in + let eo = self#read_option (fun () -> self#read_expr) in + FProp(pn1,pn2,tho,eo) + | _ -> assert false + + method read_cfield = + let pn = self#read_placed_name in + let doc = self#read_option (fun () -> self#read_documentation) in + let pos = self#read_pos in + let meta = self#read_metadata in + let access = self#read_list (fun () -> self#read_placed_access) in + let kind = self#read_cfield_kind in + { + cff_name = pn; + cff_doc = doc; + cff_pos = pos; + cff_meta = meta; + cff_access = access; + cff_kind = kind; + } + + method read_expr = + let p = self#read_pos in + let e = match self#read_u8 with + | 0 -> + let s = self#read_string in + let suffix = self#read_option (fun () -> self#read_string) in + EConst (Int (s, suffix)) + | 1 -> + let s = self#read_string in + let suffix = self#read_option (fun () -> self#read_string) in + EConst (Float (s, suffix)) + | 2 -> + let s = self#read_string in + let qs = begin match self#read_u8 with + | 0 -> SDoubleQuotes + | 1 -> SSingleQuotes + | _ -> assert false + end in + EConst (String (s,qs)) + | 3 -> + EConst (Ident (self#read_string)) + | 4 -> + let s1 = self#read_string in + let s2 = self#read_string in + EConst (Regexp(s1,s2)) + | 5 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + EArray(e1,e2) + | 6 -> + let op = self#get_binop (self#read_u8) in + let e1 = self#read_expr in + let e2 = self#read_expr in + EBinop(op,e1,e2) + | 7 -> + let e = self#read_expr in + let s = self#read_string in + let kind = begin match self#read_u8 with + | 0 -> EFNormal + | 1 -> EFSafe + | _ -> assert false + end in + EField(e,s,kind) + | 8 -> + EParenthesis (self#read_expr) + | 9 -> + let fields = self#read_list (fun () -> + let n = self#read_string in + let p = self#read_pos in + let qs = begin match self#read_u8 with + | 0 -> NoQuotes + | 1 -> DoubleQuotes + | _ -> assert false + end in + let e = self#read_expr in + ((n,p,qs),e) + ) in + EObjectDecl fields + | 10 -> + let el = self#read_list (fun () -> self#read_expr) in + EArrayDecl el + | 11 -> + let e = self#read_expr in + let el = self#read_list (fun () -> self#read_expr) in + ECall(e,el) + | 12 -> + let ptp = self#read_placed_type_path in + let el = self#read_list (fun () -> self#read_expr) in + ENew(ptp,el) + | 13 -> + let (op,flag) = self#get_unop (self#read_u8) in + let e = self#read_expr in + EUnop(op,flag,e) + | 14 -> + let vl = self#read_list (fun () -> + let name = self#read_placed_name in + let final = self#read_bool in + let static = self#read_bool in + let t = self#read_option (fun () -> self#read_type_hint) in + let expr = self#read_option (fun () -> self#read_expr) in + let meta = self#read_metadata in + { + ev_name = name; + ev_final = final; + ev_static = static; + ev_type = t; + ev_expr = expr; + ev_meta = meta; + } + ) in + EVars vl + | 15 -> + let fk = begin match self#read_u8 with + | 0 -> FKAnonymous + | 1 -> + let pn = self#read_placed_name in + let b = self#read_bool in + FKNamed(pn,b) + | 2 -> FKArrow + | _ -> assert false end in + let f = self#read_func in + EFunction(fk,f) + | 16 -> + EBlock (self#read_list (fun () -> self#read_expr)) + | 17 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + EFor(e1,e2) + | 18 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + EIf(e1,e2,None) + | 19 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + let e3 = self#read_expr in + EIf(e1,e2,Some e3) + | 20 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + EWhile(e1,e2,NormalWhile) + | 21 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + EWhile(e1,e2,DoWhile) + | 22 -> + let e1 = self#read_expr in + let cases = self#read_list (fun () -> + let el = self#read_list (fun () -> self#read_expr) in + let eg = self#read_option (fun () -> self#read_expr) in + let eo = self#read_option (fun () -> self#read_expr) in + let p = self#read_pos in + (el,eg,eo,p) + ) in + let def = self#read_option (fun () -> + let eo = self#read_option (fun () -> self#read_expr) in + let p = self#read_pos in + (eo,p) + ) in + ESwitch(e1,cases,def) + | 23 -> + let e1 = self#read_expr in + let catches = self#read_list (fun () -> + let pn = self#read_placed_name in + let th = self#read_option (fun () -> self#read_type_hint) in + let e = self#read_expr in + let p = self#read_pos in + (pn,th,e,p) + ) in + ETry(e1,catches) + | 24 -> EReturn None + | 25 -> EReturn (Some (self#read_expr)) + | 26 -> EBreak + | 27 -> EContinue + | 28 -> EUntyped (self#read_expr) + | 29 -> EThrow (self#read_expr) + | 30 -> ECast ((self#read_expr),None) + | 31 -> + let e1 = self#read_expr in + let th = self#read_type_hint in + ECast(e1,Some th) + | 32 -> + let e1 = self#read_expr in + let th = self#read_type_hint in + EIs(e1,th) + | 33 -> + let e1 = self#read_expr in + let dk = begin match self#read_u8 with + | 0 -> DKCall + | 1 -> DKDot + | 2 -> DKStructure + | 3 -> DKMarked + | 4 -> DKPattern (self#read_bool) + | _ -> assert false end in + EDisplay(e1,dk) + | 34 -> + let e1 = self#read_expr in + let e2 = self#read_expr in + let e3 = self#read_expr in + ETernary(e1,e2,e3) + | 35 -> + let e1 = self#read_expr in + let th = self#read_type_hint in + ECheckType(e1,th) + | 36 -> + let m = self#read_metadata_entry in + let e = self#read_expr in + EMeta(m,e) + | _ -> assert false + in + (e,p) + + (* Type instances *) + + method read_type_parameter_ref = function + | 5 -> + let p = self#read_path in + (try + let ttp = Hashtbl.find field_type_parameters p in + (match follow ttp.ttp_type with + | TInst(c, _) -> + if c.cl_path <> p then begin + Printf.eprintf "Error loading ftp: %s <> %s\n" (s_type_path c.cl_path) (s_type_path p); + die "" __LOC__ + end + | _ -> die "" __LOC__ + ); + ttp.ttp_type + with _ -> + Printf.eprintf "Error loading ftp for %s\n" (s_type_path p); + die "" __LOC__ + ) + | 6 -> + let i = self#read_uleb128 in + (type_type_parameters.(i)).ttp_type + | 7 -> + let k = self#read_uleb128 in + local_type_parameters.(k).ttp_type + | _ -> + die "" __LOC__ + + method read_type_instance = + let kind = self#read_u8 in + (* prerr_endline (Printf.sprintf " Read type instance %d" kind); *) + + match kind with + | 0 -> + (* prerr_endline (Printf.sprintf " %s identity" todo); *) + mk_mono() (* TODO: identity *) + | 1 -> + (* prerr_endline (Printf.sprintf " %s TMono Some" todo); *) + let t = self#read_type_instance in + let tmono = !monomorph_create_ref () in (* TODO identity *) + tmono.tm_type <- Some t; + TMono tmono; + | 5 | 6 | 7 -> self#read_type_parameter_ref kind + | 8 -> + let e = self#read_expr in + TInst({null_class with cl_kind = KExpr e}, []) + | 10 -> + TInst(self#read_class_ref,[]) + | 11 -> + TEnum(self#read_enum_ref,[]) + | 12 -> + let tp = self#read_path in + begin match self#read_u8 with + | 0 -> TType({null_typedef with t_type = (mk_anon (ref Closed)); t_path = tp },[]) + | 1 -> TType({null_typedef with t_type = (TAnon self#read_anon_ref); t_path = tp },[]) + | 4 -> + let c = self#read_class_ref in + let t_tmp = class_module_type c in + TType(t_tmp,[]) + | 5 -> + let e = self#read_enum_ref in + let t_tmp = enum_module_type e.e_module e.e_path e.e_pos in + TType(t_tmp,[]) + | 6 -> + let a = self#read_abstract_ref in + let t_tmp = abstract_module_type a [] in + TType(t_tmp,[]) + | _ -> + TType(self#read_typedef_ref,[]) + end + | 13 -> + TAbstract(self#read_abstract_ref,[]) + | 14 -> + let c = self#read_class_ref in + let tl = self#read_types in + TInst(c,tl) + | 15 -> + let e = self#read_enum_ref in + let tl = self#read_types in + TEnum(e,tl) + | 16 -> + let tp = self#read_path in + begin match self#read_u8 with + | 0 -> + let an = mk_anon (ref Closed) in + let tl = self#read_types in + let td = { null_typedef with t_type = an; t_path = tp } in + TType(td,tl) + | 1 -> + let an = TAnon self#read_anon_ref in + let tl = self#read_types in + let td = { null_typedef with t_type = an; t_path = tp } in + TType(td,tl) + | 4 -> + let c = self#read_class_ref in + let t_tmp = class_module_type c in + TType(t_tmp,[]) + | 5 -> + let e = self#read_enum_ref in + let t_tmp = enum_module_type e.e_module e.e_path e.e_pos in + TType(t_tmp,[]) + | 6 -> + let a = self#read_abstract_ref in + let t_tmp = abstract_module_type a [] in + TType(t_tmp,[]) + (* TODO: does this help with anything? *) + (* | 2 -> *) + (* let t = self#read_type_instance in *) + (* let tl = self#read_types in *) + (* let tmono = !monomorph_create_ref () in (1* TODO identity *1) *) + (* tmono.tm_type <- Some t; *) + (* let td = { null_typedef with t_type = TMono tmono; t_path = tp } in *) + (* TType(td,tl) *) + | _ -> + let t = self#read_type_instance in + let tl = self#read_types in + let td = { null_typedef with t_type = t; t_path = tp } in + (* let td = { null_typedef with t_type = t; t_path = ([], "708") } in *) + TType(td,tl) + end + | 17 -> + let a = self#read_abstract_ref in + let tl = self#read_types in + TAbstract(a,tl) + | 30 -> TFun([],self#get_tvoid) + | 31 -> + let f () = + let name = self#read_string in + (* prerr_endline (Printf.sprintf " Read type instance for %s" name); *) + let opt = self#read_bool in + let t = self#read_type_instance in + (name,opt,t) + in + let args = self#read_list f in + TFun(args,self#get_tvoid) + | 32 -> + let f () = + let name = self#read_string in + (* prerr_endline (Printf.sprintf " Read type instance for %s" name); *) + let opt = self#read_bool in + let t = self#read_type_instance in + (name,opt,t) + in + let args = self#read_list f in + (* prerr_endline (Printf.sprintf " Read type instance for TFun"); *) + let ret = self#read_type_instance in + TFun(args,ret) + | 33 -> + let t = self#read_type_instance in + (* TLazy (ref (LAvailable t)) *) + t + | 40 -> + t_dynamic + | 41 -> + TDynamic (Some self#read_type_instance) + | 50 -> + let empty = self#read_bool in + if empty then mk_anon (ref Closed) + else TAnon self#read_anon_ref + | 51 -> TAnon self#read_anon_ref + | i -> error (Printf.sprintf "Bad type instance id: %i" i) + + method read_types = + self#read_list (fun () -> self#read_type_instance) + + (* Fields *) + + method add_field_type_parameters a = Array.iter (fun ttp -> + (match follow ttp.ttp_type with + | TInst(c,_) -> Hashtbl.add field_type_parameters c.cl_path ttp + | _ -> die "" __LOC__ + ) + ) a + + method read_type_parameters (path : path) (f : typed_type_param array -> unit) = + let l = self#read_uleb128 in + let a = Array.init l (fun _ -> + let name = self#read_string in + let pos = self#read_pos in + (* prerr_endline (Printf.sprintf " Read ttp pos for %s: %s" name (Printer.s_pos pos)); *) + (* prerr_endline (Printf.sprintf " - Path was %s" (s_type_path path)); *) + let c = mk_class m (fst path @ [snd path],name) pos pos in + mk_type_param name (TInst(c,[])) None + ) in + f a; + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let tl1 = self#read_types in + let tl2 = self#read_types in + let meta = self#read_metadata in + begin match a.(i) with + | {ttp_type = TInst(c,_)} as ttp -> + c.cl_kind <- KTypeParameter tl1; + c.cl_meta <- meta; + a.(i) <- {ttp with ttp_type = (TInst(c,tl2))} + | _ -> + die "" __LOC__ + end; + done; + + method read_field_kind = match self#read_u8 with + | 0 -> Method MethNormal + | 1 -> Method MethInline + | 2 -> Method MethDynamic + | 3 -> Method MethMacro + | 10 -> Var {v_read = AccNormal;v_write = AccNormal} + | 11 -> Var {v_read = AccNormal;v_write = AccNo} + | 12 -> Var {v_read = AccNormal;v_write = AccNever} + | 13 -> Var {v_read = AccNormal;v_write = AccCtor} + | 14 -> Var {v_read = AccNormal;v_write = AccCall} + | 20 -> Var {v_read = AccInline;v_write = AccNever} + | 30 -> Var {v_read = AccCall;v_write = AccNormal} + | 31 -> Var {v_read = AccCall;v_write = AccNo} + | 32 -> Var {v_read = AccCall;v_write = AccNever} + | 33 -> Var {v_read = AccCall;v_write = AccCtor} + | 34 -> Var {v_read = AccCall;v_write = AccCall} + | 100 -> + let f = function + | 0 -> AccNormal + | 1 -> AccNo + | 2 -> AccNever + | 3 -> AccCtor + | 4 -> AccCall + | 5 -> AccInline + | 6 -> + let s = self#read_string in + let so = self#read_option (fun () -> self#read_string) in + AccRequire(s,so) + | i -> + error (Printf.sprintf "Bad accessor kind: %i" i) + in + let r = f self#read_u8 in + let w = f self#read_u8 in + Var {v_read = r;v_write = w} + | i -> + error (Printf.sprintf "Bad field kind: %i" i) + + method read_tfunction_arg = + let v = self#read_var in + let cto = self#read_option (fun () -> self#read_texpr) in + (v,cto) + + method read_tfunction = + let args = self#read_list (fun () -> self#read_tfunction_arg) in + let r = self#read_type_instance in + let e = self#read_texpr in + { + tf_args = args; + tf_type = r; + tf_expr = e; + } + + method read_var_kind = + match IO.read_byte ch with + | 0 -> VUser TVOLocalVariable + | 1 -> VUser TVOArgument + | 2 -> VUser TVOForVariable + | 3 -> VUser TVOPatternVariable + | 4 -> VUser TVOCatchVariable + | 5 -> VUser TVOLocalFunction + | 6 -> VGenerated + | 7 -> VInlined + | 8 -> VInlinedConstructorVariable + | 9 -> VExtractorVariable + | 10 -> VAbstractThis + | _ -> assert false + + method read_var = + let id = IO.read_i32 ch in + let name = self#read_string in + let extra = self#read_option (fun () -> + let params = self#read_list (fun () -> + let i = self#read_uleb128 in + local_type_parameters.(i) + ) in + let vexpr = self#read_option (fun () -> self#read_texpr) in + { + v_params = params; + v_expr = vexpr; + }; + ) in + let t = self#read_type_instance in + let kind = self#read_var_kind in + let flags = IO.read_i32 ch in + let meta = self#read_metadata in + let pos = self#read_pos in + let v = { + v_id = id; + v_name = name; + v_type = t; + v_kind = kind; + v_meta = meta; + v_pos = pos; + v_extra = extra; + v_flags = flags; + } in + Hashtbl.add vars id v; + v + + method read_texpr = + let t = self#read_type_instance in + let pos = self#read_pos in + + let i = IO.read_byte ch in + (* prerr_endline (Printf.sprintf " -- texpr [%d] --" i); *) + let e = match i with + (* values 0-19 *) + | 0 -> TConst TNull + | 1 -> TConst TThis + | 2 -> TConst TSuper + | 3 -> TConst (TBool false) + | 4 -> TConst (TBool true) + | 5 -> TConst (TInt (IO.read_real_i32 ch)) + | 6 -> TConst (TFloat self#read_string) + | 7 -> TConst (TString self#read_string) + + (* vars 20-29 *) + | 20 -> TLocal (Hashtbl.find vars (IO.read_i32 ch)) + | 21 -> + let v = self#read_var in + TVar (v,None) + | 22 -> + let v = self#read_var in + let e = self#read_texpr in + TVar (v, Some e) + + (* blocks 30-49 *) + | 30 -> TBlock [] + | 31 | 32 | 33 | 34 | 35 -> + let l = i - 30 in + let el = List.init l (fun _ -> self#read_texpr) in + TBlock el; + | 36 -> + let l = IO.read_byte ch in + let el = List.init l (fun _ -> self#read_texpr) in + TBlock el; + | 37 -> + let l = IO.read_ui16 ch in + let el = List.init l (fun _ -> self#read_texpr) in + TBlock el; + | 38 -> + let l = IO.read_i32 ch in + let el = List.init l (fun _ -> self#read_texpr) in + TBlock el; + + (* function 50-59 *) + | 50 -> TFunction self#read_tfunction + + (* texpr compounds 60-79 *) + | 60 -> + let e1 = self#read_texpr in + let e2 = self#read_texpr in + TArray (e1,e2) + | 61 -> TParenthesis self#read_texpr + | 62 -> TArrayDecl self#read_texpr_list + | 63 -> + let fl = self#read_list (fun () -> + let name = self#read_string in + let p = self#read_pos in + let qs = match IO.read_byte ch with + | 0 -> NoQuotes + | 1 -> DoubleQuotes + | _ -> assert false + in + let e = self#read_texpr in + ((name,p,qs),e) + ) in + TObjectDecl fl + | 64 -> + let e1 = self#read_texpr in + let el = self#read_texpr_list in + TCall(e1,el) + | 65 -> + let m = self#read_metadata_entry in + let e1 = self#read_texpr in + TMeta (m,e1) + + (* branching 80-89 *) + | 80 -> + let e1 = self#read_texpr in + let e2 = self#read_texpr in + TIf(e1,e2,None) + | 81 -> + let e1 = self#read_texpr in + let e2 = self#read_texpr in + let e3 = self#read_texpr in + TIf(e1,e2,Some e3) + | 82 -> + let subject = self#read_texpr in + let cases = self#read_list (fun () -> + let patterns = self#read_texpr_list in + let ec = self#read_texpr in + { case_patterns = patterns; case_expr = ec} + ) in + let def = self#read_option (fun () -> self#read_texpr) in + TSwitch { + switch_subject = subject; + switch_cases = cases; + switch_default = def; + switch_exhaustive = true; + } + | 83 -> + let e1 = self#read_texpr in + let catches = self#read_list (fun () -> + let v = self#read_var in + let e = self#read_texpr in + (v,e) + ) in + TTry(e1,catches) + | 84 -> + let e1 = self#read_texpr in + let e2 = self#read_texpr in + TWhile(e1,e2,NormalWhile) + | 85 -> + let e1 = self#read_texpr in + let e2 = self#read_texpr in + TWhile(e1,e2,DoWhile) + | 86 -> + let v = self#read_var in + let e1 = self#read_texpr in + let e2 = self#read_texpr in + TFor(v,e1,e2) + + (* control flow 90-99 *) + | 90 -> TReturn None + | 91 -> TReturn (Some self#read_texpr) + | 92 -> TContinue + | 93 -> TBreak + | 94 -> TThrow (self#read_texpr) + + (* access 100-119 *) + | 100 -> TEnumIndex (self#read_texpr) + | 101 -> + let e1 = self#read_texpr in + let en = self#read_enum_ref in + let ef = self#read_enum_field_ref en in + let i = IO.read_i32 ch in + TEnumParameter(e1,ef,i) + | 102 -> + let e1 = self#read_texpr in + let c = self#read_class_ref in + let tl = self#read_types in + let cf = self#read_field_ref c.cl_fields in + TField(e1,FInstance(c,tl,cf)) + | 103 -> + let e1 = self#read_texpr in + let c = self#read_class_ref in + let cf = self#read_field_ref c.cl_statics in + TField(e1,FStatic(c,cf)) + | 104 -> + let e1 = self#read_texpr in + let cf = self#read_anon_field_ref in + TField(e1,FAnon(cf)) + | 105 -> + let e1 = self#read_texpr in + let c = self#read_class_ref in + let tl = self#read_types in + let cf = self#read_field_ref c.cl_fields in + TField(e1,FClosure(Some(c,tl),cf)) + | 106 -> + let e1 = self#read_texpr in + let cf = self#read_anon_field_ref in + TField(e1,FClosure(None,cf)) + | 107 -> + let e1 = self#read_texpr in + let en = self#read_enum_ref in + let ef = self#read_enum_field_ref en in + let params = ref [] in + self#read_type_parameters ([],ef.ef_name) (fun a -> params := Array.to_list a); + ef.ef_params <- !params; + TField(e1,FEnum(en,ef)) + | 108 -> + let e1 = self#read_texpr in + let s = self#read_string in + TField(e1,FDynamic s) + + (* module types 120-139 *) + | 120 -> TTypeExpr (TClassDecl self#read_class_ref) + | 121 -> TTypeExpr (TEnumDecl self#read_enum_ref) + | 122 -> TTypeExpr (TAbstractDecl self#read_abstract_ref) + | 123 -> TTypeExpr (TTypeDecl self#read_typedef_ref) + | 124 -> TCast(self#read_texpr,None) + | 125 -> + let e1 = self#read_texpr in + let (pack,mname,tname) = self#read_full_path in + let sign = self#read_string in + let md = self#resolve_type sign pack mname tname in + TCast(e1,Some md) + | 126 -> + let c = self#read_class_ref in + let tl = self#read_types in + let el = self#read_texpr_list in + TNew(c,tl,el) + | 127 -> + (* TODO: this is giga awkward *) + let t = self#read_type_parameter_ref self#read_uleb128 in + let c = match t with | TInst(c,_) -> c | _ -> die "" __LOC__ in + let tl = self#read_types in + let el = self#read_texpr_list in + TNew(c,tl,el) + | 128 -> + (* TODO: this is giga awkward *) + let t = self#read_type_parameter_ref self#read_uleb128 in + let c = match t with | TInst(c,_) -> c | _ -> die "" __LOC__ in + TTypeExpr (TClassDecl c) + + (* unops 140-159 *) + | _ when i >= 140 && i < 160 -> + let (op,flag) = self#get_unop (i - 140) in + let e = self#read_texpr in + TUnop(op,flag,e) + + (* binops 160-219 *) + | _ when i >= 160 && i < 220 -> + let op = self#get_binop (i - 160) in + let e1 = self#read_texpr in + let e2 = self#read_texpr in + TBinop(op,e1,e2) + + (* rest 250-254 *) + | 250 -> TIdent (self#read_string) + + | i -> + prerr_endline (Printf.sprintf " [ERROR] Unhandled texpr %d at:" i); + (* MessageReporting.display_source_at com pos; *) + assert false + in + + (* prerr_endline (Printf.sprintf " Done reading texpr at:"); *) + (* MessageReporting.display_source_at com pos; *) + + { + eexpr = e; + etype = t; + epos = pos; + } + + method read_texpr_list = + let len = IO.read_ui16 ch in + List.init len (fun _ -> self#read_texpr); + + method read_class_field_forward = + let name = self#read_string in + let pos = self#read_pos in + let name_pos = self#read_pos in + let overloads = self#read_list (fun () -> self#read_class_field_forward) in + { null_field with cf_name = name; cf_pos = pos; cf_name_pos = name_pos; cf_overloads = overloads } + + method read_class_field_data (nested : bool) (cf : tclass_field) : unit = + let name = cf.cf_name in + (* prerr_endline (Printf.sprintf " Read class field %s" name); *) + + if not nested then Hashtbl.clear field_type_parameters; + let params = ref [] in + self#read_type_parameters ([],name) (fun a -> + Array.iter (fun ttp -> + params := ttp :: !params; + (match follow ttp.ttp_type with + | TInst(c,_) -> Hashtbl.add field_type_parameters c.cl_path ttp + | _ -> die "" __LOC__ + ) + ) a + ); + self#read_type_parameters ([],name) (fun a -> + local_type_parameters <- if nested then Array.append local_type_parameters a else a + ); + let t = self#read_type_instance in + + let flags = IO.read_i32 ch in + + let doc = self#read_option (fun () -> self#read_documentation) in + let meta = self#read_metadata in + let kind = self#read_field_kind in + + let expr = try + self#read_option (fun () -> self#read_texpr) + with e -> + prerr_endline (Printf.sprintf "Error reading field expr for %s" cf.cf_name); + raise e + in + let expr_unoptimized = self#read_option (fun () -> self#read_texpr) in + + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let f = List.nth cf.cf_overloads i in + self#read_class_field_data true f + done; + + cf.cf_type <- t; + cf.cf_doc <- doc; + cf.cf_meta <- meta; + cf.cf_kind <- kind; + cf.cf_expr <- expr; + cf.cf_expr_unoptimized <- expr_unoptimized; + cf.cf_params <- !params; + cf.cf_flags <- flags; + + method read_class_field (nested : bool) = + let cf = self#read_class_field_forward in + self#read_class_field_data nested cf; + cf + + method read_class_fields (c : tclass) = + begin match c.cl_kind with + | KAbstractImpl a -> + type_type_parameters <- Array.of_list a.a_params + | _ -> + type_type_parameters <- Array.of_list c.cl_params + end; + (* prerr_endline (Printf.sprintf " read class fields with type parameters for %s: %d" (s_type_path c.cl_path) (Array.length type_type_parameters); *) + (* prerr_endline (Printf.sprintf " own class params: %d" (List.length c.cl_params); *) + let _ = self#read_option (fun f -> + self#read_class_field_data false (Option.get c.cl_constructor) + ) in + let f fields = + let name = self#read_string in + let cf = PMap.find name fields in + self#read_class_field_data false cf + in + let _ = self#read_list (fun () -> f c.cl_fields) in + let _ = self#read_list (fun () -> f c.cl_statics) in + c.cl_init <- self#read_option (fun () -> self#read_texpr); + (match c.cl_kind with KModuleFields md -> md.m_statics <- Some c; | _ -> ()); + + method read_enum_fields (e : tenum) = + type_type_parameters <- Array.of_list e.e_params; + ignore(self#read_list (fun () -> + let name = self#read_string in + (* prerr_endline (Printf.sprintf " Read enum field %s" name); *) + let ef = PMap.find name e.e_constrs in + let params = ref [] in + self#read_type_parameters ([],name) (fun a -> + Array.iter (fun ttp -> + params := ttp :: !params; + (match follow ttp.ttp_type with + | TInst(c,_) -> Hashtbl.add field_type_parameters c.cl_path ttp + | _ -> die "" __LOC__ + ) + ) a + ); + ef.ef_params <- !params; + ef.ef_type <- self#read_type_instance; + ef.ef_doc <- self#read_option (fun () -> self#read_documentation); + ef.ef_meta <- self#read_metadata; + )) + + (* Module types *) + + method read_common_module_type (infos : tinfos) = + (* if (snd m.m_path) = "Issue9149" then *) + (* prerr_endline (Printf.sprintf "[%s] Read module type %s" (s_type_path m.m_path) (s_type_path infos.mt_path)); *) + infos.mt_private <- self#read_bool; + infos.mt_doc <- self#read_option (fun () -> self#read_documentation); + infos.mt_meta <- self#read_metadata; + self#read_type_parameters infos.mt_path (fun a -> type_type_parameters <- a); + infos.mt_params <- Array.to_list type_type_parameters; + infos.mt_using <- self#read_list (fun () -> + let c = self#read_class_ref in + let p = self#read_pos in + (c,p) + ) + + method read_class_kind = match self#read_u8 with + | 0 -> KNormal + | 1 -> KTypeParameter self#read_types + | 2 -> KExpr self#read_expr + | 3 -> KGeneric + | 4 -> + let c = self#read_class_ref in + let tl = self#read_types in + KGenericInstance(c,tl) + | 5 -> KMacroType + | 6 -> KGenericBuild (self#read_list (fun () -> self#read_cfield)) + | 7 -> KAbstractImpl self#read_abstract_ref + | 8 -> KModuleFields m + | i -> + error (Printf.sprintf "Invalid class kind id: %i" i) + + method read_class (c : tclass) = + self#read_common_module_type (Obj.magic c); + c.cl_kind <- self#read_class_kind; + c.cl_flags <- (Int32.to_int self#read_u32); + let read_relation () = + let c = self#read_class_ref in + let tl = self#read_types in + (c,tl) + in + c.cl_super <- self#read_option read_relation; + c.cl_implements <- self#read_list read_relation; + c.cl_dynamic <- self#read_option (fun () -> self#read_type_instance); + c.cl_array_access <- self#read_option (fun () -> self#read_type_instance); + + method read_abstract (a : tabstract) = + self#read_common_module_type (Obj.magic a); + a.a_impl <- self#read_option (fun () -> self#read_class_ref); + let impl = match a.a_impl with None -> null_class | Some c -> c in + a.a_this <- self#read_type_instance; + a.a_from <- self#read_list (fun () -> self#read_type_instance); + a.a_from_field <- self#read_list (fun () -> + let name = self#read_string in + self#read_type_parameters ([],name) self#add_field_type_parameters; + let t = self#read_type_instance in + let cf = self#read_field_ref impl.cl_statics in + (t,cf) + ); + a.a_to <- self#read_list (fun () -> self#read_type_instance); + a.a_to_field <- self#read_list (fun () -> + let name = self#read_string in + self#read_type_parameters ([],name) self#add_field_type_parameters; + let t = self#read_type_instance in + let cf = self#read_field_ref impl.cl_statics in + (t,cf) + ); + + a.a_array <- self#read_list (fun () -> self#read_field_ref impl.cl_statics); + a.a_read <- self#read_option (fun () -> self#read_field_ref impl.cl_statics); + a.a_write <- self#read_option (fun () -> self#read_field_ref impl.cl_statics); + a.a_call <- self#read_option (fun () -> self#read_field_ref impl.cl_statics); + a.a_enum <- self#read_bool; + + method read_enum (e : tenum) = + self#read_common_module_type (Obj.magic e); + (match self#read_u8 with + | 0 -> e.e_type.t_type <- (mk_anon (ref Closed)) + | _ -> e.e_type.t_type <- TAnon self#read_anon_ref); + e.e_extern <- self#read_bool; + e.e_names <- self#read_list (fun () -> self#read_string); + + method read_typedef (td : tdef) = + self#read_common_module_type (Obj.magic td); + td.t_type <- self#read_type_instance; + + (* Chunks *) + + method read_string_pool = + let l = self#read_uleb128 in + (* prerr_endline (Printf.sprintf " Read string pool of size %d" l); *) + Array.init l (fun i -> + self#read_raw_string; + ); + + method read_chunk = + let size = Int32.to_int self#read_u32 in + let name = Bytes.unsafe_to_string (IO.nread ch 4) in + let data = IO.nread ch size in + let crc = self#read_u32 in + ignore(crc); (* TODO *) + (* prerr_endline (Printf.sprintf "%s check crc (%d)" todo (Int32.to_int crc)); *) + let kind = chunk_kind_of_string name in + (kind,data) + + method read_cfld = + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let c = classes.(i) in + self#read_class_fields c; + done + + method read_clsd = + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let c = classes.(i) in + self#read_class c; + done + + method read_absd = + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let a = abstracts.(i) in + self#read_abstract a; + done + + method read_enmd = + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let en = enums.(i) in + self#read_enum en; + done + + method read_efld = + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let e = enums.(i) in + self#read_enum_fields e; + done + + method read_anon an = + let old = type_type_parameters in + self#read_type_parameters ([],"") (fun a -> type_type_parameters <- Array.append type_type_parameters a); + let read_fields () = + let fields = self#read_list (fun () -> + let cf = self#read_class_field_forward in + self#read_class_field_data true cf; + cf + ) in + List.iter (fun cf -> an.a_fields <- PMap.add cf.cf_name cf an.a_fields) fields; + in + + begin match self#read_u8 with + | 0 -> + an.a_status := Closed; + read_fields () + | 1 -> + an.a_status := Const; + read_fields () + | 2 -> + an.a_status := Extend self#read_types; + read_fields () + | 3 -> + an.a_status := ClassStatics self#read_class_ref; + | 4 -> + an.a_status := EnumStatics self#read_enum_ref; + read_fields () + | 5 -> + an.a_status := AbstractStatics self#read_abstract_ref; + read_fields () + | _ -> assert false + end; + + type_type_parameters <- old; + an + + method read_tpdd = + let l = self#read_uleb128 in + for i = 0 to l - 1 do + let t = typedefs.(i) in + self#read_typedef t; + done + + method read_clsr = + let l = self#read_uleb128 in + classes <- (Array.init l (fun i -> + let (pack,mname,tname) = self#read_full_path in + let sign = self#read_string in + match self#resolve_type sign pack mname tname with + | TClassDecl c -> + c + | _ -> + error ("Unexpected type where class was expected: " ^ (s_type_path (pack,tname))) + )) + + method read_absr = + let l = self#read_uleb128 in + abstracts <- (Array.init l (fun i -> + let (pack,mname,tname) = self#read_full_path in + let sign = self#read_string in + match self#resolve_type sign pack mname tname with + | TAbstractDecl a -> + a + | _ -> + error ("Unexpected type where abstract was expected: " ^ (s_type_path (pack,tname))) + )) + + method read_enmr = + let l = self#read_uleb128 in + enums <- (Array.init l (fun i -> + let (pack,mname,tname) = self#read_full_path in + let sign = self#read_string in + match self#resolve_type sign pack mname tname with + | TEnumDecl en -> + en + | _ -> + error ("Unexpected type where enum was expected: " ^ (s_type_path (pack,tname))) + )) + + method read_tpdr = + let l = self#read_uleb128 in + typedefs <- (Array.init l (fun i -> + let (pack,mname,tname) = self#read_full_path in + let sign = self#read_string in + match self#resolve_type sign pack mname tname with + | TTypeDecl tpd -> + tpd + | _ -> + error ("Unexpected type where typedef was expected: " ^ (s_type_path (pack,tname))) + )) + + method read_typf = + self#read_list (fun () -> + let kind = self#read_u8 in + (* let path = self#read_path in *) + let (pack,_,tname) = self#read_full_path in + let path = (pack, tname) in + let pos = self#read_pos in + let name_pos = self#read_pos in + let mt = match kind with + | 0 -> + let c = mk_class m path pos name_pos in + classes <- Array.append classes (Array.make 1 c); + + let read_field () = + self#read_class_field_forward; + in + + c.cl_constructor <- self#read_option read_field; + c.cl_ordered_fields <- self#read_list read_field; + c.cl_ordered_statics <- self#read_list read_field; + (* prerr_endline (Printf.sprintf " Forward declare %s with %d fields, %d statics\n" (s_type_path path) (List.length c.cl_ordered_fields) (List.length c.cl_ordered_statics)); *) + List.iter (fun cf -> c.cl_fields <- PMap.add cf.cf_name cf c.cl_fields) c.cl_ordered_fields; + List.iter (fun cf -> c.cl_statics <- PMap.add cf.cf_name cf c.cl_statics) c.cl_ordered_statics; + + TClassDecl c + | 1 -> + let en = mk_enum m path pos name_pos in + enums <- Array.append enums (Array.make 1 en); + + let read_field () = + let name = self#read_string in + let pos = self#read_pos in + let name_pos = self#read_pos in + let index = self#read_u8 in + + { null_enum_field with + ef_name = name; + ef_pos = pos; + ef_name_pos = name_pos; + ef_index = index; + } + in + + List.iter (fun ef -> en.e_constrs <- PMap.add ef.ef_name ef en.e_constrs) (self#read_list read_field); + TEnumDecl en + | 2 -> + let td = mk_typedef m path pos name_pos (mk_mono()) in + typedefs <- Array.append typedefs (Array.make 1 td); + TTypeDecl td + | 3 -> + let a = mk_abstract m path pos name_pos in + abstracts <- Array.append abstracts (Array.make 1 a); + TAbstractDecl a + | _ -> + error ("Invalid type kind: " ^ (string_of_int kind)); + in + mt + ) + + method read_hhdr = + let path = self#read_path in + let file = self#read_string in + (* prerr_endline (Printf.sprintf "Read hxb module %s" (s_type_path path)); *) + + let l = self#read_uleb128 in + (* trace (Printf.sprintf "%d anons available" l); *) + anons <- Array.init l (fun _ -> { a_fields = PMap.empty; a_status = ref Closed }); + + anon_fields <- Array.make (self#read_uleb128) null_field; + make_module path file + + method read (file_ch : IO.input) (debug : bool) (p : pos) = + (* TODO: add magic & version to writer! *) + (* if (Bytes.to_string (IO.nread ch 3)) <> "hxb" then *) + (* raise (HxbFailure "magic"); *) + (* let version = self#read_u8 in *) + (* ignore(version); *) + let rec loop acc = + ch <- file_ch; + let chunk = self#read_chunk in + match fst chunk with + | HEND -> + List.rev acc + | _ -> + loop (chunk :: acc) + in + let chunks = loop [] in + let chunks = List.sort (fun (kind1,_) (kind2,_) -> + (Obj.magic kind1) - (Obj.magic kind2) + ) chunks in + let rec pass_0 chunks = match chunks with + | [] -> + error "Missing HHDR chunk" + | (kind,data) :: chunks -> + ch <- IO.input_bytes data; + match kind with + | STRI -> + string_pool <- self#read_string_pool; + pass_0 chunks + | DOCS -> + doc_pool <- self#read_string_pool; + pass_0 chunks + | HHDR -> + m <- self#read_hhdr; + chunks + | _ -> + error ("Unexpected early chunk: " ^ (string_of_chunk_kind kind)) + in + let chunks = pass_0 chunks in + assert(m != null_module); + (* trace (Printf.sprintf " Reading module %s from hxb" (s_type_path m.m_path)); *) + List.iter (fun (kind,data) -> + (* prerr_endline (Printf.sprintf " Reading chunk %s" (string_of_chunk_kind kind)); *) + ch <- IO.input_bytes data; + match kind with + | TYPF -> + m.m_types <- self#read_typf; + add_module m; + | CLSR -> + self#read_clsr; + | ABSR -> + self#read_absr; + | TPDR -> + self#read_tpdr; + | ENMR -> + self#read_enmr; + | CLSD -> + self#read_clsd; + | ABSD -> + self#read_absd; + | CFLD -> + flush_fields (); + self#read_cfld; + | TPDD -> + self#read_tpdd; + | ENMD -> + self#read_enmd; + | EFLD -> + self#read_efld; + | _ -> + error ("Unexpected late chunk: " ^ (string_of_chunk_kind kind)) + ) chunks; + (* prerr_endline (Printf.sprintf "Done reading hxb module %s" (s_type_path m.m_path)); *) + m +end diff --git a/src/compiler/hxb/hxbWriter.ml b/src/compiler/hxb/hxbWriter.ml new file mode 100644 index 00000000000..b10b239e2b0 --- /dev/null +++ b/src/compiler/hxb/hxbWriter.ml @@ -0,0 +1,1614 @@ +open Globals +open Ast +open Type +open HxbData +open Tanon_identification + +(* Debug utils *) +let no_color = false +let c_reset = if no_color then "" else "\x1b[0m" +let c_bold = if no_color then "" else "\x1b[1m" +let c_dim = if no_color then "" else "\x1b[2m" +let todo = "\x1b[33m[TODO]" ^ c_reset +let todo_error = "\x1b[31m[TODO] error:" ^ c_reset + +type field_source = + | ClassStatic of tclass + | ClassMember of tclass + | CLassConstructor of tclass + +let rec binop_index op = match op with + | OpAdd -> 0 + | OpMult -> 1 + | OpDiv -> 2 + | OpSub -> 3 + | OpAssign -> 4 + | OpEq -> 5 + | OpNotEq -> 6 + | OpGt -> 7 + | OpGte -> 8 + | OpLt -> 9 + | OpLte -> 10 + | OpAnd -> 11 + | OpOr -> 12 + | OpXor -> 13 + | OpBoolAnd -> 14 + | OpBoolOr -> 15 + | OpShl -> 16 + | OpShr -> 17 + | OpUShr -> 18 + | OpMod -> 19 + | OpInterval -> 20 + | OpArrow -> 21 + | OpIn -> 22 + | OpNullCoal -> 23 + | OpAssignOp op -> 30 + binop_index op + +let unop_index op flag = match op,flag with + | Increment,Prefix -> 0 + | Decrement,Prefix -> 1 + | Not,Prefix -> 2 + | Neg,Prefix -> 3 + | NegBits,Prefix -> 4 + | Spread,Prefix -> 5 + | Increment,Postfix -> 6 + | Decrement,Postfix -> 7 + | Not,Postfix -> 8 + | Neg,Postfix -> 9 + | NegBits,Postfix -> 10 + | Spread,Postfix -> 11 + +let debug_msg msg = + prerr_endline msg + +let print_stacktrace () = + let stack = Printexc.get_callstack 10 in + let lines = Printf.sprintf "%s\n" (Printexc.raw_backtrace_to_string stack) in + match (ExtString.String.split_on_char '\n' lines) with + | (_ :: (_ :: lines)) -> debug_msg (Printf.sprintf "%s" (ExtString.String.join "\n" lines)) + | _ -> die "" __LOC__ + +let print_types source tl = + debug_msg (Printf.sprintf "Types from %s:" source); + List.iter (fun t -> debug_msg (Printf.sprintf " %s" (s_type_kind t))) tl + +let print_params source ttp = + debug_msg (Printf.sprintf "Params from %s:" source); + List.iter (fun t -> debug_msg (Printf.sprintf " %s" t.ttp_name)) ttp + +class ['key,'value] pool = object(self) + val lut = Hashtbl.create 0 + val items = DynArray.create () + + method add (key : 'key) (value : 'value) = + let index = DynArray.length items in + DynArray.add items value; + Hashtbl.add lut key index; + index + + method extract (key : 'key) = + DynArray.get items (self#get key) + + method has (key : 'key) = + Hashtbl.mem lut key + + method get (key : 'key) = + Hashtbl.find lut key + + method get_or_add (key : 'key) (value : 'value) = + try + self#get key + with Not_found -> + self#add key value + + method is_empty = + DynArray.length items = 0 + + method to_list = + DynArray.to_list items + + method items = items +end + +class ['key,'value] identity_pool = object(self) + val items = DynArray.create () + + method add (key : 'key) (value : 'value) = + let index = DynArray.length items in + DynArray.add items (key,value); + index + + method get (key : 'key) = + DynArray.index_of (fun (key',_) -> key == key') items + + method to_list = + DynArray.to_list items + + method items = items +end + +class abstract_chunk + (name : string) = +object(self) + val ch = IO.output_bytes() + + (* Primitives *) + + method write_u8 v = + IO.write_byte ch v + + method write_u32 v = + IO.write_real_i32 ch v + + method write_f64 v = + IO.write_double ch v + + method write_uleb128 v = + let b = v land 0x7F in + let rest = v lsr 7 in + if rest = 0 then + self#write_u8 b + else begin + self#write_u8 (b lor 0x80); + self#write_uleb128 rest + end + + method write_leb128 v = + let b = v land 0x7F in + let rest = v asr 7 in + if (rest = 0 && (b land 0x40 = 0)) || (rest = -1 && (b land 0x40 = 0x40)) then + self#write_u8 b + else begin + self#write_u8 (b lor 0x80); + self#write_leb128 rest + end + + method write_byte b = + IO.write_byte ch b; + + method write_bytes b = + self#write_uleb128 (Bytes.length b); + IO.nwrite ch b; + + method write_bool b = + self#write_byte (if b then 1 else 0) + + method write_ui16 i = + IO.write_ui16 ch i; + + method write_i16 i = + IO.write_i16 ch i; + + method write_i32 i = + IO.write_real_i32 ch (Int32.of_int i); + + method write_float f = + IO.write_double ch f + + method export : 'a . 'a IO.output -> unit = fun chex -> + let bytes = IO.close_out ch in + IO.write_real_i32 chex (Int32.of_int (Bytes.length bytes)); + IO.nwrite chex (Bytes.unsafe_of_string name); + IO.nwrite chex bytes; + let crc = Int32.of_int 0x1234567 in (* TODO *) + IO.write_real_i32 chex crc + + method export_data : 'a . 'a IO.output -> unit = fun chex -> + let bytes = IO.close_out ch in + IO.nwrite chex bytes; + + method ch = + ch +end + +class string_pool (kind : chunk_kind) = object(self) + inherit abstract_chunk (string_of_chunk_kind kind) as super + + val pool = new pool + + method get (s : string) = + pool#get_or_add s s + + method is_empty = + pool#is_empty + + method !export : 'a . 'a IO.output -> unit = fun chex -> + self#write_uleb128 (DynArray.length pool#items); + DynArray.iter (fun s -> + let b = Bytes.unsafe_of_string s in + self#write_bytes b; + ) pool#items; + super#export chex +end + +class chunk + (kind : chunk_kind) + (cp : string_pool) += object(self) + inherit abstract_chunk (string_of_chunk_kind kind) + + method write_string s = + self#write_uleb128 (cp#get s); + + method write_list : 'b . 'b list -> ('b -> unit) -> unit = fun l f -> + self#write_uleb128 (List.length l); + List.iter f l; + + method write_option : 'b . 'b option -> ('b -> unit) -> unit = fun v f -> match v with + | None -> + self#write_byte 0 + | Some v -> + self#write_byte 1; + f v + + method kind = + kind +end + +class ['a] hxb_writer + (* (com : Common.context) *) + (anon_id : Type.t Tanon_identification.tanon_identification) += object(self) + + val mutable current_module = null_module + val chunks = DynArray.create () + val cp = new string_pool STRI + val docs = new string_pool DOCS + + val mutable chunk = Obj.magic () + + val classes = new pool + val enums = new pool + val typedefs = new pool + val abstracts = new pool + val anons = new pool + val anon_fields = new identity_pool + + val own_classes = new pool + val own_abstracts = new pool + val own_enums = new pool + val own_typedefs = new pool + + val type_param_lut = new pool + val mutable type_type_parameters = new pool + val mutable field_type_parameters = new pool + val mutable local_type_parameters = new identity_pool + + (* Chunks *) + + method start_chunk (kind : chunk_kind) = + (* debug_msg (Printf.sprintf "Writing chunk %s" (string_of_chunk_kind kind)); *) + let new_chunk = new chunk kind cp in + DynArray.add chunks new_chunk; + chunk <- new_chunk + + method start_temporary_chunk = + let new_chunk = new chunk HEND (* TODO: something else? *) cp in + let old_chunk = chunk in + chunk <- new_chunk; + (fun f -> + chunk <- old_chunk; + f old_chunk new_chunk; + ) + + (* Basic compounds *) + + method write_path (path : path) = + chunk#write_list (fst path) chunk#write_string; + chunk#write_string (snd path); + + method write_full_path (pack : string list) (mname : string) (tname : string) = + chunk#write_list pack chunk#write_string; + chunk#write_string mname; + chunk#write_string tname; + + method write_documentation (doc : doc_block) = + chunk#write_option doc.doc_own (fun s -> + chunk#write_uleb128 (docs#get s) + ); + chunk#write_list doc.doc_inherited (fun s -> + chunk#write_uleb128 (docs#get s) + ); + + method write_pos (p : pos) = + (* let t = Timer.timer ["server";"cache context";"write module";"write pos"] in *) + chunk#write_string p.pfile; + chunk#write_leb128 p.pmin; + chunk#write_leb128 p.pmax; + (* t() *) + + method write_metadata_entry ((meta,el,p) : metadata_entry) = + chunk#write_string (Meta.to_string meta); + self#write_pos p; + chunk#write_list el self#write_expr; + + method write_metadata ml = + chunk#write_list ml self#write_metadata_entry + + (* References *) + + method write_class_ref (c : tclass) = + let i = classes#get_or_add c.cl_path c in + (* debug_msg (Printf.sprintf " Write class ref %d for %s" i (snd c.cl_path)); *) + chunk#write_uleb128 i + + method write_enum_ref (en : tenum) = + let i = enums#get_or_add en.e_path en in + (* debug_msg (Printf.sprintf " Write enum ref %d for %s" i (snd en.e_path)); *) + chunk#write_uleb128 i + + method write_typedef_ref (td : tdef) = + let i = typedefs#get_or_add td.t_path td in + (* debug_msg (Printf.sprintf " Write typedef ref %d for %s" i (s_type_path td.t_path)); *) + chunk#write_uleb128 i + + method write_abstract_ref (a : tabstract) = + let i = abstracts#get_or_add a.a_path a in + (* debug_msg (Printf.sprintf " Write abstract ref %d for %s" i (snd a.a_path)); *) + chunk#write_uleb128 i + + method write_anon_ref (an : tanon) (ttp : type_params) = + let pfm = Option.get (anon_id#identify ~strict:true true (TAnon an)) in + try + let index = anons#get pfm.pfm_path in + chunk#write_byte 0; + chunk#write_uleb128 index + with Not_found -> + let index = anons#add pfm.pfm_path an in + chunk#write_byte 1; + chunk#write_uleb128 index; + self#write_anon an ttp + + method write_field_ref (source : field_source) (cf : tclass_field) = + chunk#write_string cf.cf_name + + method write_enum_field_ref ef = + chunk#write_string ef.ef_name + + method write_anon_field_ref cf = + try + let index = anon_fields#get cf in + chunk#write_byte 0; + chunk#write_uleb128 index + with Not_found -> + let index = anon_fields#add cf () in + chunk#write_byte 1; + chunk#write_uleb128 index; + let close = self#open_field_scope true cf in + List.iter (fun ttp -> match follow ttp.ttp_type with + | TInst(c,_) -> ignore(field_type_parameters#add c.cl_path ttp) + | _ -> die "" __LOC__ + ) cf.cf_params; + self#write_class_field_forward cf; + self#write_class_field_data cf; + close() + + (* Type instances *) + + method write_type_parameter_ref (c : tclass) = + begin try + let _ = field_type_parameters#get c.cl_path in + chunk#write_byte 5; + self#write_path c.cl_path; + with Not_found -> try + let i = type_type_parameters#get c.cl_path in + chunk#write_byte 6; + chunk#write_uleb128 i + with Not_found -> try + (* trace (s_type_path c.cl_path); *) + let index = local_type_parameters#get c in + chunk#write_byte 7; + chunk#write_uleb128 index; + with Not_found -> + prerr_endline (Printf.sprintf "[%s] %s Unbound type parameter %s (%s)" (s_type_path current_module.m_path) todo_error (s_type_path c.cl_path) (snd c.cl_path)); + (* DynArray.iter (fun ttp -> debug_msg (Printf.sprintf "FTP %s %s" ttp.ttp_name (s_type_kind ttp.ttp_type)) field_type_parameters#items); *) + (* DynArray.iter (fun ttp -> debug_msg (Printf.sprintf "TTP %s %s" ttp.ttp_name (s_type_kind ttp.ttp_type)) type_type_parameters#items); *) + (* print_stacktrace (); *) + chunk#write_byte 0 (* TMono None *) + end + + method write_type_instance ?(debug:bool = false) t = + let debug_trace = (fun _ -> ()) in + (* let debug_trace = if debug then (fun s -> trace s) else (fun _ -> ()) in *) + ignore(debug_trace); + + let write_function_arg (n,o,t) = + chunk#write_string n; + chunk#write_bool o; + self#write_type_instance ~debug t; + in + match t with + | TMono r -> + begin match r.tm_type with + | None -> + chunk#write_byte 0 + | Some t -> + chunk#write_byte 1; + self#write_type_instance ~debug t + end + | TInst({cl_kind = KTypeParameter _} as c,[]) -> + (* debug_msg (Printf.sprintf "[%s] KTypeParameter for %s" (s_type_path current_module.m_path) (s_type_path c.cl_path)); *) + self#write_type_parameter_ref c + | TInst({cl_kind = KExpr e},[]) -> + chunk#write_byte 8; + self#write_expr e; + | TInst(c,[]) -> + chunk#write_byte 10; + self#write_class_ref c; + | TEnum(en,[]) -> + chunk#write_byte 11; + self#write_enum_ref en; + | TType(td,[]) -> + chunk#write_byte 12; + self#write_path td.t_path; + begin match td.t_type with + | TAnon an when PMap.is_empty an.a_fields -> + chunk#write_byte 0; + | TAnon an -> + chunk#write_byte 1; + self#write_anon_ref an td.t_params + (* TODO: do something about TMono? *) + | _ -> + chunk#write_byte 2; + self#write_typedef_ref td; + end; + | TAbstract(a,[]) -> + chunk#write_byte 13; + self#write_abstract_ref a; + | TInst(c,tl) -> + chunk#write_byte 14; + self#write_class_ref c; + self#write_types tl + | TEnum(en,tl) -> + chunk#write_byte 15; + self#write_enum_ref en; + self#write_types tl + | TType(td,tl) -> + chunk#write_byte 16; + self#write_path td.t_path; + begin match td.t_type with + | TAnon an when PMap.is_empty an.a_fields -> + chunk#write_byte 0; + self#write_types tl + | TAnon an -> + chunk#write_byte 1; + self#write_anon_ref an td.t_params; + self#write_types tl + | _ -> + chunk#write_byte 2; + self#write_type_instance ~debug (apply_typedef td tl); + self#write_types tl + end; + | TAbstract(a,tl) -> + chunk#write_byte 17; + self#write_abstract_ref a; + self#write_types tl + | TFun([],t) when ExtType.is_void (follow t) -> + chunk#write_byte 30; + | TFun(args,t) when ExtType.is_void (follow t) -> + chunk#write_byte 31; + chunk#write_list args write_function_arg; + | TFun(args,t) -> + chunk#write_byte 32; + chunk#write_list args write_function_arg; + self#write_type_instance ~debug t; + | TLazy r -> + chunk#write_byte 33; + self#write_type_instance ~debug (lazy_type r); + | TDynamic None -> + chunk#write_byte 40 + | TDynamic (Some t) -> + chunk#write_byte 41; + self#write_type_instance ~debug t; + | TAnon an when PMap.is_empty an.a_fields -> + chunk#write_byte 50; + chunk#write_bool true + | TAnon an -> + chunk#write_byte 51; + self#write_anon_ref an [] + + method write_types tl = + chunk#write_list tl self#write_type_instance + + (* expr *) + + method write_object_field_key (n,p,qs) = + chunk#write_string n; + self#write_pos p; + begin match qs with + | NoQuotes -> chunk#write_byte 0 + | DoubleQuotes -> chunk#write_byte 1 + end + + method write_type_path tp = + chunk#write_list tp.tpackage chunk#write_string; + chunk#write_string tp.tname; + chunk#write_list tp.tparams self#write_type_param_or_const; + chunk#write_option tp.tsub chunk#write_string + + method write_placed_type_path ptp = + self#write_type_path ptp.path; + self#write_pos ptp.pos_full; + self#write_pos ptp.pos_path + + method write_type_param_or_const = function + | TPType th -> + chunk#write_byte 0; + self#write_type_hint th + | TPExpr e -> + chunk#write_byte 1; + self#write_expr e + + method write_complex_type = function + | CTPath tp -> + chunk#write_byte 0; + self#write_placed_type_path tp + | CTFunction(thl,th) -> + chunk#write_byte 1; + chunk#write_list thl self#write_type_hint; + self#write_type_hint th + | CTAnonymous cffl -> + chunk#write_byte 2; + chunk#write_list cffl self#write_cfield; + | CTParent th -> + chunk#write_byte 3; + self#write_type_hint th + | CTExtend(ptp,cffl) -> + chunk#write_byte 4; + chunk#write_list ptp self#write_placed_type_path; + chunk#write_list cffl self#write_cfield; + | CTOptional th -> + chunk#write_byte 5; + self#write_type_hint th + | CTNamed(pn,th) -> + chunk#write_byte 6; + self#write_placed_name pn; + self#write_type_hint th + | CTIntersection(thl) -> + chunk#write_byte 7; + chunk#write_list thl self#write_type_hint; + + method write_type_hint (ct,p) = + self#write_complex_type ct; + self#write_pos p + + method write_type_param tp = + self#write_placed_name tp.tp_name; + chunk#write_list tp.tp_params self#write_type_param; + chunk#write_option tp.tp_constraints self#write_type_hint; + chunk#write_option tp.tp_default self#write_type_hint; + chunk#write_list tp.tp_meta self#write_metadata_entry; + + method write_func_arg (pn,b,meta,tho,eo) = + self#write_placed_name pn; + chunk#write_bool b; + self#write_metadata meta; + chunk#write_option tho self#write_type_hint; + chunk#write_option eo self#write_expr; + + method write_func f = + chunk#write_list f.f_params self#write_type_param; + chunk#write_list f.f_args self#write_func_arg; + chunk#write_option f.f_type self#write_type_hint; + chunk#write_option f.f_expr self#write_expr + + method write_placed_name (s,p) = + chunk#write_string s; + self#write_pos p + + method write_access ac = + let i = match ac with + | APublic -> 0 + | APrivate -> 1 + | AStatic -> 2 + | AOverride -> 3 + | ADynamic -> 4 + | AInline -> 5 + | AMacro -> 6 + | AFinal -> 7 + | AExtern -> 8 + | AAbstract -> 9 + | AOverload -> 10 + | AEnum -> 11 + in + chunk#write_byte i; + + method write_placed_access (ac,p) = + self#write_access ac; + self#write_pos p; + + method write_cfield_kind = function + | FVar(tho,eo) -> + chunk#write_byte 0; + chunk#write_option tho self#write_type_hint; + chunk#write_option eo self#write_expr; + | FFun f -> + chunk#write_byte 1; + self#write_func f; + | FProp(pn1,pn2,tho,eo) -> + chunk#write_byte 2; + self#write_placed_name pn1; + self#write_placed_name pn2; + chunk#write_option tho self#write_type_hint; + chunk#write_option eo self#write_expr; + + method write_cfield cff = + self#write_placed_name cff.cff_name; + chunk#write_option cff.cff_doc self#write_documentation; + self#write_pos cff.cff_pos; + self#write_metadata cff.cff_meta; + chunk#write_list cff.cff_access self#write_placed_access; + self#write_cfield_kind cff.cff_kind; + + method write_expr (e,p) = + self#write_pos p; + match e with + | EConst (Int (s, suffix)) -> + chunk#write_byte 0; + chunk#write_string s; + chunk#write_option suffix chunk#write_string; + | EConst (Float (s, suffix)) -> + chunk#write_byte 1; + chunk#write_string s; + chunk#write_option suffix chunk#write_string; + | EConst (String (s,qs)) -> + chunk#write_byte 2; + chunk#write_string s; + begin match qs with + | SDoubleQuotes -> chunk#write_byte 0; + | SSingleQuotes -> chunk#write_byte 1; + end + | EConst (Ident s) -> + chunk#write_byte 3; + chunk#write_string s; + | EConst (Regexp(s1,s2)) -> + chunk#write_byte 4; + chunk#write_string s1; + chunk#write_string s2; + | EArray(e1,e2) -> + chunk#write_byte 5; + self#write_expr e1; + self#write_expr e2; + | EBinop(op,e1,e2) -> + chunk#write_byte 6; + chunk#write_byte (binop_index op); + self#write_expr e1; + self#write_expr e2; + | EField(e1,s,kind) -> + chunk#write_byte 7; + self#write_expr e1; + chunk#write_string s; + begin match kind with + | EFNormal -> chunk#write_byte 0; + | EFSafe -> chunk#write_byte 1; + end + | EParenthesis e1 -> + chunk#write_byte 8; + self#write_expr e1 + | EObjectDecl fl -> + chunk#write_byte 9; + let write_field (k,e1) = + self#write_object_field_key k; + self#write_expr e1 + in + chunk#write_list fl write_field; + | EArrayDecl el -> + chunk#write_byte 10; + chunk#write_list el self#write_expr; + | ECall(e1,el) -> + chunk#write_byte 11; + self#write_expr e1; + chunk#write_list el self#write_expr + | ENew(ptp,el) -> + chunk#write_byte 12; + self#write_placed_type_path ptp; + chunk#write_list el self#write_expr; + | EUnop(op,flag,e1) -> + chunk#write_byte 13; + chunk#write_byte (unop_index op flag); + self#write_expr e1; + | EVars vl -> + chunk#write_byte 14; + let write_var v = + self#write_placed_name v.ev_name; + chunk#write_bool v.ev_final; + chunk#write_bool v.ev_static; + chunk#write_option v.ev_type self#write_type_hint; + chunk#write_option v.ev_expr self#write_expr; + self#write_metadata v.ev_meta; + in + chunk#write_list vl write_var + | EFunction(fk,f) -> + chunk#write_byte 15; + begin match fk with + | FKAnonymous -> chunk#write_byte 0; + | FKNamed (pn,inline) -> + chunk#write_byte 1; + self#write_placed_name pn; + chunk#write_bool inline; + | FKArrow -> chunk#write_byte 2; + end; + self#write_func f; + | EBlock el -> + chunk#write_byte 16; + chunk#write_list el self#write_expr + | EFor(e1,e2) -> + chunk#write_byte 17; + self#write_expr e1; + self#write_expr e2; + | EIf(e1,e2,None) -> + chunk#write_byte 18; + self#write_expr e1; + self#write_expr e2; + | EIf(e1,e2,Some e3) -> + chunk#write_byte 19; + self#write_expr e1; + self#write_expr e2; + self#write_expr e3; + | EWhile(e1,e2,NormalWhile) -> + chunk#write_byte 20; + self#write_expr e1; + self#write_expr e2; + | EWhile(e1,e2,DoWhile) -> + chunk#write_byte 21; + self#write_expr e1; + self#write_expr e2; + | ESwitch(e1,cases,def) -> + chunk#write_byte 22; + self#write_expr e1; + let write_case (el,eg,eo,p) = + chunk#write_list el self#write_expr; + chunk#write_option eg self#write_expr; + chunk#write_option eo self#write_expr; + self#write_pos p; + in + chunk#write_list cases write_case; + let write_default (eo,p) = + chunk#write_option eo self#write_expr; + self#write_pos p + in + chunk#write_option def write_default; + | ETry(e1,catches) -> + chunk#write_byte 23; + self#write_expr e1; + let write_catch (pn,th,e,p) = + self#write_placed_name pn; + chunk#write_option th self#write_type_hint; + self#write_expr e; + self#write_pos p; + in + chunk#write_list catches write_catch; + | EReturn None -> + chunk#write_byte 24; + | EReturn (Some e1) -> + chunk#write_byte 25; + self#write_expr e1; + | EBreak -> + chunk#write_byte 26; + | EContinue -> + chunk#write_byte 27; + | EUntyped e1 -> + chunk#write_byte 28; + self#write_expr e1; + | EThrow e1 -> + chunk#write_byte 29; + self#write_expr e1; + | ECast(e1,None) -> + chunk#write_byte 30; + self#write_expr e1; + | ECast(e1,Some th) -> + chunk#write_byte 31; + self#write_expr e1; + self#write_type_hint th; + | EIs(e1,th) -> + chunk#write_byte 32; + self#write_expr e1; + self#write_type_hint th; + | EDisplay(e1,dk) -> + chunk#write_byte 33; + self#write_expr e1; + begin match dk with + | DKCall -> chunk#write_byte 0; + | DKDot -> chunk#write_byte 1; + | DKStructure -> chunk#write_byte 2; + | DKMarked -> chunk#write_byte 3; + | DKPattern b -> + chunk#write_byte 4; + chunk#write_bool b; + end + | ETernary(e1,e2,e3) -> + chunk#write_byte 34; + self#write_expr e1; + self#write_expr e2; + self#write_expr e3; + | ECheckType(e1,th) -> + chunk#write_byte 35; + self#write_expr e1; + self#write_type_hint th; + | EMeta(m,e1) -> + chunk#write_byte 36; + self#write_metadata_entry m; + self#write_expr e1 + + (* texpr *) + + method write_var_kind vk = + let b = match vk with + | VUser TVOLocalVariable -> 0 + | VUser TVOArgument -> 1 + | VUser TVOForVariable -> 2 + | VUser TVOPatternVariable -> 3 + | VUser TVOCatchVariable -> 4 + | VUser TVOLocalFunction -> 5 + | VGenerated -> 6 + | VInlined -> 7 + | VInlinedConstructorVariable -> 8 + | VExtractorVariable -> 9 + | VAbstractThis -> 10 + in + chunk#write_byte b + + method write_var v = + chunk#write_i32 v.v_id; + chunk#write_string v.v_name; + chunk#write_option v.v_extra (fun ve -> + chunk#write_list ve.v_params (fun ttp -> match follow ttp.ttp_type with + | TInst(c,_) -> + let index = local_type_parameters#add c ttp in + chunk#write_uleb128 index + | _ -> + die "" __LOC__ + ); + chunk#write_option ve.v_expr self#write_texpr; + ); + self#write_type_instance v.v_type; + self#write_var_kind v.v_kind; + chunk#write_i32 v.v_flags; + self#write_metadata v.v_meta; + self#write_pos v.v_pos + + method write_texpr (e : texpr) = + let rec loop ?(debug:bool = false) e = + (try self#write_type_instance ~debug e.etype; with _ -> begin + prerr_endline (Printf.sprintf "Error while writing type instance for:"); + (* MessageReporting.display_source_at com e.epos; *) + end); + self#write_pos e.epos; + + match e.eexpr with + (* values 0-19 *) + | TConst ct -> + begin match ct with + | TNull -> + chunk#write_byte 0; + | TThis -> + chunk#write_byte 1; + | TSuper -> + chunk#write_byte 2; + | TBool false -> + chunk#write_byte 3; + | TBool true -> + chunk#write_byte 4; + | TInt i32 -> + chunk#write_byte 5; + chunk#write_u32 i32; + | TFloat f -> + chunk#write_byte 6; + chunk#write_string f; + | TString s -> + chunk#write_byte 7; + chunk#write_string s + end + (* vars 20-29 *) + | TLocal v -> + chunk#write_byte 20; + chunk#write_i32 v.v_id; + | TVar(v,None) -> + chunk#write_byte 21; + self#write_var v + | TVar(v,Some e1) -> + chunk#write_byte 22; + self#write_var v; + loop e1; + (* blocks 30-49 *) + | TBlock [] -> + chunk#write_byte 30; + | TBlock el -> + let l = List.length el in + begin match l with + | 1 -> chunk#write_byte 31; + | 2 -> chunk#write_byte 32; + | 3 -> chunk#write_byte 33; + | 4 -> chunk#write_byte 34; + | 5 -> chunk#write_byte 35; + | _ -> + if l <= 0xFF then begin + chunk#write_byte 36; + chunk#write_byte l; + end else if l < 0xFFFF then begin + chunk#write_byte 37; + chunk#write_ui16 l; + end else begin + chunk#write_byte 38; + chunk#write_i32 l; + end; + end; + List.iter loop el + (* function 50-59 *) + | TFunction tf -> + chunk#write_byte 50; + chunk#write_list tf.tf_args (fun (v,eo) -> + self#write_var v; + chunk#write_option eo loop; + ); + self#write_type_instance tf.tf_type; + loop tf.tf_expr; + (* texpr compounds 60-79 *) + | TArray(e1,e2) -> + chunk#write_byte 60; + loop e1; + loop e2; + | TParenthesis e1 -> + chunk#write_byte 61; + loop e1; + | TArrayDecl el -> + chunk#write_byte 62; + loop_el el; + | TObjectDecl fl -> + chunk#write_byte 63; + chunk#write_list fl (fun ((name,p,qs),e) -> + chunk#write_string name; + self#write_pos p; + begin match qs with + | NoQuotes -> chunk#write_byte 0; + | DoubleQuotes -> chunk#write_byte 1; + end; + loop e + ); + | TCall(e1,el) -> + chunk#write_byte 64; + loop e1; + loop_el el; + | TMeta(m,e1) -> + chunk#write_byte 65; + self#write_metadata_entry m; + loop e1; + (* branching 80-89 *) + | TIf(e1,e2,None) -> + chunk#write_byte 80; + loop e1; + loop e2; + | TIf(e1,e2,Some e3) -> + chunk#write_byte 81; + loop e1; + loop e2; + loop e3; + | TSwitch s -> + chunk#write_byte 82; + loop s.switch_subject; + chunk#write_list s.switch_cases (fun c -> + loop_el c.case_patterns; + loop c.case_expr; + ); + chunk#write_option s.switch_default loop; + | TTry(e1,catches) -> + chunk#write_byte 83; + loop e1; + chunk#write_list catches (fun (v,e) -> + self#write_var v; + loop e + ); + | TWhile(e1,e2,flag) -> + chunk#write_byte (if flag = NormalWhile then 84 else 85); + loop e1; + loop e2; + | TFor(v,e1,e2) -> + chunk#write_byte 86; + self#write_var v; + loop e1; + loop e2; + (* control flow 90-99 *) + | TReturn None -> + chunk#write_byte 90; + | TReturn (Some e1) -> + chunk#write_byte 91; + loop e1; + | TContinue -> + chunk#write_byte 92; + | TBreak -> + chunk#write_byte 93; + | TThrow e1 -> + chunk#write_byte 94; + loop e1; + (* access 100-119 *) + | TEnumIndex e1 -> + chunk#write_byte 100; + loop e1; + | TEnumParameter(e1,({ ef_type = TEnum(en,_) | TFun(_, TEnum(en,_)) } as ef),i) -> + chunk#write_byte 101; + loop e1; + self#write_enum_ref en; + self#write_enum_field_ref ef; + chunk#write_i32 i; + | TEnumParameter(e1,({ ef_type = eft}),i) -> + prerr_endline (Printf.sprintf "en = %s" (s_type_kind eft)); + assert false + | TField(e1,FInstance(c,tl,cf)) -> + chunk#write_byte 102; + loop e1; + self#write_class_ref c; + self#write_types tl; + self#write_field_ref (ClassMember c) cf; (* TODO check source *) + | TField(e1,FStatic(c,cf)) -> + chunk#write_byte 103; + loop e1; + self#write_class_ref c; + self#write_field_ref (ClassMember c) cf; (* TODO check source *) + | TField(e1,FAnon cf) -> + chunk#write_byte 104; + loop e1; + self#write_anon_field_ref cf + | TField(e1,FClosure(Some(c,tl),cf)) -> + chunk#write_byte 105; + loop e1; + self#write_class_ref c; + self#write_types tl; + self#write_field_ref (ClassMember c) cf; (* TODO check source *) + | TField(e1,FClosure(None,cf)) -> + chunk#write_byte 106; + loop e1; + self#write_anon_field_ref cf + | TField(e1,FEnum(en,ef)) -> + chunk#write_byte 107; + loop e1; + self#write_enum_ref en; + self#write_enum_field_ref ef; + (* TODO ef.ef_params here triggers unbound type params later *) + chunk#write_list ef.ef_params self#write_type_parameter_forward; + chunk#write_list ef.ef_params self#write_type_parameter_data; + | TField(e1,FDynamic s) -> + chunk#write_byte 108; + loop e1; + chunk#write_string s; + (* module types 120-139 *) + | TTypeExpr (TClassDecl ({cl_kind = KTypeParameter []} as c)) -> + chunk#write_byte 128; + self#write_type_parameter_ref c + | TTypeExpr (TClassDecl c) -> + chunk#write_byte 120; + self#write_class_ref c; + | TTypeExpr (TEnumDecl en) -> + chunk#write_byte 121; + self#write_enum_ref en; + | TTypeExpr (TAbstractDecl a) -> + chunk#write_byte 122; + self#write_abstract_ref a + | TTypeExpr (TTypeDecl td) -> + chunk#write_byte 123; + self#write_typedef_ref td + | TCast(e1,None) -> + chunk#write_byte 124; + loop e1; + | TCast(e1,Some md) -> + chunk#write_byte 125; + loop e1; + let infos = t_infos md in + let m = infos.mt_module in + self#write_full_path (fst m.m_path) (snd m.m_path) (snd infos.mt_path); + chunk#write_string m.m_extra.m_sign; + | TNew(({cl_kind = KTypeParameter _} as c),tl,el) -> + chunk#write_byte 127; + self#write_type_parameter_ref c; + self#write_types tl; + loop_el el; + | TNew(c,tl,el) -> + chunk#write_byte 126; + self#write_class_ref c; + self#write_types tl; + loop_el el; + (* unops 140-159 *) + | TUnop(op,flag,e1) -> + chunk#write_byte (140 + unop_index op flag); + loop e1; + (* binops 160-219 *) + | TBinop(op,e1,e2) -> + chunk#write_byte (160 + binop_index op); + loop e1; + loop e2; + (* rest 250-254 *) + | TIdent s -> + chunk#write_byte 250; + chunk#write_string s; + and loop_el el = + chunk#write_ui16 (List.length el); + List.iter loop el + in + loop e + + (* Fields *) + + method set_field_type_parameters (nested : bool) params = + if not nested then field_type_parameters <- new pool; + List.iter (fun ttp -> match follow ttp.ttp_type with + | TInst(c,_) -> ignore(field_type_parameters#add c.cl_path ttp); + | _ -> die "" __LOC__ + ) params + + method write_type_parameter_forward ttp = match follow ttp.ttp_type with + | TInst({cl_kind = KTypeParameter _} as c,_) -> + chunk#write_string ttp.ttp_name; + self#write_pos c.cl_name_pos + | _ -> + die "" __LOC__ + + method write_type_parameter_data ttp = match follow ttp.ttp_type with + | TInst({cl_kind = KTypeParameter tl1} as c,tl2) -> + self#write_types tl1; + self#write_types tl2; + self#write_metadata c.cl_meta + | _ -> + die "" __LOC__ + + method write_field_kind = function + | Method MethNormal -> chunk#write_byte 0; + | Method MethInline -> chunk#write_byte 1; + | Method MethDynamic -> chunk#write_byte 2; + | Method MethMacro -> chunk#write_byte 3; + (* normal read *) + | Var {v_read = AccNormal; v_write = AccNormal } -> chunk#write_byte 10 + | Var {v_read = AccNormal; v_write = AccNo } -> chunk#write_byte 11 + | Var {v_read = AccNormal; v_write = AccNever } -> chunk#write_byte 12 + | Var {v_read = AccNormal; v_write = AccCtor } -> chunk#write_byte 13 + | Var {v_read = AccNormal; v_write = AccCall } -> chunk#write_byte 14 + (* inline read *) + | Var {v_read = AccInline; v_write = AccNever } -> chunk#write_byte 20 + (* getter read *) + | Var {v_read = AccCall; v_write = AccNormal } -> chunk#write_byte 30 + | Var {v_read = AccCall; v_write = AccNo } -> chunk#write_byte 31 + | Var {v_read = AccCall; v_write = AccNever } -> chunk#write_byte 32 + | Var {v_read = AccCall; v_write = AccCtor } -> chunk#write_byte 33 + | Var {v_read = AccCall; v_write = AccCall } -> chunk#write_byte 34 + (* weird/overlooked combinations *) + | Var {v_read = r;v_write = w } -> + chunk#write_byte 100; + let f = function + | AccNormal -> chunk#write_byte 0 + | AccNo -> chunk#write_byte 1 + | AccNever -> chunk#write_byte 2 + | AccCtor -> chunk#write_byte 3 + | AccCall -> chunk#write_byte 4 + | AccInline -> chunk#write_byte 5 + | AccRequire(s,so) -> + chunk#write_byte 6; + chunk#write_string s; + chunk#write_option so chunk#write_string + in + f r; + f w; + + method open_field_scope (nested : bool) (cf : tclass_field) = + let old_field_params = field_type_parameters in + let old_local_params = local_type_parameters in + if not nested then local_type_parameters <- new identity_pool; + self#set_field_type_parameters nested cf.cf_params; + (fun () -> + field_type_parameters <- old_field_params; + local_type_parameters <- old_local_params; + ) + + method write_class_field_forward cf = + chunk#write_string cf.cf_name; + self#write_pos cf.cf_pos; + self#write_pos cf.cf_name_pos; + chunk#write_list cf.cf_overloads (self#write_class_field_forward); + + method write_class_field_data cf = + let restore = self#start_temporary_chunk in + (* if (snd current_module.m_path) = "Main" then *) + (* debug_msg (Printf.sprintf " (1) Write class field %s" cf.cf_name); *) + (try self#write_type_instance cf.cf_type with e -> begin + prerr_endline (Printf.sprintf "%s while writing type instance for field %s" todo_error cf.cf_name); + (* raise e *) + end); + chunk#write_i32 cf.cf_flags; + chunk#write_option cf.cf_doc self#write_documentation; + self#write_metadata cf.cf_meta; + self#write_field_kind cf.cf_kind; + (try chunk#write_option cf.cf_expr self#write_texpr with e -> begin + prerr_endline (Printf.sprintf "%s while writing expr for field %s" todo_error cf.cf_name); + (* MessageReporting.display_source_at com cf.cf_pos; *) + (* raise e *) + end); + chunk#write_option cf.cf_expr_unoptimized self#write_texpr; + chunk#write_list cf.cf_overloads (fun f -> self#write_class_field_data f); + restore (fun chunk new_chunk -> + chunk#write_list cf.cf_params self#write_type_parameter_forward; + chunk#write_list cf.cf_params self#write_type_parameter_data; + let ltp = List.map snd local_type_parameters#to_list in + chunk#write_list ltp self#write_type_parameter_forward; + chunk#write_list ltp self#write_type_parameter_data; + new_chunk#export_data chunk#ch + ) + + (* Module types *) + + method select_type (path : path) = + (* debug_msg (Printf.sprintf "Select type %s" (s_type_path path)); *) + type_type_parameters <- type_param_lut#extract path + + method write_common_module_type (infos : tinfos) : unit = + (* self#write_path infos.mt_path; *) + chunk#write_bool infos.mt_private; + chunk#write_option infos.mt_doc self#write_documentation; + self#write_metadata infos.mt_meta; + chunk#write_list infos.mt_params self#write_type_parameter_forward; + chunk#write_list infos.mt_params self#write_type_parameter_data; + chunk#write_list infos.mt_using (fun (c,p) -> + self#write_class_ref c; + self#write_pos p; + ); + + method write_class_kind = function + | KNormal -> + chunk#write_byte 0 + | KTypeParameter tl -> + chunk#write_byte 1; + self#write_types tl; + | KExpr e -> + chunk#write_byte 2; + self#write_expr e; + | KGeneric -> + chunk#write_byte 3; + | KGenericInstance(c,tl) -> + chunk#write_byte 4; + self#write_class_ref c; + self#write_types tl + | KMacroType -> + chunk#write_byte 5; + | KGenericBuild l -> + chunk#write_byte 6; + chunk#write_list l self#write_cfield; + | KAbstractImpl a -> + chunk#write_byte 7; + self#write_abstract_ref a; + | KModuleFields md -> + chunk#write_byte 8; + + method write_class (c : tclass) = + begin match c.cl_kind with + | KAbstractImpl a -> + (* debug_msg (Printf.sprintf "Write abstract impl %s with %d type params" (snd c.cl_path) (List.length a.a_params)); *) + self#select_type a.a_path + | _ -> + self#select_type c.cl_path; + end; + (* if (snd current_module.m_path) = "Bar_String" then *) + (* debug_msg (Printf.sprintf "[%s] Write class %s with %d type params" (s_type_path current_module.m_path) (snd c.cl_path) (List.length c.cl_params)); *) + self#write_common_module_type (Obj.magic c); + self#write_class_kind c.cl_kind; + chunk#write_u32 (Int32.of_int c.cl_flags); + chunk#write_option c.cl_super (fun (c,tl) -> + self#write_class_ref c; + self#write_types tl + ); + chunk#write_list c.cl_implements (fun (c,tl) -> + self#write_class_ref c; + self#write_types tl + ); + chunk#write_option c.cl_dynamic self#write_type_instance; + chunk#write_option c.cl_array_access self#write_type_instance; + + method write_abstract (a : tabstract) = + begin try + self#select_type a.a_path + with Not_found -> + prerr_endline ("Could not select abstract " ^ (s_type_path a.a_path)); + end; + self#write_common_module_type (Obj.magic a); + (* ops *) + (* unops *) + chunk#write_option a.a_impl self#write_class_ref; + let c = match a.a_impl with + | None -> + null_class + | Some c -> + c + in + self#write_type_instance a.a_this; + chunk#write_list a.a_from self#write_type_instance; + chunk#write_list a.a_from_field (fun (t,cf) -> + chunk#write_string cf.cf_name; + self#set_field_type_parameters false cf.cf_params; + chunk#write_list cf.cf_params self#write_type_parameter_forward; + chunk#write_list cf.cf_params self#write_type_parameter_data; + self#write_type_instance t; + self#write_field_ref (ClassStatic c) cf; + ); + chunk#write_list a.a_to self#write_type_instance; + chunk#write_list a.a_to_field (fun (t,cf) -> + chunk#write_string cf.cf_name; + self#set_field_type_parameters false cf.cf_params; + chunk#write_list cf.cf_params self#write_type_parameter_forward; + chunk#write_list cf.cf_params self#write_type_parameter_data; + self#write_type_instance t; + self#write_field_ref (ClassStatic c) cf; + ); + chunk#write_list a.a_array (self#write_field_ref (ClassStatic c)); + chunk#write_option a.a_read (self#write_field_ref (ClassStatic c)); + chunk#write_option a.a_write (self#write_field_ref (ClassStatic c)); + chunk#write_option a.a_call (self#write_field_ref (ClassStatic c)); + chunk#write_bool a.a_enum + + method write_enum (e : tenum) = + (* debug_msg (Printf.sprintf "Write enum %s" (snd e.e_path)); *) + self#select_type e.e_path; + self#write_common_module_type (Obj.magic e); + + (match e.e_type.t_type with + | TAnon an when PMap.is_empty an.a_fields -> + chunk#write_byte 0; + | TAnon an -> + chunk#write_byte 1; + self#write_anon_ref an e.e_type.t_params + | _ -> assert false); + + chunk#write_bool e.e_extern; + chunk#write_list e.e_names chunk#write_string; + + method write_typedef (td : tdef) = + (* debug_msg (Printf.sprintf "Write typedef %s %s >>" (s_type_path td.t_path) (s_type_kind td.t_type)); *) + self#select_type td.t_path; + self#write_common_module_type (Obj.magic td); + self#write_type_instance td.t_type; + + method write_anon (an : tanon) (ttp : type_params) = + let old = type_type_parameters in + type_type_parameters <- new pool; + List.iter (fun ttp -> match follow ttp.ttp_type with + | TInst(c,_) -> ignore(type_type_parameters#add c.cl_path ttp) + | _ -> die "" __LOC__ + ) ttp; + chunk#write_list ttp self#write_type_parameter_forward; + chunk#write_list ttp self#write_type_parameter_data; + + let write_fields () = + chunk#write_list (PMap.foldi (fun s f acc -> (s,f) :: acc) an.a_fields []) (fun (_,cf) -> + let close = self#open_field_scope true cf in + self#write_class_field_forward cf; + self#write_class_field_data cf; + close() + ) + in + + begin match !(an.a_status) with + | Closed -> + chunk#write_byte 0; + write_fields () + | Const -> + chunk#write_byte 1; + write_fields () + | Extend tl -> + chunk#write_byte 2; + self#write_types tl; + write_fields () + | ClassStatics c -> + chunk#write_byte 3; + self#write_class_ref c; + | EnumStatics en -> + chunk#write_byte 4; + self#write_enum_ref en; + write_fields () + | AbstractStatics a -> + chunk#write_byte 5; + self#write_abstract_ref a; + write_fields () + end; + + type_type_parameters <- old + + (* Module *) + + method forward_declare_type (mt : module_type) = + let name = ref "" in + let i = match mt with + | TClassDecl c -> + ignore(classes#add c.cl_path c); + ignore(own_classes#add c.cl_path c); + name := snd c.cl_path; + 0 + | TEnumDecl e -> + ignore(enums#get_or_add e.e_path e); + ignore(own_enums#add e.e_path e); + name := snd e.e_path; + 1 + | TTypeDecl t -> + ignore(typedefs#get_or_add t.t_path t); + ignore(own_typedefs#add t.t_path t); + name := snd t.t_path; + 2 + | TAbstractDecl a -> + ignore(abstracts#add a.a_path a); + ignore(own_abstracts#add a.a_path a); + name := snd a.a_path; + 3 + in + + let infos = t_infos mt in + (* debug_msg (Printf.sprintf "Forward declare type %s" (s_type_path infos.mt_path)); *) + chunk#write_byte i; + (* self#write_path infos.mt_path; *) + self#write_full_path (fst infos.mt_path) (snd infos.mt_path) !name; + self#write_pos infos.mt_pos; + self#write_pos infos.mt_name_pos; + let params = new pool in + type_type_parameters <- params; + ignore(type_param_lut#add infos.mt_path params); + List.iter (fun ttp -> match follow ttp.ttp_type with + | TInst(c,_) -> ignore(type_type_parameters#add c.cl_path ttp) + | _ -> die "" __LOC__ + ) infos.mt_params; + + (* Forward declare fields *) + match mt with + | TClassDecl c -> + chunk#write_option c.cl_constructor self#write_class_field_forward; + chunk#write_list c.cl_ordered_fields self#write_class_field_forward; + chunk#write_list c.cl_ordered_statics self#write_class_field_forward; + | TEnumDecl e -> + chunk#write_list (PMap.foldi (fun s f acc -> (s,f) :: acc) e.e_constrs []) (fun (s,ef) -> + (* debug_msg (Printf.sprintf " forward declare enum field %s.%s" (s_type_path e.e_path) s); *) + chunk#write_string s; + self#write_pos ef.ef_pos; + self#write_pos ef.ef_name_pos; + chunk#write_byte ef.ef_index + ); + | TAbstractDecl a -> + (* TODO ? *) + () + | TTypeDecl t -> + (* TODO ? *) + () + + method write_module (m : module_def) = + current_module <- m; + + self#start_chunk TYPF; + chunk#write_list m.m_types self#forward_declare_type; + + (* if (snd current_module.m_path) = "Issue3090" then *) + (* debug_msg (Printf.sprintf "Write module %s with %d own classes, %d own abstracts, %d own enums, %d own typedefs" *) + (* (snd m.m_path) (List.length own_classes#to_list) (List.length own_abstracts#to_list) (List.length own_enums#to_list) (List.length own_typedefs#to_list)); *) + + begin match own_abstracts#to_list with + | [] -> + () + | own_abstracts -> + self#start_chunk ABSD; + chunk#write_list own_abstracts self#write_abstract; + end; + begin match own_classes#to_list with + | [] -> + () + | own_classes -> + self#start_chunk CLSD; + chunk#write_list own_classes self#write_class; + self#start_chunk CFLD; + chunk#write_list own_classes (fun c -> + begin match c.cl_kind with + | KAbstractImpl a -> + self#select_type a.a_path + | _ -> + self#select_type c.cl_path; + end; + + let write_field with_name cf = + if with_name then chunk#write_string cf.cf_name; + let close = self#open_field_scope false cf in + self#write_class_field_data cf; + close(); + in + + chunk#write_option c.cl_constructor (write_field false); + chunk#write_list c.cl_ordered_fields (write_field true); + chunk#write_list c.cl_ordered_statics (write_field true); + chunk#write_option c.cl_init self#write_texpr; + ) + end; + begin match own_enums#to_list with + | [] -> + () + | own_enums -> + self#start_chunk ENMD; + chunk#write_list own_enums self#write_enum; + self#start_chunk EFLD; + chunk#write_list own_enums (fun e -> + chunk#write_list (PMap.foldi (fun s f acc -> (s,f) :: acc) e.e_constrs []) (fun (s,ef) -> + self#select_type e.e_path; + (* debug_msg (Printf.sprintf " Write enum field %s.%s" (s_type_path e.e_path) s); *) + chunk#write_string s; + self#set_field_type_parameters false ef.ef_params; + chunk#write_list ef.ef_params self#write_type_parameter_forward; + chunk#write_list ef.ef_params self#write_type_parameter_data; + self#write_type_instance ef.ef_type; + chunk#write_option ef.ef_doc self#write_documentation; + self#write_metadata ef.ef_meta; + ); + ) + end; + begin match own_typedefs#to_list with + | [] -> + () + | own_typedefs -> + self#start_chunk TPDD; + chunk#write_list own_typedefs self#write_typedef; + end; + + begin match classes#to_list with + | [] -> + () + | l -> + self#start_chunk CLSR; + chunk#write_list l (fun c -> + let m = c.cl_module in + (* debug_msg (Printf.sprintf " [cls] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd c.cl_path)]))); *) + self#write_full_path (fst m.m_path) (snd m.m_path) (snd c.cl_path); + chunk#write_string m.m_extra.m_sign + ) + end; + begin match abstracts#to_list with + | [] -> + () + | l -> + self#start_chunk ABSR; + chunk#write_list l (fun a -> + let m = a.a_module in + (* debug_msg (Printf.sprintf " [abs] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd a.a_path)]))); *) + self#write_full_path (fst m.m_path) (snd m.m_path) (snd a.a_path); + chunk#write_string m.m_extra.m_sign + ) + end; + begin match enums#to_list with + | [] -> + () + | l -> + self#start_chunk ENMR; + chunk#write_list l (fun en -> + let m = en.e_module in + (* debug_msg (Printf.sprintf " [enm] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd en.e_path)]))); *) + self#write_full_path (fst m.m_path) (snd m.m_path) (snd en.e_path); + chunk#write_string m.m_extra.m_sign + ) + end; + begin match typedefs#to_list with + | [] -> + () + | l -> + self#start_chunk TPDR; + chunk#write_list l (fun td -> + let m = td.t_module in + (* debug_msg (Printf.sprintf " [tpdr] Write full path %s" (ExtString.String.join "." ((fst m.m_path) @ [(snd m.m_path); (snd td.t_path)]))); *) + self#write_full_path (fst m.m_path) (snd m.m_path) (snd td.t_path); + chunk#write_string m.m_extra.m_sign + ) + end; + self#start_chunk HHDR; + self#write_path m.m_path; + chunk#write_string (Path.UniqueKey.lazy_path m.m_extra.m_file); + chunk#write_uleb128 (DynArray.length anons#items); + chunk#write_uleb128 (DynArray.length anon_fields#items); + self#start_chunk HEND; + + (* Export *) + + method export : 'a . 'a IO.output -> unit = fun ch -> + cp#export ch; + if not docs#is_empty then + docs#export ch; + let l = DynArray.to_list chunks in + let l = List.sort (fun chunk1 chunk2 -> + (Obj.magic chunk1#kind) - (Obj.magic chunk2#kind) + ) l in + List.iter (fun (chunk : chunk) -> + chunk#export ch + ) l +end diff --git a/src/compiler/messageReporting.ml b/src/compiler/messageReporting.ml index 4094ae5cb7c..5bf05688049 100644 --- a/src/compiler/messageReporting.ml +++ b/src/compiler/messageReporting.ml @@ -178,6 +178,7 @@ let compiler_pretty_message_string com ectx cm = (* Error source *) if display_source then out := List.fold_left (fun out (l, line) -> let nb_len = String.length (string_of_int l) in + let gutter = gutter_len - nb_len - 1 in (* Replace tabs with 1 space to avoid column misalignments *) let line = String.concat " " (ExtString.String.nsplit line "\t") in @@ -185,7 +186,7 @@ let compiler_pretty_message_string com ectx cm = out ^ Printf.sprintf "%s%s | %s\n" (* left-padded line number *) - (String.make (gutter_len-nb_len-1) ' ') + (if gutter < 1 then "" else String.make gutter ' ') (if l = 0 then "-" else Printf.sprintf "%d" l) (* Source code at that line *) ( @@ -297,6 +298,14 @@ let get_max_line max_lines messages = else max_lines ) max_lines messages +let display_source_at com p = + let ectx = create_error_context () in + let msg = make_compiler_message "" p 0 MessageKind.DKCompilerMessage MessageSeverity.Information in + ectx.max_lines <- get_max_line ectx.max_lines [msg]; + match compiler_pretty_message_string com ectx msg with + | None -> () + | Some s -> Printf.eprintf "%s\n" s + exception ConfigError of string let get_formatter com ectx def default = diff --git a/src/compiler/server.ml b/src/compiler/server.ml index de6edffc75c..42cf0ad6c2e 100644 --- a/src/compiler/server.ml +++ b/src/compiler/server.ml @@ -434,7 +434,7 @@ let type_module sctx (ctx:Typecore.typer) mpath p = begin match check_module sctx ctx m p with | None -> () | Some reason -> - ServerMessage.skipping_dep com "" (m,(Printer.s_module_skip_reason reason)); + ServerMessage.skipping_dep com "" (mpath,(Printer.s_module_skip_reason reason)); tcheck(); raise Not_found; end; @@ -469,9 +469,11 @@ let after_target_init sctx ctx = Hashtbl.add sctx.class_paths sign com.class_path; () +let after_save sctx ctx = + ServerCompilationContext.after_save sctx ctx.com (has_error ctx) + let after_compilation sctx ctx = - if not (has_error ctx) then - maybe_cache_context sctx ctx.com + ServerCompilationContext.after_compilation sctx ctx.com (has_error ctx) let mk_length_prefixed_communication allow_nonblock chin chout = let sin = Unix.descr_of_in_channel chin in @@ -622,6 +624,7 @@ let rec process sctx comm args = callbacks = { before_anything = before_anything sctx; after_target_init = after_target_init sctx; + after_save = after_save sctx; after_compilation = after_compilation sctx; }; init_wait_socket = init_wait_socket; diff --git a/src/compiler/serverCompilationContext.ml b/src/compiler/serverCompilationContext.ml index bec9724e4c3..52cc016ffaf 100644 --- a/src/compiler/serverCompilationContext.ml +++ b/src/compiler/serverCompilationContext.ml @@ -27,7 +27,7 @@ let create verbose = { cs = new CompilationCache.cache; class_paths = Hashtbl.create 0; changed_directories = Hashtbl.create 0; - compilation_step = 0; + compilation_step = 1; delays = []; was_compilation = false; macro_context_setup = false; @@ -57,12 +57,15 @@ let reset sctx = Hashtbl.clear Timer.htimers; Helper.start_time := get_time() -let maybe_cache_context sctx com = - if com.display.dms_full_typing && com.display.dms_populate_cache then begin +let after_save sctx com has_error = + if not has_error && com.display.dms_full_typing && com.display.dms_populate_cache then begin CommonCache.cache_context sctx.cs com; ServerMessage.cached_modules com "" (List.length com.modules); end +let after_compilation sctx com has_error = + () + let ensure_macro_setup sctx = if not sctx.macro_context_setup then begin sctx.macro_context_setup <- true; diff --git a/src/compiler/serverMessage.ml b/src/compiler/serverMessage.ml index 18a3faeeefa..b2fb9b8c403 100644 --- a/src/compiler/serverMessage.ml +++ b/src/compiler/serverMessage.ml @@ -100,8 +100,8 @@ let retyper_fail com tabs m reason = print_endline (Printf.sprintf "%s%s%s" (sign_string com) (tabs ^ " ") reason); end -let skipping_dep com tabs (m,reason) = - if config.print_skipping_dep then print_endline (Printf.sprintf "%sskipping %s (%s)" (sign_string com) (s_type_path m.m_path) reason) +let skipping_dep com tabs (mpath,reason) = + if config.print_skipping_dep then print_endline (Printf.sprintf "%sskipping %s (%s)" (sign_string com) (s_type_path mpath) reason) let unchanged_content com tabs file = if config.print_unchanged_content then print_endline (Printf.sprintf "%s%s changed time not but content, reusing" (sign_string com) file) diff --git a/src/context/common.ml b/src/context/common.ml index 10c6e484f40..2ea237ff784 100644 --- a/src/context/common.ml +++ b/src/context/common.ml @@ -374,6 +374,7 @@ type context = { mutable config : platform_config; mutable std_path : string list; mutable class_path : string list; + mutable binary_class_path : string list; mutable main_class : path option; mutable package_rules : (string,package_rule) PMap.t; mutable report_mode : report_mode; @@ -830,6 +831,7 @@ let create compilation_step cs version args = run_command_args = (fun s args -> com.run_command (Printf.sprintf "%s %s" s (String.concat " " args))); std_path = []; class_path = []; + binary_class_path = []; main_class = None; package_rules = PMap.empty; file = ""; @@ -1135,7 +1137,7 @@ let cache_directory ctx class_path dir f_dir = in Option.may (Array.iter prepare_file) dir_listing -let find_file ctx f = +let find_file ctx ?(class_path=ctx.class_path) f = try match ctx.file_lookup_cache#find f with | None -> raise Exit @@ -1170,7 +1172,7 @@ let find_file ctx f = loop (had_empty || p = "") l end in - let r = try Some (loop false ctx.class_path) with Not_found -> None in + let r = try Some (loop false class_path) with Not_found -> None in ctx.file_lookup_cache#add f r; match r with | None -> raise Not_found diff --git a/src/core/tFunctions.ml b/src/core/tFunctions.ml index f9aec9853e3..f6405abe832 100644 --- a/src/core/tFunctions.ml +++ b/src/core/tFunctions.ml @@ -199,19 +199,53 @@ let mk_field name ?(public = true) ?(static = false) t p name_pos = { } let null_module = { - m_id = alloc_mid(); - m_path = [] , ""; - m_types = []; - m_statics = None; - m_extra = module_extra "" "" 0. MFake []; - } + m_id = alloc_mid(); + m_path = [] , ""; + m_types = []; + m_statics = None; + m_extra = module_extra "" "" 0. MFake []; +} let null_class = let c = mk_class null_module ([],"") null_pos null_pos in c.cl_private <- true; c +let null_typedef = + let t = mk_typedef null_module ([],"") null_pos null_pos (TDynamic None) in + t.t_private <- true; + t + +let null_tanon = { a_fields = PMap.empty; a_status = ref Closed } + +let null_enum = { + e_path = ([],""); + e_module = null_module; + e_pos = null_pos; + e_name_pos = null_pos; + e_private = true; + e_doc = None; + e_meta = []; + e_params = []; + e_using = []; + e_restore = (fun () -> ()); + e_type = null_typedef; + e_extern = false; + e_constrs = PMap.empty; + e_names = []; +} + let null_field = mk_field "" t_dynamic null_pos null_pos +let null_enum_field = { + ef_name = ""; + ef_type = TEnum (null_enum, []); + ef_pos = null_pos; + ef_name_pos = null_pos; + ef_doc = None; + ef_index = 0; + ef_params = []; + ef_meta = []; +} let null_abstract = { a_path = ([],""); diff --git a/src/core/tOther.ml b/src/core/tOther.ml index dcb5c2b9ea7..221a23e271e 100644 --- a/src/core/tOther.ml +++ b/src/core/tOther.ml @@ -278,6 +278,51 @@ let abstract_module_type a tl = let t = mk_anon (ref (AbstractStatics a)) in {(mk_typedef a.a_module path a.a_pos null_pos t) with t_private = true} +let mk_enum m path pos name_pos = + { + e_path = path; + e_module = m; + e_pos = pos; + e_name_pos = name_pos; + e_doc = None; + e_meta = []; + e_params = []; + e_using = []; + e_restore = (fun () -> ()); + e_private = false; + e_extern = false; + e_constrs = PMap.empty; + e_names = []; + e_type = enum_module_type m path pos; + } + +let mk_abstract m path pos name_pos = + { + a_path = path; + a_private = false; + a_module = m; + a_pos = pos; + a_name_pos = name_pos; + a_doc = None; + a_params = []; + a_using = []; + a_restore = (fun () -> ()); + a_meta = []; + a_from = []; + a_to = []; + a_from_field = []; + a_to_field = []; + a_ops = []; + a_unops = []; + a_impl = None; + a_array = []; + a_this = mk_mono(); + a_read = None; + a_write = None; + a_enum = false; + a_call = None; + } + module TClass = struct let get_member_fields' self_too c0 tl = let rec loop acc c tl = diff --git a/src/core/tType.ml b/src/core/tType.ml index f313959a78a..ab137fc5c7e 100644 --- a/src/core/tType.ml +++ b/src/core/tType.ml @@ -248,10 +248,10 @@ and tinfos = { mt_module : module_def; mt_pos : pos; mt_name_pos : pos; - mt_private : bool; - mt_doc : Ast.documentation; + mutable mt_private : bool; + mutable mt_doc : Ast.documentation; mutable mt_meta : metadata; - mt_params : type_params; + mutable mt_params : type_params; mutable mt_using : (tclass * pos) list; mutable mt_restore : unit -> unit; } @@ -305,14 +305,14 @@ and tenum = { e_module : module_def; e_pos : pos; e_name_pos : pos; - e_private : bool; + mutable e_private : bool; mutable e_doc : Ast.documentation; mutable e_meta : metadata; mutable e_params : type_params; mutable e_using : (tclass * pos) list; mutable e_restore : unit -> unit; (* do not insert any fields above *) - e_type : tdef; + mutable e_type : tdef; mutable e_extern : bool; mutable e_constrs : (string , tenum_field) PMap.t; mutable e_names : string list; @@ -323,8 +323,8 @@ and tdef = { t_module : module_def; t_pos : pos; t_name_pos : pos; - t_private : bool; - t_doc : Ast.documentation; + mutable t_private : bool; + mutable t_doc : Ast.documentation; mutable t_meta : metadata; mutable t_params : type_params; mutable t_using : (tclass * pos) list; @@ -338,7 +338,7 @@ and tabstract = { a_module : module_def; a_pos : pos; a_name_pos : pos; - a_private : bool; + mutable a_private : bool; mutable a_doc : Ast.documentation; mutable a_meta : metadata; mutable a_params : type_params; @@ -357,7 +357,7 @@ and tabstract = { mutable a_read : tclass_field option; mutable a_write : tclass_field option; mutable a_call : tclass_field option; - a_enum : bool; + mutable a_enum : bool; } and module_type = diff --git a/src/core/tUnification.ml b/src/core/tUnification.ml index 6335fd4a5d7..dcfdba26798 100644 --- a/src/core/tUnification.ml +++ b/src/core/tUnification.ml @@ -445,6 +445,10 @@ let unify_kind k1 k2 = | MethDynamic, MethNormal -> true | _ -> false +let unify_kind_strict cfk1 cfk2 = cfk1 = cfk2 || match cfk1, cfk2 with + | Var _, Var _ | Method _, Method _ -> unify_kind cfk1 cfk2 + | _ -> false + type 'a rec_stack = { mutable rec_stack : 'a list; } @@ -568,7 +572,8 @@ let rec type_eq uctx a b = PMap.iter (fun n f1 -> try let f2 = PMap.find n a2.a_fields in - if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind]; + (* if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind]; *) + if f1.cf_kind <> f2.cf_kind && (param = EqStrict || param = EqCoreType || param = EqDoNotFollowNull || not (unify_kind f1.cf_kind f2.cf_kind)) then error [invalid_kind n f1.cf_kind f2.cf_kind]; let a = f1.cf_type and b = f2.cf_type in (try type_eq uctx a b with Unify_error l -> error (invalid_field n :: l)); if (has_class_field_flag f1 CfPublic) != (has_class_field_flag f2 CfPublic) then error [invalid_visibility n]; diff --git a/src/typing/tanon_identification.ml b/src/typing/tanon_identification.ml index 8af805fe9ee..38a92a620f3 100644 --- a/src/typing/tanon_identification.ml +++ b/src/typing/tanon_identification.ml @@ -1,21 +1,21 @@ open Globals open Type -let rec replace_mono t = - match t with - | TMono t -> - (match t.tm_type with - | None -> Monomorph.bind t t_dynamic - | Some _ -> ()) - | TEnum (_,p) | TInst (_,p) | TType (_,p) | TAbstract (_,p) -> - List.iter replace_mono p - | TFun (args,ret) -> - List.iter (fun (_,_,t) -> replace_mono t) args; - replace_mono ret - | TAnon _ - | TDynamic _ -> () - | TLazy f -> - replace_mono (lazy_type f) +let replace_mono t = + let visited_anons = ref [] in + let rec loop t = + match t with + | TMono ({ tm_type = None } as tmono) -> + Monomorph.bind tmono t_dynamic + | TAnon an -> + if not (List.memq an !visited_anons) then begin + visited_anons := an :: !visited_anons; + TFunctions.iter loop t + end + | _ -> + TFunctions.iter loop t + in + loop t type 'a path_field_mapping = { pfm_path : path; @@ -59,7 +59,7 @@ object(self) DynArray.add (DynArray.get pfm_by_arity pfm.pfm_arity) pfm; Hashtbl.replace pfms path pfm - method unify (tc : Type.t) (pfm : 'a path_field_mapping) = + method unify ?(unify_kind = TUnification.unify_kind) ?(strict:bool = false) (tc : Type.t) (pfm : 'a path_field_mapping) = let check () = let pair_up fields = PMap.fold (fun cf acc -> @@ -85,7 +85,14 @@ object(self) List.iter (fun (cf,cf') -> if not (unify_kind cf'.cf_kind cf.cf_kind) then raise (Unify_error [Unify_custom "kind mismatch"]); fields := PMap.remove cf.cf_name !fields; - Type.type_eq EqDoNotFollowNull cf'.cf_type (map (monomorphs cf.cf_params cf.cf_type)) + let uctx = if strict then { + allow_transitive_cast = false; + allow_abstract_cast = false; + allow_dynamic_to_cast = false; + equality_kind = EqDoNotFollowNull; + equality_underlying = true; + } else {default_unification_context with equality_kind = EqDoNotFollowNull} in + type_eq_custom uctx cf'.cf_type (map (monomorphs cf.cf_params cf.cf_type)) ) pairs; if not (PMap.is_empty !fields) then raise (Unify_error [Unify_custom "not enough fields"]); monos @@ -105,17 +112,18 @@ object(self) with Not_found -> raise (Unify_error []) - method find_compatible (arity : int) (tc : Type.t) = + method find_compatible (strict : bool) (arity : int) (tc : Type.t) = if arity >= DynArray.length pfm_by_arity then raise Not_found; let d = DynArray.get pfm_by_arity arity in let l = DynArray.length d in + let rec loop i = if i >= l then raise Not_found; let pfm = DynArray.unsafe_get d i in try - self#unify tc pfm; + if strict then self#unify ~unify_kind:unify_kind_strict ~strict tc pfm else self#unify tc pfm; pfm with Unify_error _ -> loop (i + 1) @@ -135,7 +143,7 @@ object(self) in loop td.t_type - method identify (accept_anons : bool) (t : Type.t) = + method identify ?(strict:bool = false) (accept_anons : bool) (t : Type.t) = match t with | TType(td,tl) -> begin try @@ -157,7 +165,7 @@ object(self) i + 1 ) an.a_fields 0 in begin try - Some (self#find_compatible arity t) + Some (self#find_compatible strict arity t) with Not_found -> let id = num in num <- num + 1; @@ -174,4 +182,4 @@ object(self) end; | _ -> None -end \ No newline at end of file +end diff --git a/src/typing/typeloadModule.ml b/src/typing/typeloadModule.ml index a12549deee7..0005f2fa4d5 100644 --- a/src/typing/typeloadModule.ml +++ b/src/typing/typeloadModule.ml @@ -793,7 +793,63 @@ let type_module ctx mpath file ?(dont_check_path=false) ?(is_extern=false) tdecl let type_module_hook = ref (fun _ _ _ -> None) -let load_module' ctx g m p = +let rec get_reader ctx g p = + (* TODO: create typer context for this module? *) + (* let ctx = create_typer_context_for_module tctx m in *) + + let make_module path file = + let m = ModuleLevel.make_module ctx path file p in + (* m.m_extra.m_added <- ctx.com.compilation_step; *) + m.m_extra.m_processed <- 1; + m + in + + let add_module m = + ctx.com.module_lut#add m.m_path m + in + + let flush_fields () = + flush_pass ctx PConnectField "hxb" + in + + let resolve_type sign pack mname tname = + let m = load_module' ctx g (pack,mname) p in + List.find (fun t -> snd (t_path t) = tname) m.m_types + in + + new HxbReader.hxb_reader make_module add_module resolve_type flush_fields + +and load_hxb_module ctx g path p = + let compose_path no_rename = + (match path with + | [] , name -> name + | x :: l , name -> + String.concat "/" (x :: l) ^ "/" ^ name + ) ^ ".hxb" + in + + let target = Common.platform_name_macro ctx.com in + let bcp = List.map (fun p -> p ^ target ^ Path.path_sep) ctx.com.binary_class_path in + let find_file = Common.find_file ctx.com ~class_path:bcp in + let file = try find_file (compose_path false) with Not_found -> find_file (compose_path true) in + let ch = try open_in_bin file with Sys_error _ -> raise Not_found in + let input = IO.input_channel ch in + + (* TODO use finally instead *) + try + (* Printf.eprintf "[%s] Read module %s\n" target (s_type_path path); *) + let m = (get_reader ctx g p)#read input true p in + (* Printf.eprintf "[%s] Done reading module %s\n" target (s_type_path path); *) + close_in ch; + m + with e -> + Printf.eprintf "\x1b[30;41mError loading %s from %s\x1b[0m\n" (snd path) file; + let msg = Printexc.to_string e and stack = Printexc.get_backtrace () in + Printf.eprintf " => %s\n%s\n" msg stack; + close_in ch; + raise e + +and load_module' ctx g m p = try (* Check current context *) ctx.com.module_lut#find m @@ -802,7 +858,8 @@ let load_module' ctx g m p = match !type_module_hook ctx m p with | Some m -> m - | None -> + (* Try loading from hxb first, then from source *) + | None -> try load_hxb_module ctx 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(); diff --git a/tests/runci/targets/Macro.hx b/tests/runci/targets/Macro.hx index c0eab03ec8c..869614ba984 100644 --- a/tests/runci/targets/Macro.hx +++ b/tests/runci/targets/Macro.hx @@ -5,6 +5,9 @@ import runci.Config.*; class Macro { static public function run(args:Array) { + runCommand("haxe", ["compile-hxb-interp.hxml"].concat(args)); + runCommand("haxe", ["compile-read-hxb-interp.hxml"].concat(args)); + runCommand("haxe", ["compile-macro.hxml"].concat(args)); changeDirectory(displayDir); diff --git a/tests/server/src/cases/ServerTests.hx b/tests/server/src/cases/ServerTests.hx index 8605bc44ff1..a5ff2d0f0e5 100644 --- a/tests/server/src/cases/ServerTests.hx +++ b/tests/server/src/cases/ServerTests.hx @@ -223,6 +223,7 @@ class ServerTests extends TestCase { vfs.putContent("HelloWorld.hx", getTemplate("HelloWorld.hx")); var args = ["--main", "HelloWorld", "--interp"]; runHaxe(args); + assertSuccess(); runHaxe(args); assertReuse("HelloWorld"); runHaxeJson([], ServerMethods.Invalidate, {file: new FsPath("HelloWorld.hx")}); diff --git a/tests/unit/.vscode/settings.json b/tests/unit/.vscode/settings.json index 1bd9f6fda38..a5c36ee08c1 100644 --- a/tests/unit/.vscode/settings.json +++ b/tests/unit/.vscode/settings.json @@ -7,8 +7,8 @@ {"label": "Lua", "args": ["compile-lua.hxml", "-cmd", "lua bin/unit.lua"]}, ], "[haxe]": { - "editor.formatOnSave": true, - "editor.formatOnPaste": true + "editor.formatOnSave": false, + "editor.formatOnPaste": false }, "editor.codeActionsOnSave": { "source.sortImports": true diff --git a/tests/unit/compile-hxb-interp.hxml b/tests/unit/compile-hxb-interp.hxml new file mode 100644 index 00000000000..bd3a0028949 --- /dev/null +++ b/tests/unit/compile-hxb-interp.hxml @@ -0,0 +1,4 @@ +compile-each.hxml +--main unit.TestMain +--interp +--hxb bin/hxb diff --git a/tests/unit/compile-hxb-roundtrip.hxml b/tests/unit/compile-hxb-roundtrip.hxml new file mode 100644 index 00000000000..8191f3d00e8 --- /dev/null +++ b/tests/unit/compile-hxb-roundtrip.hxml @@ -0,0 +1,5 @@ +compile-hxb-interp.hxml + +--next + +compile-read-hxb-interp.hxml \ No newline at end of file diff --git a/tests/unit/compile-read-hxb-interp.hxml b/tests/unit/compile-read-hxb-interp.hxml new file mode 100644 index 00000000000..34e2b656841 --- /dev/null +++ b/tests/unit/compile-read-hxb-interp.hxml @@ -0,0 +1,20 @@ +-D source-header= +--debug +# -p src +# -cp "C:\Program Files\The Haxe Effect\src/dev/null" +--resource res1.txt@re/s?!%[]))("'1.txt +--resource res2.bin@re/s?!%[]))("'1.bin +--resource serializedValues.txt +--macro Macro.init() +--dce full +-lib utest +-D analyzer-optimize +-D analyzer-user-var-fusion +-D message.reporting=pretty +-D haxe-next +# compile-each.hxml + +--main unit.TestMain +--interp +# --hxb bin/hxb +-bcp bin/hxb diff --git a/tests/unit/src/unit/issues/Issue3090.hx b/tests/unit/src/unit/issues/Issue3090.hx.disabled similarity index 100% rename from tests/unit/src/unit/issues/Issue3090.hx rename to tests/unit/src/unit/issues/Issue3090.hx.disabled diff --git a/tests/unit/src/unit/issues/Issue7574.hx b/tests/unit/src/unit/issues/Issue7574.hx.disabled similarity index 100% rename from tests/unit/src/unit/issues/Issue7574.hx rename to tests/unit/src/unit/issues/Issue7574.hx.disabled