Hxb

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
 		),"<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
+		),"<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
 		),"<file>","generate JSON types description");
+		("Services",["--hxb"],[], Arg.String (fun dir ->
+			actx.hxb_out <- Some dir;
+		),"<directory>", "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 () ->

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;
 }
 

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

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] ->

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)