Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Reorganize switch handling

master
Pierre Chambart 2016-07-26 15:11:19 +02:00
parent f5573b0f6b
commit 6ee86d523d
3 changed files with 79 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
middle_end/inline_and_simplify.ml
View File

@ -187,6 +187,10 @@ let approx_for_allocated_const (const : Allocated_const.t) =
A.value_immutable_float_array
(Array.map A.value_float (Array.of_list a))
type filtered_switch_branches =
| Must_be_taken of Flambda.t
| Can_be_taken of (int * Flambda.t) list
(* Determine whether a given closure ID corresponds directly to a variable
(bound to a closure) in the given environment. This happens when the body
of a [let rec]-bound function refers to another in the same set of closures.
@ -1256,7 +1260,34 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
[Switch]. (This should also make the [Let] that binds [arg] redundant,
meaning that it too can be eliminated.) *)
simplify_free_variable env arg ~f:(fun env arg arg_approx ->
let get_failaction () : Flambda.t =
let rec filter_branches filter branches compatible_branches =
match branches with
| [] -> Can_be_taken compatible_branches
| (c, lam) as branch :: branches ->
match filter arg_approx c with
| A.Cannot_be_taken ->
filter_branches filter branches compatible_branches
| A.Can_be_taken ->
filter_branches filter branches (branch :: compatible_branches)
| A.Must_be_taken ->
Must_be_taken lam
in
let filtered_consts =
filter_branches A.potentially_taken_const_switch_branch sw.consts []
in
let filtered_blocks =
filter_branches A.potentially_taken_block_switch_branch sw.blocks []
in
begin match filtered_consts, filtered_blocks with
| Must_be_taken _, Must_be_taken _ ->
assert false
| Must_be_taken branch, _
| _, Must_be_taken branch ->
let lam, r = simplify env r branch in
lam, R.map_benefit r B.remove_branch
| Can_be_taken consts, Can_be_taken blocks ->
match consts, blocks, sw.failaction with
| [], [], None ->
(* If the switch is applied to a statically-known value that does not
match any case:
* if there is a default action take that case;
@ -1269,40 +1300,6 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
match v with <-- This match is unreachable
| Float f -> ...]
*)
match sw.failaction with
| None -> Proved_unreachable
| Some f -> f
in
let consts =
List.filter
(fun (c, _) -> A.potentially_taken_const_switch_branch arg_approx c)
sw.consts
in
let blocks =
List.filter
(fun (c, _) -> A.potentially_taken_block_switch_branch arg_approx c)
sw.blocks
in
begin match arg_approx.descr with
| Value_int i
| Value_constptr i ->
let lam =
try List.assoc i consts
with Not_found -> get_failaction ()
in
let lam, r = simplify env r lam in
lam, R.map_benefit r B.remove_branch
| Value_block (tag, _) ->
let tag = Tag.to_int tag in
let lam =
try List.assoc tag blocks
with Not_found -> get_failaction ()
in
let lam, r = simplify env r lam in
lam, R.map_benefit r B.remove_branch
| _ ->
match consts, blocks, sw.failaction with
| [], [], None ->
Proved_unreachable, ret r A.value_bottom
| [_, branch], [], None
| [], [_, branch], None

78
middle_end/simple_value_approx.ml
View File

@ -795,25 +795,30 @@ let check_approx_for_string t : string option =
| Value_extern _ | Value_boxed_int _ | Value_symbol _ ->
None
type switch_branch_selection =
| Cannot_be_taken
| Can_be_taken
| Must_be_taken
let potentially_taken_const_switch_branch t branch =
match t.descr with
| (Value_unresolved _
| Value_unknown _
| Value_extern _
| Value_symbol _) ->
| Value_unresolved _
| Value_unknown _
| Value_extern _
| Value_symbol _ ->
(* In theory symbol cannot contain integers but this shouldn't
matter as this will always be an imported approximation *)
true
| (Value_constptr i | Value_int i) ->
i = branch
| Value_char c ->
Char.code c = branch
| ( Value_block _ | Value_float _ | Value_float_array _
| Value_string _ | Value_closure _ | Value_set_of_closures _
| Value_boxed_int _ | Value_bottom ) ->
false
Can_be_taken
| Value_constptr i | Value_int i when i = branch ->
Must_be_taken
| Value_char c when Char.code c = branch ->
Must_be_taken
| Value_constptr _ | Value_int _ | Value_char _ ->
Cannot_be_taken
| Value_block _ | Value_float _ | Value_float_array _
| Value_string _ | Value_closure _ | Value_set_of_closures _
| Value_boxed_int _ | Value_bottom ->
Cannot_be_taken
let potentially_taken_block_switch_branch t tag =
match t.descr with
@ -821,28 +826,25 @@ let potentially_taken_block_switch_branch t tag =
| Value_unknown _
| Value_extern _
| Value_symbol _) ->
true
Can_be_taken
| (Value_constptr _ | Value_int _| Value_char _) ->
false
| Value_block (block_tag, _) ->
Tag.to_int block_tag = tag
| Value_float _ ->
tag = Obj.double_tag
| Value_float_array _ ->
tag = Obj.double_array_tag
| Value_string _ ->
tag = Obj.string_tag
| (Value_closure _ | Value_set_of_closures _) ->
tag = Obj.closure_tag || tag = Obj.infix_tag
| Value_boxed_int _ ->
tag = Obj.custom_tag
Cannot_be_taken
| Value_block (block_tag, _) when Tag.to_int block_tag = tag ->
Must_be_taken
| Value_float _ when tag = Obj.double_tag ->
Must_be_taken
| Value_float_array _ when tag = Obj.double_array_tag ->
Must_be_taken
| Value_string _ when tag = Obj.string_tag ->
Must_be_taken
| (Value_closure _ | Value_set_of_closures _)
when tag = Obj.closure_tag || tag = Obj.infix_tag ->
Can_be_taken
| Value_boxed_int _ when tag = Obj.custom_tag ->
Must_be_taken
| Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _
| Value_string _ | Value_float_array _ | Value_boxed_int _ ->
Cannot_be_taken
| Value_bottom ->
false
Cannot_be_taken

9
middle_end/simple_value_approx.mli
View File

@ -413,6 +413,11 @@ val float_array_as_constant : value_float_array -> float list option
(** Returns the value if it can be proved to be a constant string *)
val check_approx_for_string : t -> string option
type switch_branch_selection =
| Cannot_be_taken
| Can_be_taken
| Must_be_taken
(** Check that the branch is compatible with the approximation *)
val potentially_taken_const_switch_branch : t -> int -> bool
val potentially_taken_block_switch_branch : t -> int -> bool
val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection
val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection