Skip to content

Commit

Permalink
Revert "Allow unboxing to detect and delete dead code (#1676)"
Browse files Browse the repository at this point in the history 
This reverts commit 1a58792.
  • Loading branch information
@mshinwell
mshinwell authored Jun 13, 2024
1 parent 12ba4d9 commit 8507632
Show file tree
Hide file tree
Showing 20 changed files with 286 additions and 392 deletions.
202 changes: 94 additions & 108 deletions middle_end/flambda2/simplify/apply_cont_rewrite.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@ type used =
type t =
{ original_params_usage : used list;
extra_params_usage : used list;
extra_args : EA.t list Or_invalid.t Id.Map.t;
extra_args : EA.t list Id.Map.t;
original_params : Bound_parameters.t;
extra_params : Bound_parameters.t
}
Expand Down Expand Up @@ -54,8 +54,8 @@ let [@ocamlformat "disable"] print ppf
)@]"
print_params_used (original_params, original_params_usage)
print_params_used (extra_params, extra_params_usage)
(Id.Map.print (Or_invalid.print
(Format.pp_print_list ~pp_sep:Format.pp_print_space EA.print)))
(Id.Map.print
(Format.pp_print_list ~pp_sep:Format.pp_print_space EA.print))
extra_args

let does_nothing t =
Expand Down Expand Up @@ -145,96 +145,92 @@ let extra_args_list rewrite id =
try Id.Map.find id rewrite.extra_args
with Not_found -> (
match rewrite.extra_params_usage with
| [] -> Or_invalid.Ok []
| [] -> []
| _ :: _ ->
Misc.fatal_errorf
"Apply_cont_rewrite.extra_args_list:@ Could not find extra args but \
extra params were not empty")

