Skip to content

Fix simplify-exits #1108

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Feb 14, 2023
Merged

Fix simplify-exits #1108

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
107 changes: 65 additions & 42 deletions ocaml/lambda/simplif.ml
View file
Open in desktop
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