From db20e9724c8d1b583f8d9cfe77cdaa8826e71f53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nathana=C3=ABlle=20Courant?= Date: Tue, 14 Feb 2023 17:11:16 +0100 Subject: [PATCH] flambda-backend: Fix simplify-exits (#1108) --- lambda/simplif.ml | 107 ++++++++++++++++++++++++++++------------------ 1 file changed, 65 insertions(+), 42 deletions(-) diff --git a/lambda/simplif.ml b/lambda/simplif.ml index ef420ec80a0..d637b33a3a5 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -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 -> () @@ -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"; _ }, @@ -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 @@ -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 @@ -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) ->