|
|
@@ -139,6 +139,7 @@ type context =
|
|
|
mutable ctx_return_from_internal_node : bool;
|
|
|
mutable ctx_debug : bool;
|
|
|
mutable ctx_debug_type : bool;
|
|
|
+ mutable ctx_do_safe_point : bool;
|
|
|
mutable ctx_real_this_ptr : bool;
|
|
|
mutable ctx_dynamic_this_ptr : bool;
|
|
|
mutable ctx_static_id_curr : int;
|
|
|
@@ -160,6 +161,7 @@ let new_context writer debug =
|
|
|
ctx_debug_type = debug;
|
|
|
ctx_return_from_block = false;
|
|
|
ctx_return_from_internal_node = false;
|
|
|
+ ctx_do_safe_point = false;
|
|
|
ctx_real_this_ptr = true;
|
|
|
ctx_dynamic_this_ptr = false;
|
|
|
ctx_static_id_curr = 0;
|
|
|
@@ -644,6 +646,23 @@ let tmatch_params_to_args params =
|
|
|
List.fold_left
|
|
|
(fun acc (v,t) -> incr n; match v with None -> acc | Some v -> (v,t,!n) :: acc) [] l)
|
|
|
|
|
|
+exception AlreadySafe;;
|
|
|
+exception PossibleRecursion;;
|
|
|
+
|
|
|
+let expression_needs_safe_point expression =
|
|
|
+ try (
|
|
|
+ let rec needs_safe expression always_executed =
|
|
|
+ (* TODO - fill this out *)
|
|
|
+ Type.iter (fun expr -> match expr.eexpr with
|
|
|
+ | TNew (_,_,_) when always_executed -> raise AlreadySafe
|
|
|
+ | TCall (_,_) -> raise PossibleRecursion
|
|
|
+ | _ -> needs_safe expr false;
|
|
|
+ ) expression in
|
|
|
+ needs_safe expression true;
|
|
|
+ false;
|
|
|
+ ) with AlreadySafe -> false
|
|
|
+ | PossibleRecursion -> true
|
|
|
+;;
|
|
|
|
|
|
(*
|
|
|
This is the big one.
|
|
|
@@ -666,6 +685,8 @@ let rec gen_expression ctx retval expression =
|
|
|
ctx.ctx_return_from_block <- false;
|
|
|
let return_from_internal_node = ctx.ctx_return_from_internal_node in
|
|
|
ctx.ctx_return_from_internal_node <- false;
|
|
|
+ let do_safe_point = ctx.ctx_do_safe_point in
|
|
|
+ ctx.ctx_do_safe_point <- false;
|
|
|
|
|
|
(* Annotate source code with debug - can get a bit verbose. Mainly for debugging code gen,
|
|
|
rather than the run time *)
|
|
|
@@ -783,13 +804,16 @@ let rec gen_expression ctx retval expression =
|
|
|
|
|
|
let pop_real_this_ptr = clear_real_this_ptr ctx true in
|
|
|
|
|
|
+ let do_safe = expression_needs_safe_point func_def.tf_expr in
|
|
|
if (block) then begin
|
|
|
writer#begin_block;
|
|
|
+ ctx.ctx_do_safe_point <- do_safe;
|
|
|
gen_expression ctx false func_def.tf_expr;
|
|
|
output_i "return null();\n";
|
|
|
writer#end_block;
|
|
|
end else begin
|
|
|
writer#begin_block;
|
|
|
+ if (do_safe) then output_i "__SAFE_POINT;\n";
|
|
|
(* Save old values, and equalize for new input ... *)
|
|
|
let old_used = ctx.ctx_static_id_used in
|
|
|
let old_curr = ctx.ctx_static_id_curr in
|
|
|
@@ -1075,6 +1099,7 @@ let rec gen_expression ctx retval expression =
|
|
|
)
|
|
|
end else begin
|
|
|
writer#begin_block;
|
|
|
+ if (do_safe_point) then output_i "__SAFE_POINT\n";
|
|
|
(* Save old values, and equalize for new input ... *)
|
|
|
let old_used = ctx.ctx_static_id_used in
|
|
|
let old_curr = ctx.ctx_static_id_curr in
|
|
|
@@ -1222,6 +1247,7 @@ let rec gen_expression ctx retval expression =
|
|
|
output_i "";
|
|
|
gen_expression ctx false loop;
|
|
|
output ";\n";
|
|
|
+ output_i "__SAFE_POINT\n";
|
|
|
ctx.ctx_writer#end_block;
|
|
|
| TIf (condition, if_expr, optional_else_expr) ->
|
|
|
let output_if_expr expr terminate =
|
|
|
@@ -1275,6 +1301,7 @@ let rec gen_expression ctx retval expression =
|
|
|
output "while(";
|
|
|
gen_expression ctx true condition;
|
|
|
output ")";
|
|
|
+ ctx.ctx_do_safe_point <- true;
|
|
|
gen_expression ctx false repeat
|
|
|
| TWhile (condition, repeat, Ast.DoWhile ) ->
|
|
|
output "do";
|
|
|
@@ -1495,6 +1522,7 @@ let gen_field ctx class_name ptr_name is_static is_external is_interface field =
|
|
|
output (gen_arg_list function_def.tf_args "__o_");
|
|
|
output ")";
|
|
|
|
|
|
+ ctx.ctx_do_safe_point <- expression_needs_safe_point function_def.tf_expr;
|
|
|
if (has_default_values function_def.tf_args) then begin
|
|
|
ctx.ctx_writer#begin_block;
|
|
|
generate_default_values ctx function_def.tf_args "__o_";
|
Hugh Sanderson