Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

selectgen.ml: cross-cutting handling of Proc.contains_calls

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14609 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit fa0f96ab2b23d5748ba56be1a66eb36ac0113a00 1 parent 5db6318
Gabriel Scherer authored
Showing with 58 additions and 11 deletions.
  1. +34 −11 asmcomp/selectgen.ml
  2. +24 −0 asmcomp/selectgen.mli
View
45 asmcomp/selectgen.ml
@@ -210,6 +210,37 @@ method virtual select_addressing :
method select_store addr arg =
(Istore(Word, addr), arg)
+(* call marking methods, documented in selectgen.mli *)
+
+method mark_call =
+ Proc.contains_calls := true
+
+method mark_tailcall = ()
+
+method mark_c_tailcall = ()
+
+method mark_instr = function
+ | Iop (Icall_ind | Icall_imm _ | Iextcall _) ->
+ self#mark_call
+ | Iop (Itailcall_ind | Itailcall_imm _) ->
+ self#mark_tailcall
+ | Iop (Ialloc _) ->
+ self#mark_call (* caml_alloc*, caml_garbage_collection *)
+ | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) ->
+ self#mark_c_tailcall (* caml_ml_array_bound_error *)
+ | Iraise raise_kind ->
+ begin match raise_kind with
+ | Lambda.Raise_notrace -> ()
+ | Lambda.Raise_regular | Lambda.Raise_reraise ->
+ if !Clflags.debug then (* PR#6239 *)
+ (* caml_stash_backtrace; we #mark_call rather than
+ #mark_c_tailcall to get a good stack backtrace *)
+ self#mark_call
+ end
+ | Itrywith _ ->
+ self#mark_call
+ | _ -> ()
+
(* Default instruction selection for operators *)
method select_operation op args =
@@ -437,8 +468,6 @@ method emit_expr env exp =
Some(self#emit_tuple ext_env simple_list)
end
| Cop(Craise (k, dbg), [arg]) ->
- if !Clflags.debug && k <> Lambda.Raise_notrace then
- Proc.contains_calls := true; (* PR#6239 *)
begin match self#emit_expr env arg with
None -> None
| Some r1 ->
@@ -458,7 +487,6 @@ method emit_expr env exp =
let dbg = debuginfo_op op in
match new_op with
Icall_ind ->
- Proc.contains_calls := true;
let r1 = self#emit_tuple env new_args in
let rarg = Array.sub r1 1 (Array.length r1 - 1) in
let rd = self#regs_for ty in
@@ -470,7 +498,6 @@ method emit_expr env exp =
self#insert_move_results loc_res rd stack_ofs;
Some rd
| Icall_imm lbl ->
- Proc.contains_calls := true;
let r1 = self#emit_tuple env new_args in
let rd = self#regs_for ty in
let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in
@@ -480,7 +507,6 @@ method emit_expr env exp =
self#insert_move_results loc_res rd stack_ofs;
Some rd
| Iextcall(lbl, alloc) ->
- Proc.contains_calls := true;
let (loc_arg, stack_ofs) =
self#emit_extcall_args env new_args in
let rd = self#regs_for ty in
@@ -489,7 +515,6 @@ method emit_expr env exp =
self#insert_move_results loc_res rd stack_ofs;
Some rd
| Ialloc _ ->
- Proc.contains_calls := true;
let rd = self#regs_for typ_addr in
let size = size_expr env (Ctuple new_args) in
self#insert (Iop(Ialloc size)) [||] rd;
@@ -564,7 +589,6 @@ method emit_expr env exp =
None
end
| Ctrywith(e1, v, e2) ->
- Proc.contains_calls := true;
let (r1, s1) = self#emit_sequence env e1 in
let rv = self#regs_for typ_addr in
let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in
@@ -701,7 +725,6 @@ method emit_tail env exp =
self#insert (Iop Itailcall_ind)
(Array.append [|r1.(0)|] loc_arg) [||]
end else begin
- Proc.contains_calls := true;
let rd = self#regs_for ty in
let loc_res = Proc.loc_results rd in
self#insert_move_args rarg loc_arg stack_ofs;
@@ -721,7 +744,6 @@ method emit_tail env exp =
self#insert_moves r1 loc_arg';
self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||]
end else begin
- Proc.contains_calls := true;
let rd = self#regs_for ty in
let loc_res = Proc.loc_results rd in
self#insert_move_args r1 loc_arg stack_ofs;
@@ -771,7 +793,6 @@ method emit_tail env exp =
let s2 = self#emit_tail_sequence new_env e2 in
self#insert (Icatch(nfail, s1, s2)) [||] [||]
| Ctrywith(e1, v, e2) ->
- Proc.contains_calls := true;
let (opt_r1, s1) = self#emit_sequence env e1 in
let rv = self#regs_for typ_addr in
let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in
@@ -811,9 +832,11 @@ method emit_fundecl f =
f.Cmm.fun_args rargs Tbl.empty in
self#insert_moves loc_arg rarg;
self#emit_tail env f.Cmm.fun_body;
+ let body = self#extract in
+ instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body;
{ fun_name = f.Cmm.fun_name;
fun_args = loc_arg;
- fun_body = self#extract;
+ fun_body = body;
fun_fast = f.Cmm.fun_fast;
fun_dbg = f.Cmm.fun_dbg }
View
24 asmcomp/selectgen.mli
@@ -58,6 +58,30 @@ class virtual selector_generic : object
(* Fill a freshly allocated block. Can be overridden for architectures
that do not provide Arch.offset_addressing. *)
+ method mark_call : unit
+ (* informs the code emitter that the current function is non-leaf:
+ it may perform a (non-tail) call; by default, sets
+ [Proc.contains_calls := true] *)
+
+ method mark_tailcall : unit
+ (* informs the code emitter that the current function may end with
+ a tail-call; by default, does nothing *)
+
+ method mark_c_tailcall : unit
+ (* informs the code emitter that the current function may call
+ a C function that never returns; by default, does nothing.
+
+ It is unecessary to save the stack pointer in this situation
+ (which is the main purpose of tracking leaf functions) but some
+ architectures still need to ensure that the stack is properly
+ aligned when the C function is called. This is achieved by
+ overloading this method to set [Proc.contains_calls := true] *)
+
+ method mark_instr : Mach.instruction_desc -> unit
+ (* dispatches on instructions to call one of the marking function
+ above; overloading this is useful if Ispecific instructions need
+ marking *)
+
(* The following method is the entry point and should not be overridden *)
method emit_fundecl : Cmm.fundecl -> Mach.fundecl
Please sign in to comment.
Something went wrong with that request. Please try again.