Skip to content

Commit

Permalink
Support for delayed Trywith handlers in backend/dataflow.ml (ocaml-fl…
Browse files Browse the repository at this point in the history 
…ambda#1173)

* Support for delayed Trywith hadlers in backend/dataflow.ml
* Trap stack printing in Mach
* Switch liveness to Dataflow
  • Loading branch information
@lthls
lthls authored Mar 16, 2023
1 parent 08f7018 commit c156bde
Show file tree
Hide file tree
Showing 3 changed files with 80 additions and 196 deletions.
33 changes: 26 additions & 7 deletions backend/dataflow.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,13 @@ let analyze ?(exnhandler = fun x -> x) ?(exnescape = D.bot) ~transfer instr =
and set_lbl n x =
Hashtbl.replace lbls n x in

let exn_from_trap_stack generic_exn (trap_stack : Mach.trap_stack) =
match trap_stack with
| Uncaught -> exnescape
| Generic_trap _ -> generic_exn
| Specific_trap (lbl, _) -> get_lbl lbl
in

let rec before end_ exn i =
match i.desc with
| Iend ->
Expand All @@ -54,29 +61,41 @@ let analyze ?(exnhandler = fun x -> x) ?(exnescape = D.bot) ~transfer instr =
(fun accu case -> D.join accu (before bx exn case))
D.bot cases in
transfer i ~next:b1 ~exn
| Icatch(rc, _trap_stack, handlers, body) ->
| Icatch(rc, trap_stack, handlers, body) ->
let bx = before end_ exn i.next in
begin match rc with
| Cmm.Nonrecursive ->
List.iter
(fun (n, _trap_stack, h) -> set_lbl n (before bx exn h))
(fun (n, trap_stack, h) ->
let exnh = exn_from_trap_stack exn trap_stack in
set_lbl n (before bx exnh h))
handlers
| Cmm.Recursive ->
let update changed (n, _trap_stack, h) =
let update changed (n, trap_stack, h) =
let b0 = get_lbl n in
let b1 = before bx exn h in
let exnh = exn_from_trap_stack exn trap_stack in
let b1 = before bx exnh h in
if D.lessequal b1 b0 then changed else (set_lbl n b1; true) in
while List.fold_left update false handlers do () done
end;
let b = before bx exn body in
let exnb = exn_from_trap_stack exn trap_stack in
let b = before bx exnb body in
transfer i ~next:b ~exn
| Iexit (n, _trap_actions) ->
transfer i ~next:(get_lbl n) ~exn
| Itrywith(body, _trywith_kind, (_trap_stack, handler)) ->
| Itrywith(body, Regular, (trap_stack, handler)) ->
let bx = before end_ exn i.next in
let bh = exnhandler (before bx exn handler) in
let exnh = exn_from_trap_stack exn trap_stack in
let bh = exnhandler (before bx exnh handler) in
let bb = before bx bh body in
transfer i ~next:bb ~exn
| Itrywith(body, Delayed nfail, (trap_stack, handler)) ->
let bx = before end_ exn i.next in
let exnh = exn_from_trap_stack exn trap_stack in
let bh = exnhandler (before bx exnh handler) in
set_lbl nfail bh;
let bb = before bx exn body in
transfer i ~next:bb ~exn
| Iraise _ ->
transfer i ~next:D.bot ~exn
in
Expand Down
211 changes: 31 additions & 180 deletions backend/liveness.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,209 +18,60 @@

open Mach

type liveness_env =
{ at_exit : (int * Reg.Set.t) list;
at_raise : Reg.Set.t;
last_regular_trywith_handler : Reg.Set.t;
free_conts_for_handlers : Numbers.Int.Set.t Numbers.Int.Map.t;
}
module Domain = struct
type t = Reg.Set.t
let bot = Reg.Set.empty
let join = Reg.Set.union
let lessequal = Reg.Set.subset
end

let initial_env fundecl =
{ at_exit = [];
at_raise = Reg.Set.empty;
last_regular_trywith_handler = Reg.Set.empty;
free_conts_for_handlers = Mach.free_conts_for_handlers fundecl;
}
module Analyzer = Dataflow.Backward(Domain)

let env_subset env1 env2 =
List.for_all2 (fun (nfail1, live_regs1) (nfail2, live_regs2) ->
nfail1 = nfail2 && Reg.Set.subset live_regs1 live_regs2)
env1.at_exit
env2.at_exit
&& Reg.Set.subset env1.at_raise env2.at_raise
&& Reg.Set.subset env1.last_regular_trywith_handler
env2.last_regular_trywith_handler

type cache_entry =
{ restricted_env : liveness_env; (* last used environment,
restricted to the live conts *)
at_join : Reg.Set.t; (* last used set at join *)
before_handler : Reg.Set.t; (* last computed result *)
}

(*
let print_cache ppf entry =
let pr = Printmach.regset in
Format.fprintf ppf "@[<v 2>at_join: @[%a@]@,at_exit: @[%a@]@,at_raise: @[%a@]@,trywith: @[%a@]@,result: @[%a@]@]"
pr entry.at_join
(Format.pp_print_list (fun ppf (n, regs) -> Format.fprintf ppf "%d -> %a" n pr regs)) entry.restricted_env.at_exit
pr entry.restricted_env.at_raise
pr entry.restricted_env.last_regular_trywith_handler
pr entry.before_handler
*)

let fixpoint_cache : cache_entry Numbers.Int.Map.t ref =
ref Numbers.Int.Map.empty

let reset_cache () = fixpoint_cache := Numbers.Int.Map.empty

let restrict_env env conts =
{ env with at_exit =
List.filter (fun (n, _) -> Numbers.Int.Set.mem n conts)
env.at_exit;
}

let find_live_at_exit env k =
try
List.assoc k env.at_exit
with
| Not_found -> Misc.fatal_error "Liveness.find_live_at_exit"

let env_from_trap_stack env ts =
let at_raise =
match ts with
| Uncaught -> Reg.Set.empty
| Generic_trap _ -> env.last_regular_trywith_handler
| Specific_trap (nfail, _) -> find_live_at_exit env nfail
in
{ env with at_raise; }

let rec live env i finally =
(* finally is the set of registers live after execution of the
instruction sequence.
The result of the function is the set of registers live just
before the instruction sequence.
The instruction i is annotated by the set of registers live across
the instruction. *)
let transfer i ~next ~exn =
match i.desc with
Iend ->
i.live <- finally;
finally
| Ireturn _ | Iop(Itailcall_ind) | Iop(Itailcall_imm _) ->
i.live <- Reg.Set.empty; (* no regs are live across *)
Reg.set_of_array i.arg
| Iop op ->
let after = live env i.next finally in
if operation_is_pure op (* no side effects *)
&& Reg.disjoint_set_array after i.res (* results are not used after *)
&& not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *)
&& not (Proc.regs_are_volatile i.res) (* is involved *)
if operation_is_pure op (* no side effects *)
&& Reg.disjoint_set_array next i.res (* results are not used after *)
&& not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *)
&& not (Proc.regs_are_volatile i.res) (* is involved *)
then begin
(* This operation is dead code. Ignore its arguments. *)
i.live <- after;
after
i.live <- next;
next
end else begin
let across_after = Reg.diff_set_array after i.res in
let across1 = Reg.diff_set_array next i.res in
let across =
(* Operations that can raise an exception (function calls,
bounds checks, allocations) can branch to the
nearest enclosing try ... with.
Hence, everything that must be live at the beginning of
the exception handler must also be live across this instr. *)
if operation_can_raise op
then Reg.Set.union across_after env.at_raise
else across_after in
then Reg.Set.union across1 exn
else across1 in
i.live <- across;
Reg.add_set_array across i.arg
end
| Iifthenelse(_test, ifso, ifnot) ->
let at_join = live env i.next finally in
let at_fork =
Reg.Set.union (live env ifso at_join) (live env ifnot at_join)
in
i.live <- at_fork;
Reg.add_set_array at_fork i.arg
| Iswitch(_index, cases) ->
let at_join = live env i.next finally in
let at_fork = ref Reg.Set.empty in
for i = 0 to Array.length cases - 1 do
at_fork := Reg.Set.union !at_fork (live env cases.(i) at_join)
done;
i.live <- !at_fork;
Reg.add_set_array !at_fork i.arg
| Icatch(rec_flag, ts, handlers, body) ->
let at_join = live (env_from_trap_stack env ts) i.next finally in
let aux env (nfail, ts, handler) (nfail', before_handler) =
assert(nfail = nfail');
let env = env_from_trap_stack env ts in
let free_conts = Numbers.Int.Map.find nfail env.free_conts_for_handlers in
let before_handler', restricted_env, do_update =
match Numbers.Int.Map.find nfail !fixpoint_cache with
| exception Not_found ->
let restricted_env = restrict_env env free_conts in
live env handler at_join, restricted_env, true
| cache ->
let restricted_env = restrict_env env free_conts in
if env_subset restricted_env cache.restricted_env
&& Reg.Set.equal at_join cache.at_join
then cache.before_handler, cache.restricted_env, false
else live env handler at_join, restricted_env, true
in
if do_update then begin
let cache_entry =
{ restricted_env;
at_join;
before_handler = before_handler';
}
in
fixpoint_cache := Numbers.Int.Map.add nfail cache_entry !fixpoint_cache
end;
nfail, Reg.Set.union before_handler before_handler'
in
let aux_equal (nfail, before_handler) (nfail', before_handler') =
assert(nfail = nfail');
Reg.Set.equal before_handler before_handler'
in
let rec fixpoint before_handlers =
let env = { env with at_exit = before_handlers @ env.at_exit; } in
let before_handlers' = List.map2 (aux env) handlers before_handlers in
match rec_flag with
| Cmm.Nonrecursive ->
before_handlers'
| Cmm.Recursive ->
if List.for_all2 aux_equal before_handlers before_handlers'
then before_handlers'
else fixpoint before_handlers'
in
let init_state =
List.map (fun (nfail, _ts, _handler) -> nfail, Reg.Set.empty) handlers
in
let before_handler = fixpoint init_state in
(* We could use handler.live instead of Reg.Set.empty as the initial
value but we would need to clean the live field before doing the
analysis (to remove remnants of previous passes). *)
let env = { env with at_exit = before_handler @ env.at_exit; } in
let before_body = live env body at_join in
i.live <- before_body;
before_body
| Iexit (nfail, _traps) ->
let this_live = find_live_at_exit env nfail in
i.live <- this_live ;
this_live
| Itrywith(body, kind, (ts, handler)) ->
let at_join = live env i.next finally in
let env_handler = env_from_trap_stack env ts in
let before_handler = live env_handler handler at_join in
let live_at_raise = Reg.Set.remove Proc.loc_exn_bucket before_handler in
let env =
match kind with
| Regular ->
{ env with at_raise = live_at_raise;
last_regular_trywith_handler = live_at_raise;
}
| Delayed nfail ->
{ env with at_exit = (nfail, live_at_raise) :: env.at_exit; }
in
let before_body = live env body at_join in
i.live <- before_body;
before_body
| Iifthenelse _
| Iswitch _ ->
i.live <- next;
Reg.add_set_array next i.arg
| Iend | Icatch _ | Iexit _ | Itrywith _ ->
i.live <- next;
next
| Iraise _ ->
i.live <- env.at_raise;
Reg.add_set_array env.at_raise i.arg
i.live <- exn;
Reg.add_set_array exn i.arg

let exnhandler before_handler =
Reg.Set.remove Proc.loc_exn_bucket before_handler

let fundecl f =
reset_cache ();
let initially_live = live (initial_env f) f.fun_body Reg.Set.empty in
let (initially_live, _) =
Analyzer.analyze ~exnhandler ~transfer f.fun_body in
(* Sanity check: only function parameters can be live at entrypoint *)
let wrong_live = Reg.Set.diff initially_live (Reg.set_of_array f.fun_args) in
if not (Reg.Set.is_empty wrong_live) then begin
Expand Down
32 changes: 23 additions & 9 deletions backend/printmach.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -82,6 +82,21 @@ let regsetaddr' ?(print_reg = reg) ppf s =
let regsetaddr ppf s = regsetaddr' ppf s
let trap_stack ppf (ts : Mach.trap_stack) =
let rec has_specific = function
| Uncaught -> false
| Generic_trap ts -> has_specific ts
| Specific_trap _ -> true
in
if has_specific ts then begin
let rec p ppf = function
| Uncaught -> Format.fprintf ppf "U"
| Generic_trap ts -> Format.fprintf ppf "G:%a" p ts
| Specific_trap (lbl, ts) -> Format.fprintf ppf "S%d:%a" lbl p ts
in
Format.fprintf ppf "<%a>" p ts
end else ()
let intcomp = function
| Isigned c -> Printf.sprintf " %ss " (Printcmm.integer_comparison c)
| Iunsigned c -> Printf.sprintf " %su " (Printcmm.integer_comparison c)
Expand Down Expand Up @@ -268,12 +283,11 @@ let rec instr ppf i =
fprintf ppf "@]@,%a@]" instr cases.(i)
done;
fprintf ppf "@,endswitch"
| Icatch(flag, _ts, handlers, body) ->
fprintf ppf "@[<v 2>catch%a@,%a@;<0 -2>with"
Printcmm.rec_flag flag instr body;
let h (nfail, _trap_stack, handler) =
(* CR vlaviron: print the trap stacks ? *)
fprintf ppf "(%d)@,%a@;" nfail instr handler in
| Icatch(flag, ts, handlers, body) ->
fprintf ppf "@[<v 2>catch%a%a@,%a@;<0 -2>with"
Printcmm.rec_flag flag trap_stack ts instr body;
let h (nfail, ts, handler) =
fprintf ppf "(%d)%a@,%a@;" nfail trap_stack ts instr handler in
let rec aux = function
| [] -> ()
| [v] -> h v
Expand All @@ -286,9 +300,9 @@ let rec instr ppf i =
fprintf ppf "@;<0 -2>endcatch@]"
| Iexit (i, traps) ->
fprintf ppf "exit%a(%d)" Printcmm.trap_action_list traps i
| Itrywith(body, kind, (_ts, handler)) ->
fprintf ppf "@[<v 2>try%a@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]"
Printcmm.trywith_kind kind instr body instr handler
| Itrywith(body, kind, (ts, handler)) ->
fprintf ppf "@[<v 2>try%a@,%a@;<0 -2>with%a@,%a@;<0 -2>endtry@]"
Printcmm.trywith_kind kind instr body trap_stack ts instr handler
| Iraise k ->
fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0)
end;
Expand Down

0 comments on commit c156bde

Please sign in to comment.