Skip to content

Commit db20e97

Browse files
EkdohibsEkdohibs
authored
flambda-backend: Fix simplify-exits (#1108)
1 parent 6a63906 commit db20e97

File tree

1 file changed

+65
-42
lines changed

1 file changed

+65
-42
lines changed

‎lambda/simplif.ml

Lines changed: 65 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -184,7 +184,7 @@ let simplify_exits lam =
184184
| Lsend(_k, m, o, ll, _, _, _, _) -> List.iter (count ~try_depth) (m::o::ll)
185185
| Levent(l, _) -> count ~try_depth l
186186
| Lifused(_v, l) -> count ~try_depth l
187-
| Lregion (l, _) -> count ~try_depth l
187+
| Lregion (l, _) -> count ~try_depth:(try_depth+1) l
188188

189189
and count_default ~try_depth sw = match sw.sw_failaction with
190190
| None -> ()
@@ -220,22 +220,28 @@ let simplify_exits lam =
220220
*)
221221

222222
let subst = Hashtbl.create 17 in
223-
let rec simplif ~try_depth = function
224-
| (Lvar _| Lmutvar _ | Lconst _) as l -> l
223+
let rec simplif ~layout ~try_depth l =
224+
(* layout is the expected layout of the result: [None] if we want to
225+
leave it unchanged, [Some layout] if we need to update the layout of
226+
the result to [layout]. *)
227+
let result_layout ly = Option.value layout ~default:ly in
228+
match l with
229+
| Lvar _| Lmutvar _ | Lconst _ -> l
225230
| Lapply ap ->
226-
Lapply{ap with ap_func = simplif ~try_depth ap.ap_func;
227-
ap_args = List.map (simplif ~try_depth) ap.ap_args}
231+
Lapply{ap with ap_func = simplif ~layout:None ~try_depth ap.ap_func;
232+
ap_args = List.map (simplif ~layout:None ~try_depth) ap.ap_args}
228233
| Lfunction{kind; params; return; mode; region; body = l; attr; loc} ->
229-
lfunction ~kind ~params ~return ~mode ~region ~body:(simplif ~try_depth l) ~attr ~loc
234+
lfunction ~kind ~params ~return ~mode ~region
235+
~body:(simplif ~layout:None ~try_depth l) ~attr ~loc
230236
| Llet(str, kind, v, l1, l2) ->
231-
Llet(str, kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
237+
Llet(str, kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2)
232238
| Lmutlet(kind, v, l1, l2) ->
233-
Lmutlet(kind, v, simplif ~try_depth l1, simplif ~try_depth l2)
239+
Lmutlet(kind, v, simplif ~layout:None ~try_depth l1, simplif ~layout ~try_depth l2)
234240
| Lletrec(bindings, body) ->
235-
Lletrec(List.map (fun (v, l) -> (v, simplif ~try_depth l)) bindings,
236-
simplif ~try_depth body)
241+
Lletrec(List.map (fun (v, l) -> (v, simplif ~layout:None ~try_depth l)) bindings,
242+
simplif ~layout ~try_depth body)
237243
| Lprim(p, ll, loc) -> begin
238-
let ll = List.map (simplif ~try_depth) ll in
244+
let ll = List.map (simplif ~layout:None ~try_depth) ll in
239245
match p, ll with
240246
(* Simplify Obj.with_tag *)
241247
| Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
@@ -250,21 +256,24 @@ let simplify_exits lam =
250256
| _ -> Lprim(p, ll, loc)
251257
end
252258
| Lswitch(l, sw, loc, kind) ->
253-
let new_l = simplif ~try_depth l
259+
let new_l = simplif ~layout:None ~try_depth l
254260
and new_consts =
255-
List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_consts
261+
List.map (fun (n, e) -> (n, simplif ~layout ~try_depth e)) sw.sw_consts
256262
and new_blocks =
257-
List.map (fun (n, e) -> (n, simplif ~try_depth e)) sw.sw_blocks
258-
and new_fail = Option.map (simplif ~try_depth) sw.sw_failaction in
263+
List.map (fun (n, e) -> (n, simplif ~layout ~try_depth e)) sw.sw_blocks
264+
and new_fail = Option.map (simplif ~layout ~try_depth) sw.sw_failaction in
259265
Lswitch
260266
(new_l,
261267
{sw with sw_consts = new_consts ; sw_blocks = new_blocks;
262268
sw_failaction = new_fail},
263-
loc, kind)
269+
loc, result_layout kind)
264270
| Lstringswitch(l,sw,d,loc, kind) ->
265271
Lstringswitch
266-
(simplif ~try_depth l,List.map (fun (s,l) -> s,simplif ~try_depth l) sw,
267-
Option.map (simplif ~try_depth) d,loc,kind)
272+
(simplif ~layout:None ~try_depth l,
273+
List.map (fun (s,l) -> s,simplif ~layout ~try_depth l) sw,
274+
Option.map (simplif ~layout ~try_depth) d,
275+
loc,
276+
result_layout kind)
268277
| Lstaticraise (i,[]) as l ->
269278
begin try
270279
let _,handler = Hashtbl.find subst i in
@@ -273,7 +282,7 @@ let simplify_exits lam =
273282
| Not_found -> l
274283
end
275284
| Lstaticraise (i,ls) ->
276-
let ls = List.map (simplif ~try_depth) ls in
285+
let ls = List.map (simplif ~layout:None ~try_depth) ls in
277286
begin try
278287
let xs,handler = Hashtbl.find subst i in
279288
let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in
@@ -295,43 +304,57 @@ let simplify_exits lam =
295304
| Not_found -> Lstaticraise (i,ls)
296305
end
297306
| Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2),_) ->
298-
Hashtbl.add subst i ([],simplif ~try_depth l2) ;
299-
simplif ~try_depth l1
307+
Hashtbl.add subst i ([],simplif ~layout ~try_depth l2) ;
308+
simplif ~layout ~try_depth l1
300309
| Lstaticcatch (l1,(i,xs),l2,kind) ->
301310
let {count; max_depth} = get_exit i in
302311
if count = 0 then
303312
(* Discard staticcatch: not matching exit *)
304-
simplif ~try_depth l1
313+
simplif ~layout ~try_depth l1
305314
else if
306315
count = 1 && max_depth <= try_depth then begin
307316
(* Inline handler if there is a single occurrence and it is not
308317
nested within an inner try..with *)
309318
assert(max_depth = try_depth);
310-
Hashtbl.add subst i (xs,simplif ~try_depth l2);
311-
simplif ~try_depth l1
319+
Hashtbl.add subst i (xs,simplif ~layout ~try_depth l2);
320+
simplif ~layout:(Some (result_layout kind)) ~try_depth l1
312321
end else
313-
Lstaticcatch (simplif ~try_depth l1, (i,xs), simplif ~try_depth l2, kind)
322+
Lstaticcatch (
323+
simplif ~layout ~try_depth l1,
324+
(i,xs),
325+
simplif ~layout ~try_depth l2,
326+
result_layout kind)
314327
| Ltrywith(l1, v, l2, kind) ->
315-
let l1 = simplif ~try_depth:(try_depth + 1) l1 in
316-
Ltrywith(l1, v, simplif ~try_depth l2, kind)
317-
| Lifthenelse(l1, l2, l3, kind) -> Lifthenelse(simplif ~try_depth l1,
318-
simplif ~try_depth l2, simplif ~try_depth l3, kind)
319-
| Lsequence(l1, l2) -> Lsequence(simplif ~try_depth l1, simplif ~try_depth l2)
320-
| Lwhile lw -> Lwhile {lw with wh_cond = simplif ~try_depth lw.wh_cond;
321-
wh_body = simplif ~try_depth lw.wh_body}
328+
let l1 = simplif ~layout ~try_depth:(try_depth + 1) l1 in
329+
Ltrywith(l1, v, simplif ~layout ~try_depth l2, result_layout kind)
330+
| Lifthenelse(l1, l2, l3, kind) ->
331+
Lifthenelse(
332+
simplif ~layout:None ~try_depth l1,
333+
simplif ~layout ~try_depth l2,
334+
simplif ~layout ~try_depth l3,
335+
result_layout kind)
336+
| Lsequence(l1, l2) ->
337+
Lsequence(
338+
simplif ~layout:None ~try_depth l1,
339+
simplif ~layout ~try_depth l2)
340+
| Lwhile lw -> Lwhile {
341+
lw with wh_cond = simplif ~layout:None ~try_depth lw.wh_cond;
342+
wh_body = simplif ~layout:None ~try_depth lw.wh_body}
322343
| Lfor lf ->
323-
Lfor {lf with for_from = simplif ~try_depth lf.for_from;
324-
for_to = simplif ~try_depth lf.for_to;
325-
for_body = simplif ~try_depth lf.for_body}
326-
| Lassign(v, l) -> Lassign(v, simplif ~try_depth l)
344+
Lfor {lf with for_from = simplif ~layout:None ~try_depth lf.for_from;
345+
for_to = simplif ~layout:None ~try_depth lf.for_to;
346+
for_body = simplif ~layout:None ~try_depth lf.for_body}
347+
| Lassign(v, l) -> Lassign(v, simplif ~layout:None ~try_depth l)
327348
| Lsend(k, m, o, ll, pos, mode, loc, layout) ->
328-
Lsend(k, simplif ~try_depth m, simplif ~try_depth o,
329-
List.map (simplif ~try_depth) ll, pos, mode, loc, layout)
330-
| Levent(l, ev) -> Levent(simplif ~try_depth l, ev)
331-
| Lifused(v, l) -> Lifused (v,simplif ~try_depth l)
332-
| Lregion (l, layout) -> Lregion (simplif ~try_depth l, layout)
349+
Lsend(k, simplif ~layout:None ~try_depth m, simplif ~layout:None ~try_depth o,
350+
List.map (simplif ~layout:None ~try_depth) ll, pos, mode, loc, layout)
351+
| Levent(l, ev) -> Levent(simplif ~layout ~try_depth l, ev)
352+
| Lifused(v, l) -> Lifused (v,simplif ~layout ~try_depth l)
353+
| Lregion (l, ly) -> Lregion (
354+
simplif ~layout ~try_depth:(try_depth + 1) l,
355+
result_layout ly)
333356
in
334-
simplif ~try_depth:0 lam
357+
simplif ~layout:None ~try_depth:0 lam
335358

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

0 commit comments

Comments
 (0)