Browse Source

another important change in compiler passes :
- removed too many flushes causing loops
- added a set-inheritance pass (not ordered)
- added cl_build() for individual class building (allow more lazy behavior)

Nicolas Cannasse 13 years ago
parent
commit
d0bfb24489
6 changed files with 66 additions and 38 deletions
  1. 1 0
      codegen.ml
  2. 1 0
      interp.ml
  3. 2 0
      type.ml
  4. 29 27
      typecore.ml
  5. 32 11
      typeload.ml
  6. 1 0
      typer.ml

+ 1 - 0
codegen.ml

@@ -481,6 +481,7 @@ let build_macro_type ctx pl p =
 let build_instance ctx mtype p =
 	match mtype with
 	| TClassDecl c ->
+		if ctx.pass > PBuildClass then c.cl_build();
 		let ft = (fun pl ->
 			match c.cl_kind with
 			| KGeneric ->

+ 1 - 0
interp.ml

@@ -3986,6 +3986,7 @@ and encode_class_kind k =
 	enc_enum IClassKind tag pl
 
 and encode_tclass c =
+	c.cl_build();
 	encode_mtype (TClassDecl c) [
 		"kind", encode_class_kind c.cl_kind;
 		"isExtern", VBool c.cl_extern;

+ 2 - 0
type.ml

@@ -188,6 +188,7 @@ and tclass = {
 	mutable cl_init : texpr option;
 	mutable cl_overrides : string list;
 
+	mutable cl_build : unit -> unit;
 	mutable cl_restore : unit -> unit;
 }
 
@@ -317,6 +318,7 @@ let mk_class m path pos =
 		cl_constructor = None;
 		cl_init = None;
 		cl_overrides = [];
+		cl_build = (fun() -> ());
 		cl_restore = (fun() -> ());
 	}
 

+ 29 - 27
typecore.ml

@@ -39,8 +39,9 @@ type macro_mode =
 
 type typer_pass =
 	| PBuildModule			(* build the module structure and setup module type parameters *)
-	| PInitModuleTypes		(* resolve imports and typedefs : dont follow types ! *)
+	| PInitModuleTypes		(* load imports and set typedefs : dont follow types ! *)
 	| PResolveTypedefs		(* using and other functions that need to follow typededs *)
+	| PSetInherit			(* build the class extends/implements *)
 	| PBuildClass			(* build the class structure *)
 	| PDefineConstructor	(* add an inherited constructor *)
 	| PTypeField			(* type the class field, allow access to types structures *)
@@ -175,6 +176,7 @@ let pass_name = function
 	| PBuildModule -> "build-module"
 	| PInitModuleTypes -> "init-types"
 	| PResolveTypedefs -> "resolve-types"
+	| PSetInherit -> "set-inherit"
 	| PBuildClass -> "build-class"
 	| PDefineConstructor -> "define-constructor"
 	| PTypeField -> "type-field"
@@ -207,17 +209,6 @@ let unify_raise ctx t1 t2 p =
 			(* no untyped check *)
 			raise (Error (Unify l,p))
 
-let exc_protect ctx f (where:string) =
-	let rec r = ref (fun() ->
-		try
-			f r
-		with
-			| Error (m,p) ->
-				display_error ctx (error_msg m) p;
-				raise Fatal_error
-	) in
-	r
-
 let save_locals ctx =
 	let locals = ctx.locals in
 	(fun() -> ctx.locals <- locals)
@@ -269,6 +260,8 @@ let rec flush_pass ctx p (where:string) =
 	| _ ->
 		()
 
+let make_pass ctx f = f
+
 let fake_modules = Hashtbl.create 0
 let create_fake_module ctx file =
 	let file = Common.unique_full_path file in
@@ -326,7 +319,6 @@ let delay ctx p f =
 
 let pending_passes ctx =
 	let rec loop acc = function
-		| (PDefineConstructor,_) :: pl -> loop acc pl (* SKIP SINCE HAVE SPECIAL BEHAVIOR *)
 		| (p,l) :: pl when p < ctx.pass -> loop (acc @ l) pl
 		| _ -> acc
 	in
@@ -338,6 +330,17 @@ let display_error ctx msg p =
 	debug ctx ("ERROR " ^ msg);
 	display_error ctx msg p
 
+let make_pass ctx f =
+	let inf = pass_infos ctx ctx.pass in
+	(fun v ->
+		debug ctx ("run " ^ inf ^ pending_passes ctx);
+		let old = !delay_tabs in
+		delay_tabs := !delay_tabs ^ "\t";
+		let t = f v in
+		delay_tabs := old;
+		t
+	)
+
 let rec flush_pass ctx p where =
 	let rec loop() =
 		match ctx.g.debug_delayed with
@@ -349,7 +352,7 @@ let rec flush_pass ctx p where =
 				ctx.g.debug_delayed <- (p2,l) :: rest;
 				let old = !delay_tabs in
 				(match p2 with
-				| PForce | PTypeField -> ()
+				| PForce | PTypeField | PBuildClass -> ()
 				| _ ->
 					debug ctx ("run " ^ inf ^ pending_passes ctx2);
 					delay_tabs := !delay_tabs ^ "\t");
@@ -369,19 +372,18 @@ let rec flush_pass ctx p where =
 		debug ctx "flush-done";
 	| _ ->
 		()
-
-let exc_protect ctx f where =
-	let inf = pass_infos ctx ctx.pass in
-	exc_protect ctx (fun r ->
-		flush_pass ctx PBuildClass where;
-		debug ctx ("run " ^ inf ^ pending_passes ctx);
-		let old = !delay_tabs in
-		delay_tabs := !delay_tabs ^ "\t";
-		let t = f r in
-		delay_tabs := old;
-		t
-	) where
-
 */*)
 (* --------------------------------------------------- *)
 
+
+let exc_protect ctx f (where:string) =
+	let f = make_pass ctx f in
+	let rec r = ref (fun() ->
+		try
+			f r
+		with
+			| Error (m,p) ->
+				display_error ctx (error_msg m) p;
+				raise Fatal_error
+	) in
+	r

+ 32 - 11
typeload.ml

@@ -229,7 +229,9 @@ and load_complex_type ctx p t =
 					mk_anon (PMap.foldi PMap.add a.a_fields a2.a_fields)
 				| _ -> error "Can only extend classes and structures" p
 			in
-			loop (load_instance ctx t p false)
+			let i = load_instance ctx t p false in
+			flush_pass ctx PBuildClass "ct_extend";
+			loop i
 		| _ -> assert false)
 	| CTAnonymous l ->
 		let rec loop acc f =
@@ -551,11 +553,11 @@ let rec return_flow ctx e =
 (* PASS 1 & 2 : Module and Class Structure *)
 
 let set_heritance ctx c herits p =
+	let ctx = { ctx with curclass = c; type_params = c.cl_types; pass = PSetInherit } in
 	let process_meta csup =
 		List.iter (fun m ->
 			match m with
 			| ":final", _, _ -> if not (Type.has_meta ":hack" c.cl_meta || (match c.cl_kind with KTypeParameter _ -> true | _ -> false)) then error "Cannot extend a final class" p;
-			| ":autoBuild", el, p -> c.cl_meta <- (":build",el,p) :: m :: c.cl_meta;
 			| _ -> ()
 		) csup.cl_meta
 	in
@@ -612,7 +614,6 @@ let set_heritance ctx c herits p =
 		| HImplements t -> HImplements (resolve_imports t)
 		| h -> h
 	) herits in
-	flush_pass ctx PBuildClass "init_class"; (* make sure super classes are fully initialized *)
 	List.iter loop (List.filter (ctx.g.do_inherit ctx c p) herits)
 
 let rec type_type_params ctx path get_params p tp =
@@ -846,10 +847,16 @@ let build_module_def ctx mt meta fvars fbuild =
 let init_class ctx c p herits fields =
 	let ctx = { ctx with curclass = c; type_params = c.cl_types; pass = PBuildClass } in
 	incr stats.s_classes_built;
+	(* make sure super classes/interfaces are built and propagate transitive properties *)
+	List.iter (fun (csup,_) ->
+		csup.cl_build();
+		List.iter (fun m ->
+			match m with
+			| ":autoBuild", el, p -> c.cl_meta <- (":build",el,p) :: m :: c.cl_meta;
+			| _ -> ()
+		) csup.cl_meta
+	) (match c.cl_super with None -> c.cl_implements | Some cs -> cs :: c.cl_implements);
 	let fields = patch_class ctx c fields in
-	c.cl_extern <- List.mem HExtern herits;
-	c.cl_interface <- List.mem HInterface herits;
-	set_heritance ctx c herits p;
 	let fields = ref fields in
 	let get_fields() = !fields in
 	build_module_def ctx (TClassDecl c) c.cl_meta get_fields (fun (e,p) ->
@@ -1003,7 +1010,6 @@ let init_class ctx c p herits fields =
 		let override = List.mem AOverride f.cff_access in
 		let ctx = { ctx with
 			tthis = tthis;
-			pass = PTypeField;
 			on_error = (fun ctx msg ep ->
 				ctx.com.error msg ep;
 				(* macros expressions might reference other code, let's recall which class we are actually compiling *)
@@ -1041,6 +1047,7 @@ let init_class ctx c p herits fields =
 				cf_overloads = [];
 			} in
 			ctx.curfield <- cf;
+			ctx.pass <- PTypeField;
 			bind_var ctx cf e stat inline;
 			f, false, cf
 		| FFun fd ->
@@ -1110,8 +1117,9 @@ let init_class ctx c p herits fields =
 				cf_params = params;
 				cf_overloads = [];
 			} in
-			ctx.curfield <- cf;
 			init_meta_overloads ctx cf;
+			ctx.curfield <- cf;
+			ctx.pass <- PTypeField;
 			let r = exc_protect ctx (fun r ->
 				if not !return_partial_type then begin
 					r := (fun() -> t);
@@ -1190,6 +1198,7 @@ let init_class ctx c p herits fields =
 				cf_overloads = [];
 			} in
 			ctx.curfield <- cf;
+			ctx.pass <- PTypeField;
 			bind_var ctx cf eo stat inline;
 			delay ctx PForce (fun() -> (!check_get)());
 			delay ctx PForce (fun() -> (!check_set)());
@@ -1362,13 +1371,26 @@ let init_module_type ctx usings (decl,p) =
 		) :: !usings
 	| EClass d ->
 		let c = (match get_type d.d_name with TClassDecl c -> c | _ -> assert false) in
+		let herits = d.d_flags in
 		if has_meta ":generic" c.cl_meta && c.cl_types <> [] then c.cl_kind <- KGeneric;
 		if c.cl_path = (["haxe";"macro"],"MacroType") then c.cl_kind <- KMacroType;
 		(* for debug only - we can't shadow ctx since it will get injected 'using' *)
 		ctx.curclass <- c;
+		c.cl_extern <- List.mem HExtern herits;
+		c.cl_interface <- List.mem HInterface herits;
 		delay ctx PForce (fun() -> check_overriding ctx c p);
 		delay ctx PForce (fun() -> check_interfaces ctx c p);
-		delay ctx PBuildClass (fun() -> init_class ctx c p d.d_flags d.d_data);
+		delay ctx PSetInherit (fun() -> set_heritance ctx c herits p);
+		let build() = 
+			c.cl_build <- (fun()->());
+			flush_pass ctx PSetInherit "build";
+			init_class ctx c p d.d_flags d.d_data
+		in
+		let old = ctx.pass in
+		ctx.pass <- PBuildClass;
+		c.cl_build <- make_pass ctx build;
+		delay ctx PBuildClass (fun() -> c.cl_build());
+		ctx.pass <- old;
 		ctx.curclass <- null_class;
 	| EEnum d ->
 		let e = (match get_type d.d_name with TEnumDecl e -> e | _ -> assert false) in
@@ -1577,7 +1599,6 @@ let type_module ctx m file tdecls loadp =
 	(* enter the next pass *)
 	let usings = ref [] in
 	delay ctx PInitModuleTypes (fun() -> List.iter (init_module_type ctx usings) tdecls);
-	flush_pass ctx (if ctx.pass < PBuildClass then ctx.pass else PBuildClass) "type_module";
 	m
 
 let resolve_module_file com m remap p =
@@ -1670,7 +1691,7 @@ let load_module ctx m p =
 				raise (Forbid_package (inf,p::pl))
 	) in
 	add_dependency ctx.current m2;
-	flush_pass ctx (if ctx.pass < PBuildClass then ctx.pass else PBuildClass) "load_module";
+	if ctx.pass = PTypeField then flush_pass ctx PBuildClass "load_module";
 	m2
 
 ;;

+ 1 - 0
typer.ml

@@ -2021,6 +2021,7 @@ and type_expr ctx ?(need_val=true) (e,p) =
 		type_call ctx e el None p
 	| ENew (t,el) ->
 		let t = Typeload.load_instance ctx t p true in
+		flush_pass ctx PDefineConstructor "new";
 		let el, c , params = (match follow t with
 		| TInst ({cl_kind = KTypeParameter tl} as c,params) ->
 			(* first check field parameters, then class parameters *)