Skip to content

Commit

Permalink
CR: simplify
Browse files Browse the repository at this point in the history
  • Loading branch information
OlivierNicole committed Dec 6, 2024
1 parent 98e2706 commit 98ded44
Showing 1 changed file with 20 additions and 26 deletions.
46 changes: 20 additions & 26 deletions compiler/lib/effects.ml
Original file line number Diff line number Diff line change
Expand Up @@ -557,10 +557,9 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last =
@ (Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body)
, branch ))

let rewrite_instr ~target ~st (instr : instr) : instr list =
match target, instr with
| (`Cps | `Direct_style), Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed
->
let rewrite_instr ~st (instr : instr) : instr list =
match instr with
| Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed ->
(* When CPS-transforming with double translation enabled, there are no closures in
code that requires transforming, due to lambda lifiting. *)
assert (not (double_translate ()));
Expand All @@ -569,8 +568,7 @@ let rewrite_instr ~target ~st (instr : instr) : instr list =
let cps_params, cps_cont = Hashtbl.find st.closure_info pc in
st.in_cps := Var.Set.add x !(st.in_cps);
[ Let (x, Closure (cps_params, cps_cont)) ]
| ( (`Cps | `Direct_style)
, Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) ) -> (
| Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> (
match arity with
| Pc (Int a) ->
[ Let
Expand All @@ -580,8 +578,7 @@ let rewrite_instr ~target ~st (instr : instr) : instr list =
, [ size; Pc (Int (Targetint.succ a)) ] ) )
]
| _ -> assert false)
| (`Cps | `Direct_style), Let (x, Apply { f; args; _ })
when not (Var.Set.mem x st.cps_needed) ->
| Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) ->
(* At the moment, we turn into CPS any function not called with
the right number of parameter *)
assert (
Expand All @@ -590,7 +587,16 @@ let rewrite_instr ~target ~st (instr : instr) : instr list =
Var.idx f >= Var.Tbl.length st.flow_info.info_approximation
|| Global_flow.exact_call st.flow_info f (List.length args));
[ Let (x, Apply { f; args; exact = true }) ]
| `Cps, Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) ->
| Let (_, e) when effect_primitive_or_application e ->
(* For the CPS target, applications of CPS functions and effect primitives require
more work (allocating a continuation and/or modifying end-of-block branches) and
are handled in a specialized function. *)
assert false
| _ -> [ instr ]

let cps_instr ~st (instr : instr) : instr list =
match instr with
| Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) ->
(* The case when double translation is disabled should be taken care of by a prior
pass *)
assert (double_translate ());
Expand All @@ -600,18 +606,13 @@ let rewrite_instr ~target ~st (instr : instr) : instr list =
[ Let (unit, Constant (Int Targetint.zero))
; Let (x, Apply { exact; f; args = [ unit ] })
]
| (`Cps | `Direct_style), Let (_, e) when effect_primitive_or_application e ->
(* For the CPS target, applications of CPS functions and effect primitives require
more work (allocating a continuation and/or modifying end-of-block branches) and
are handled in a specialized function. *)
assert false
| `Cps, Let (_, Prim (Extern "caml_assume_no_perform", args)) ->
| Let (_, Prim (Extern "caml_assume_no_perform", args)) ->
invalid_arg
@@ Format.sprintf
"Internal primitive `caml_assume_no_perform` takes exactly 1 argument (%d \
given)"
(List.length args)
| (`Cps | `Direct_style), _ -> [ instr ]
| _ -> rewrite_instr ~st instr

let cps_block ~st ~k ~orig_pc block =
debug_print "cps_block %d\n" orig_pc;
Expand Down Expand Up @@ -709,18 +710,14 @@ let cps_block ~st ~k ~orig_pc block =
match rewritten_block with
| Some (body_prefix, last_instrs, last) ->
let body_prefix =
List.map body_prefix ~f:(fun i -> rewrite_instr ~target:`Cps ~st i)
|> List.concat
List.map body_prefix ~f:(fun i -> cps_instr ~st i) |> List.concat
in
body_prefix @ last_instrs, last
| None ->
let last_instrs, last =
cps_last ~st ~alloc_jump_closures orig_pc block.branch ~k
in
let body =
List.map block.body ~f:(fun i -> rewrite_instr ~target:`Cps ~st i)
|> List.concat
in
let body = List.map block.body ~f:(fun i -> cps_instr ~st i) |> List.concat in
body @ last_instrs, last
in

Expand Down Expand Up @@ -773,10 +770,7 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block =
in
let body = List.concat_map block.body ~f:(fun i -> rewrite_instr i) in
{ block with body }
else
{ block with
body = List.concat_map ~f:(rewrite_instr ~target:`Direct_style ~st) block.body
}
else { block with body = List.concat_map ~f:(rewrite_instr ~st) block.body }

(* Apply a substitution in a set of blocks, including to bound variables *)
let subst_bound_in_blocks blocks s =
Expand Down

0 comments on commit 98ded44

Please sign in to comment.