Skip to content

Commit

Permalink
flambda-backend: Fix simplify-exits (#1108)
Browse files Browse the repository at this point in the history
  • Loading branch information
@Ekdohibs
Ekdohibs authored Feb 14, 2023
1 parent 6a63906 commit db20e97
Showing 1 changed file with 65 additions and 42 deletions.
107 changes: 65 additions & 42 deletions lambda/simplif.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -184,7 +184,7 @@ let simplify_exits lam =
| Lsend(_k, m, o, ll, _, _, _, _) -> List.iter (count ~try_depth) (m::o::ll)
| Levent(l, _) -> count ~try_depth l
| Lifused(_v, l) -> count ~try_depth l
| Lregion (l, _) -> count ~try_depth l
| Lregion (l, _) -> count ~try_depth:(try_depth+1) l

and count_default ~try_depth sw = match sw.sw_failaction with
| None -> ()
Expand Down Expand Up @@ -220,22 +220,28 @@ let simplify_exits lam =
*)

let subst = Hashtbl.create 17 in
let rec simplif ~try_depth = function
| (Lvar _| Lmutvar _ | Lconst _) as l -> l
let rec simplif ~layout ~try_depth l =
(* layout is the expected layout of the result: [None] if we want to
leave it unchanged, [Some layout] if we need to update the layout of
the result to [layout]. *)
let result_layout ly = Option.value layout ~default:ly in
match l with
| Lvar _| Lmutvar _ | Lconst _ -> l
| Lapply ap ->
Lapply{ap with ap_func = simplif ~try_depth ap.ap_func;
ap_args = List.map (simplif ~try_depth) ap.ap_args}
Lapply{ap with ap_func = simplif ~layout:None ~try_depth ap.ap_func;
ap_args = List.map (simplif ~layout:None ~try_depth) ap.ap_args}
| Lfunction{kind; params; return; mode; region; body = l; attr; loc} ->
lfunction ~kind ~params ~return ~mode ~region ~body:(simplif ~try_depth l) ~attr ~loc
lfunction ~kind ~params ~return ~mode ~region
~body:(simplif ~layout:None ~try_depth l) ~attr ~loc
| Llet(str, kind, v, l1, l2) ->
Llet(str, kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
Llet(str, kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2)
| Lmutlet(kind, v, l1, l2) ->
Lmutlet(kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
Lmutlet(kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2)
| Lletrec(bindings, body) ->
Lletrec(List.map (fun (v, l) -> (v, simplif ~try_depth l)) bindings,
simplif ~try_depth body)
Lletrec(List.map (fun (v, l) -> (v, simplif ~layout:None ~try_depth l)) bindings,
simplif ~layout ~try_depth body)
| Lprim(p, ll, loc) -> begin
let ll = List.map (simplif ~try_depth) ll in
let ll = List.map (simplif ~layout:None ~try_depth) ll in
match p, ll with
(* Simplify Obj.with_tag *)
| Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
Expand All @@ -250,21 +256,24 @@ let simplify_exits lam =
| _ -> Lprim(p, ll, loc)
end
| Lswitch(l, sw, loc, kind) ->
let new_l = simplif ~try_depth l
let new_l = simplif ~layout:None ~try_depth l
and new_consts =
List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_consts
List.map (fun (n, e) -> (n, simplif ~layout ~try_depth e)) sw.sw_consts
and new_blocks =
List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_blocks
and new_fail = Option.map (simplif ~try_depth) sw.sw_failaction in
List.map (fun (n, e) -> (n, simplif ~layout ~try_depth e)) sw.sw_blocks
and new_fail = Option.map (simplif ~layout ~try_depth) sw.sw_failaction in
Lswitch
(new_l,
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
sw_failaction = new_fail},
loc, kind)
loc, result_layout kind)
| Lstringswitch(l,sw,d,loc, kind) ->
Lstringswitch
(simplif ~try_depth l,List.map (fun (s,l) -> s,simplif ~try_depth l) sw,
Option.map (simplif ~try_depth) d,loc,kind)
(simplif ~layout:None ~try_depth l,
List.map (fun (s,l) -> s,simplif ~layout ~try_depth l) sw,
Option.map (simplif ~layout ~try_depth) d,
loc,
result_layout kind)
| Lstaticraise (i,[]) as l ->
begin try
let _,handler = Hashtbl.find subst i in
Expand All @@ -273,7 +282,7 @@ let simplify_exits lam =
| Not_found -> l
end
| Lstaticraise (i,ls) ->
let ls = List.map (simplif ~try_depth) ls in
let ls = List.map (simplif ~layout:None ~try_depth) ls in
begin try
let xs,handler = Hashtbl.find subst i in
let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in
Expand All @@ -295,43 +304,57 @@ let simplify_exits lam =
| Not_found -> Lstaticraise (i,ls)
end
| Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2),_) ->
Hashtbl.add subst i ([],simplif ~try_depth l2) ;
simplif ~try_depth l1
Hashtbl.add subst i ([],simplif ~layout ~try_depth l2) ;
simplif ~layout ~try_depth l1
| Lstaticcatch (l1,(i,xs),l2,kind) ->
let {count; max_depth} = get_exit i in
if count = 0 then
(* Discard staticcatch: not matching exit *)
simplif ~try_depth l1
simplif ~layout ~try_depth l1
else if
count = 1 && max_depth <= try_depth then begin
(* Inline handler if there is a single occurrence and it is not
nested within an inner try..with *)
assert(max_depth = try_depth);
Hashtbl.add subst i (xs,simplif ~try_depth l2);
simplif ~try_depth l1
Hashtbl.add subst i (xs,simplif ~layout ~try_depth l2);
simplif ~layout:(Some (result_layout kind)) ~try_depth l1
end else
Lstaticcatch (simplif ~try_depth l1, (i,xs), simplif ~try_depth l2, kind)
Lstaticcatch (
simplif ~layout ~try_depth l1,
(i,xs),
simplif ~layout ~try_depth l2,
result_layout kind)
| Ltrywith(l1, v, l2, kind) ->
let l1 = simplif ~try_depth:(try_depth + 1) l1 in
Ltrywith(l1, v, simplif ~try_depth l2, kind)
| Lifthenelse(l1, l2, l3, kind) -> Lifthenelse(simplif ~try_depth l1,
simplif ~try_depth l2, simplif ~try_depth l3, kind)
| Lsequence(l1, l2) -> Lsequence(simplif ~try_depth l1, simplif ~try_depth l2)
| Lwhile lw -> Lwhile {lw with wh_cond = simplif ~try_depth lw.wh_cond;
wh_body = simplif ~try_depth lw.wh_body}
let l1 = simplif ~layout ~try_depth:(try_depth + 1) l1 in
Ltrywith(l1, v, simplif ~layout ~try_depth l2, result_layout kind)
| Lifthenelse(l1, l2, l3, kind) ->
Lifthenelse(
simplif ~layout:None ~try_depth l1,
simplif ~layout ~try_depth l2,
simplif ~layout ~try_depth l3,
result_layout kind)
| Lsequence(l1, l2) ->
Lsequence(
simplif ~layout:None ~try_depth l1,
simplif ~layout ~try_depth l2)
| Lwhile lw -> Lwhile {
lw with wh_cond = simplif ~layout:None ~try_depth lw.wh_cond;
wh_body = simplif ~layout:None ~try_depth lw.wh_body}
| Lfor lf ->
Lfor {lf with for_from = simplif ~try_depth lf.for_from;
for_to = simplif ~try_depth lf.for_to;
for_body = simplif ~try_depth lf.for_body}
| Lassign(v, l) -> Lassign(v, simplif ~try_depth l)
Lfor {lf with for_from = simplif ~layout:None ~try_depth lf.for_from;
for_to = simplif ~layout:None ~try_depth lf.for_to;
for_body = simplif ~layout:None ~try_depth lf.for_body}
| Lassign(v, l) -> Lassign(v, simplif ~layout:None ~try_depth l)
| Lsend(k, m, o, ll, pos, mode, loc, layout) ->
Lsend(k, simplif ~try_depth m, simplif ~try_depth o,
List.map (simplif ~try_depth) ll, pos, mode, loc, layout)
| Levent(l, ev) -> Levent(simplif ~try_depth l, ev)
| Lifused(v, l) -> Lifused (v,simplif ~try_depth l)
| Lregion (l, layout) -> Lregion (simplif ~try_depth l, layout)
Lsend(k, simplif ~layout:None ~try_depth m, simplif ~layout:None ~try_depth o,
List.map (simplif ~layout:None ~try_depth) ll, pos, mode, loc, layout)
| Levent(l, ev) -> Levent(simplif ~layout ~try_depth l, ev)
| Lifused(v, l) -> Lifused (v,simplif ~layout ~try_depth l)
| Lregion (l, ly) -> Lregion (
simplif ~layout ~try_depth:(try_depth + 1) l,
result_layout ly)
in
simplif ~try_depth:0 lam
simplif ~layout:None ~try_depth:0 lam

(* Compile-time beta-reduction of functions immediately applied:
Lapply(Lfunction(Curried, params, body), args, loc) ->
Expand Down

0 comments on commit db20e97

Please sign in to comment.