let make_rewrite rewrite ~ctx id args : _ Or_invalid.t =
let make_rewrite rewrite ~ctx id args =
let invariant_args, args =
partition_used args rewrite.original_params_usage
in
match extra_args_list rewrite id with
| Or_invalid.Invalid -> Invalid
| Or_invalid.Ok extra_args_list ->
let extra_invariant_args_rev, extra_args_rev, extra_lets, _ =
List.fold_left2
(fun ( extra_invariant_args_rev,
extra_args_rev,
extra_lets,
required_by_other_extra_args ) (arg : EA.t) used ->
(* Some extra_args computation can depend on other extra args. But
those required extra args might not be needed as argument to the
continuation. But we want to keep the let bindings.
[required_by_other_extra_args] tracks that dependency. It is the
set of free variables of [extra_args_rev] and
[extra_invariant_args_rev] *)
let extra_arg, extra_let, free_names, defined_names =
match arg with
| Already_in_scope simple ->
simple, [], Simple.free_names simple, Name_occurrences.empty
| New_let_binding (temp, prim) ->
let extra_let =
( Bound_var.create temp Name_mode.normal,
Code_size.prim prim,
Flambda.Named.create_prim prim Debuginfo.none )
in
( Simple.var temp,
[extra_let],
Flambda_primitive.free_names prim,
Name_occurrences.singleton_variable temp Name_mode.normal )
| New_let_binding_with_named_args (temp, gen_prim) ->
let prim =
match (ctx : rewrite_apply_cont_ctx) with
| Apply_expr function_return_values ->
gen_prim function_return_values
| Apply_cont ->
Misc.fatal_errorf
"Apply_cont rewrites should not need to name arguments, \
since they are already named."
in
let extra_let =
( Bound_var.create temp Name_mode.normal,
Code_size.prim prim,
Flambda.Named.create_prim prim Debuginfo.none )
in
( Simple.var temp,
[extra_let],
Flambda_primitive.free_names prim,
Name_occurrences.singleton_variable temp Name_mode.normal )
in
let required_let, extra_invariant_args_rev, extra_args_rev =
match used with
| Used ->
true, extra_invariant_args_rev, extra_arg :: extra_args_rev
| Used_as_invariant ->
true, extra_arg :: extra_invariant_args_rev, extra_args_rev
| Unused ->
( Name_occurrences.inter_domain_is_non_empty defined_names
required_by_other_extra_args,
extra_invariant_args_rev,
extra_args_rev )
in
if required_let
then
( extra_invariant_args_rev,
extra_args_rev,
extra_let @ extra_lets,
Name_occurrences.union free_names required_by_other_extra_args )
else
( extra_invariant_args_rev,
extra_args_rev,
extra_lets,
required_by_other_extra_args ))
([], [], [], Name_occurrences.empty)
extra_args_list rewrite.extra_params_usage
in
Ok
( extra_lets,
invariant_args
@ List.rev_append extra_invariant_args_rev args
@ List.rev extra_args_rev )
let extra_args_list = extra_args_list rewrite id in
let extra_invariant_args_rev, extra_args_rev, extra_lets, _ =
List.fold_left2
(fun ( extra_invariant_args_rev,
extra_args_rev,
extra_lets,
required_by_other_extra_args ) (arg : EA.t) used ->
(* Some extra_args computation can depend on other extra args. But those
required extra args might not be needed as argument to the
continuation. But we want to keep the let bindings.
[required_by_other_extra_args] tracks that dependency. It is the set
of free variables of [extra_args_rev] and
[extra_invariant_args_rev] *)
let extra_arg, extra_let, free_names, defined_names =
match arg with
| Already_in_scope simple ->
simple, [], Simple.free_names simple, Name_occurrences.empty
| New_let_binding (temp, prim) ->
let extra_let =
( Bound_var.create temp Name_mode.normal,
Code_size.prim prim,
Flambda.Named.create_prim prim Debuginfo.none )
in
( Simple.var temp,
[extra_let],
Flambda_primitive.free_names prim,
Name_occurrences.singleton_variable temp Name_mode.normal )
| New_let_binding_with_named_args (temp, gen_prim) ->
let prim =
match (ctx : rewrite_apply_cont_ctx) with
| Apply_expr function_return_values ->
gen_prim function_return_values
| Apply_cont ->
Misc.fatal_errorf
"Apply_cont rewrites should not need to name arguments, \
since they are already named."
in
let extra_let =
( Bound_var.create temp Name_mode.normal,
Code_size.prim prim,
Flambda.Named.create_prim prim Debuginfo.none )
in
( Simple.var temp,
[extra_let],
Flambda_primitive.free_names prim,
Name_occurrences.singleton_variable temp Name_mode.normal )
in
let required_let, extra_invariant_args_rev, extra_args_rev =
match used with
| Used -> true, extra_invariant_args_rev, extra_arg :: extra_args_rev
| Used_as_invariant ->
true, extra_arg :: extra_invariant_args_rev, extra_args_rev
| Unused ->
( Name_occurrences.inter_domain_is_non_empty defined_names
required_by_other_extra_args,
extra_invariant_args_rev,
extra_args_rev )
in
if required_let
then
( extra_invariant_args_rev,
extra_args_rev,
extra_let @ extra_lets,
Name_occurrences.union free_names required_by_other_extra_args )
else
( extra_invariant_args_rev,
extra_args_rev,
extra_lets,
required_by_other_extra_args ))
([], [], [], Name_occurrences.empty)
extra_args_list rewrite.extra_params_usage
in
( extra_lets,
invariant_args
@ List.rev_append extra_invariant_args_rev args
@ List.rev extra_args_rev )

let rewrite_exn_continuation rewrite id exn_cont =
let exn_cont_arity = Exn_continuation.arity exn_cont in
Expand Down Expand Up @@ -270,29 +266,19 @@ let rewrite_exn_continuation rewrite id exn_cont =
in
let _, extra_args1 =
let extra_args_list =
match extra_args_list rewrite id with
| Invalid ->
(* CR gbury: This is not supported for now, but adding support for it
should be relatively easy and straight-forward *)
Misc.fatal_error
"[Invalid] extra args are currently not allowed for exn continuation \
rewrites"
| Ok extra_args_list ->
List.map2
(fun (arg : EA.t) extra_param ->
match arg with
| Already_in_scope simple ->
simple, Bound_parameter.kind extra_param
| New_let_binding _ | New_let_binding_with_named_args _ ->
(* Note: this is unsupported for now. If we choose to support it
in the future, we must take care of not introducing a wrapper
continuation, which would come with its own
pushtrap/poptrap. *)
Misc.fatal_error
"[New_let_binding] are currently forbidden for exn \
continuation rewrites")
extra_args_list
(Bound_parameters.to_list rewrite.extra_params)
List.map2
(fun (arg : EA.t) extra_param ->
match arg with
| Already_in_scope simple -> simple, Bound_parameter.kind extra_param
| New_let_binding _ | New_let_binding_with_named_args _ ->
(* Note: this is unsupported for now. If we choose to support it in
the future, we must take care of not introducing a wrapper
continuation, which would come with its own pushtrap/poptrap. *)
Misc.fatal_error
"[New_let_binding] are currently forbidden for exn continuation \
rewrites")
(extra_args_list rewrite id)
(Bound_parameters.to_list rewrite.extra_params)
in
partition_used extra_args_list rewrite.extra_params_usage
in
Expand Down
3 changes: 1 addition & 2 deletions middle_end/flambda2/simplify/apply_cont_rewrite.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,8 +53,7 @@ val make_rewrite :
ctx:rewrite_apply_cont_ctx ->
Apply_cont_rewrite_id.t ->
Simple.t list ->
((Bound_var.t * Code_size.t * Flambda.Named.t) list * Simple.t list)
Or_invalid.t
(Bound_var.t * Code_size.t * Flambda.Named.t) list * Simple.t list

val rewrite_exn_continuation :
t -> Apply_cont_rewrite_id.t -> Exn_continuation.t -> Exn_continuation.t
55 changes: 25 additions & 30 deletions middle_end/flambda2/simplify/common_subexpression_elimination.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -132,32 +132,30 @@ let cse_with_eligible_lhs ~typing_env_at_fork ~cse_at_each_use ~params prev_cse
match (extra_bindings : EPA.t) with
| Empty -> fun arg -> find_param arg params
| Non_empty { extra_args; extra_params } -> (
match RI.Map.find id extra_args with
| Invalid -> fun _arg -> None
| Ok extra_args -> (
let rec find_name simple params args =
match args, params with
| [], [] -> None
| [], _ | _, [] ->
Misc.fatal_error "Mismatching params and args arity"
| arg :: args, param :: params -> (
match (arg : EA.t) with
| Already_in_scope arg when Simple.equal arg simple ->
(* If [param] has an extra equation associated to it, we
shouldn't propagate equations on it as it will mess with
the application of constraints later *)
if Name.Map.mem (BP.name param) extra_equations
then None
else Some (BP.simple param)
| Already_in_scope _ | New_let_binding _
| New_let_binding_with_named_args _ ->
find_name simple params args)
in
fun arg ->
match find_param arg params with
| None ->
find_name arg (Bound_parameters.to_list extra_params) extra_args
| Some _ as r -> r))
let extra_args = RI.Map.find id extra_args in
let rec find_name simple params args =
match args, params with
| [], [] -> None
| [], _ | _, [] ->
Misc.fatal_error "Mismatching params and args arity"
| arg :: args, param :: params -> (
match (arg : EA.t) with
| Already_in_scope arg when Simple.equal arg simple ->
(* If [param] has an extra equation associated to it, we
shouldn't propagate equations on it as it will mess with the
application of constraints later *)
if Name.Map.mem (BP.name param) extra_equations
then None
else Some (BP.simple param)
| Already_in_scope _ | New_let_binding _
| New_let_binding_with_named_args _ ->
find_name simple params args)
in
fun arg ->
match find_param arg params with
| None ->
find_name arg (Bound_parameters.to_list extra_params) extra_args
| Some _ as r -> r)
in
EP.Map.fold
(fun prim bound_to eligible ->
Expand Down Expand Up @@ -250,10 +248,7 @@ let join_one_cse_equation ~cse_at_each_use prim bound_to_map
let extra_args =
RI.Map.map (fun simple : EA.t -> Already_in_scope simple) bound_to
in
let extra_bindings =
EPA.add extra_bindings ~extra_param ~extra_args
~invalids:Apply_cont_rewrite_id.Set.empty
in
let extra_bindings = EPA.add extra_bindings ~extra_param ~extra_args in
let extra_equations =
(* For the primitives Is_int and Get_tag, they're strongly linked to
their argument: additional information on the cse parameter should
Expand Down
Loading

0 comments on commit 8507632

Please sign in to comment.