Skip to content

More assertions for local alloc and letrec #1081

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 6 commits into from
Feb 21, 2023
Merged

More assertions for local alloc and letrec #1081

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
04d8ecb
More assertions for local alloc and letrec
stedolan Jan 18, 2023
545d4e4
Copy Cmmgen changes to ocaml/
stedolan Jan 23, 2023
50f5133
Add more details to Flambda2 locals assertion
stedolan Jan 23, 2023
3491d7e
Fix assertion in Cmmgen.expr_size
stedolan Jan 24, 2023
a4efcd5
fmt
stedolan Feb 8, 2023
853a4ba
squash a warning
stedolan Feb 8, 2023
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
48 changes: 29 additions & 19 deletions backend/cmmgen.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -148,18 +148,22 @@ let get_field env ptr n dbg =
get_field_gen mut ptr n dbg

type rhs_kind =
| RHS_block of int
| RHS_infix of { blocksize : int; offset : int }
| RHS_floatblock of int
| RHS_block of Lambda.alloc_mode * int
| RHS_infix of { blocksize : int; offset : int; blockmode: Lambda.alloc_mode }
| RHS_floatblock of Lambda.alloc_mode * int
| RHS_nonrec
;;

let rec expr_size env = function
| Uvar id ->
begin try V.find_same id env with Not_found -> RHS_nonrec end
| Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
RHS_block (fundecls_size functions + List.length not_scanned_slots
+ List.length scanned_slots)
(* should all have the same mode *)
let fn_mode = (List.hd functions).mode in
List.iter (fun f -> assert (Lambda.eq_mode fn_mode f.mode)) functions;
RHS_block (fn_mode,
fundecls_size functions + List.length not_scanned_slots
+ List.length scanned_slots)
| Ulet(_str, _kind, id, exp, body) ->
expr_size (V.add (VP.var id) (expr_size env exp) env) body
| Uletrec(bindings, body) ->
Expand All @@ -169,24 +173,24 @@ let rec expr_size env = function
bindings env
in
expr_size env body
| Uprim(Pmakeblock _, args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray((Paddrarray | Pintarray), _, _), args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray(Pfloatarray, _, _), args, _) ->
RHS_floatblock (List.length args)
| Uprim(Pmakearray(Pgenarray, _, _), _, _) ->
| Uprim(Pmakeblock (_, _, _, mode), args, _) ->
RHS_block (mode, List.length args)
| Uprim(Pmakearray((Paddrarray | Pintarray), _, mode), args, _) ->
RHS_block (mode, List.length args)
| Uprim(Pmakearray(Pfloatarray, _, mode), args, _) ->
RHS_floatblock (mode, List.length args)
| Uprim(Pmakearray(Pgenarray, _, _mode), _, _) ->
(* Pgenarray is excluded from recursive bindings by the
check in Translcore.check_recursive_lambda *)
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This comment is quite out of date. I suspect we can remove all the Pmakearray cases, as they're normally always followed by Pduparray, but I guess this can be handled in a separate PR.

RHS_nonrec
| Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
RHS_block sz
RHS_block (Lambda.alloc_heap, sz)
| Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false
| Uprim (Pduprecord (Record_extension _, sz), _, _) ->
RHS_block (sz + 1)
RHS_block (Lambda.alloc_heap, sz + 1)
| Uprim (Pduprecord (Record_float, sz), _, _) ->
RHS_floatblock sz
RHS_floatblock (Lambda.alloc_heap, sz)
| Uprim (Pccall { prim_name; _ }, closure::_, _)
when prim_name = "caml_check_value_is_closure" ->
(* Used for "-clambda-checks". *)
Expand All @@ -195,7 +199,8 @@ let rec expr_size env = function
expr_size env exp'
| Uoffset (exp, offset) ->
(match expr_size env exp with
| RHS_block blocksize -> RHS_infix { blocksize; offset }
| RHS_block (blockmode, blocksize) ->
RHS_infix { blocksize; offset; blockmode }
| RHS_nonrec -> RHS_nonrec
| _ -> assert false)
| Uregion exp ->
Expand Down Expand Up @@ -1428,14 +1433,19 @@ and transl_letrec env bindings cont =
args, dbg) in
let rec init_blocks = function
| [] -> fill_nonrec bsz
| (id, _exp, RHS_block sz) :: rem ->
| (_, _,
(RHS_block (Alloc_local, _) |
RHS_infix {blockmode=Alloc_local; _} |
RHS_floatblock (Alloc_local, _))) :: _ ->
Misc.fatal_error "Invalid stack allocation found"
| (id, _exp, RHS_block (Alloc_heap, sz)) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz],
init_blocks rem)
| (id, _exp, RHS_infix { blocksize; offset}) :: rem ->
| (id, _exp, RHS_infix { blocksize; offset; blockmode=Alloc_heap }) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy_infix"
[int_const dbg blocksize; int_const dbg offset],
init_blocks rem)
| (id, _exp, RHS_floatblock sz) :: rem ->
| (id, _exp, RHS_floatblock (Alloc_heap, sz)) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz],
init_blocks rem)
| (id, _exp, RHS_nonrec) :: rem ->
Expand Down
26 changes: 19 additions & 7 deletions middle_end/flambda2/from_lambda/dissect_letrec.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -187,6 +187,12 @@ let is_simple (lam : Lambda.lambda) =
match lam with Lvar _ | Lconst _ -> true | _ -> false
[@@ocaml.warning "-fragile-match"]

let assert_not_local ~lam : Lambda.alloc_mode -> unit = function
| Alloc_heap -> ()
| Alloc_local ->
Misc.fatal_errorf "Invalid stack allocation found in %a" Printlambda.lambda
lam

let dead_code lam letrec =
(* Some cases generate code without effects, and bound to nothing. We use this
function to insert it as [Lsequence] in [effects], for documentation. It
Expand All @@ -203,6 +209,7 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
(lam : Lambda.lambda) (letrec : letrec) =
match lam with
| Lfunction funct -> (
assert_not_local ~lam funct.mode;
match current_let with
| Some current_let when Ident.Set.mem current_let.ident recursive_set ->
{ letrec with functions = (current_let.ident, funct) :: letrec.functions }
Expand All @@ -221,6 +228,10 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
| None -> dead_code lam letrec)
| Lprim (((Pmakeblock _ | Pmakearray _ | Pduprecord _) as prim), args, dbg)
when not (List.for_all is_simple args) ->
(match prim with
| Pmakeblock (_, _, _, mode) | Pmakearray (_, _, mode) ->
assert_not_local ~lam mode
| _ -> ());
(* If there are some non-trivial expressions as arguments, we first extract
the arguments (to let-bound variables) before deconstructing. Arguments
could contain side effects and other blocks declarations. *)
Expand All @@ -246,15 +257,16 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
defs
in
prepare_letrec recursive_set current_let lam letrec
| Lprim (Pmakeblock _, args, _)
| Lprim (Pmakearray ((Paddrarray | Pintarray), _, _), args, _) -> (
| Lprim (Pmakeblock (_, _, _, mode), args, _)
| Lprim (Pmakearray ((Paddrarray | Pintarray), _, mode), args, _) -> (
assert_not_local ~lam mode;
match current_let with
| Some cl -> build_block cl (List.length args) (Normal 0) lam letrec
| None ->
dead_code lam letrec
(* We know that [args] are all "simple" at this point, so no effects *))
| Lprim (Pmakearray (Pfloatarray, _, _), args, _)
| Lprim (Pmakefloatblock _, args, _) -> (
| None -> dead_code lam letrec
(* We know that [args] are all "simple" at this point, so no effects *))
| Lprim (Pmakearray (Pfloatarray, _, mode), args, _)
| Lprim (Pmakefloatblock (_, mode), args, _) -> (
assert_not_local ~lam mode;
match current_let with
| Some cl -> build_block cl (List.length args) Boxed_float lam letrec
| None -> dead_code lam letrec)
Expand Down
48 changes: 29 additions & 19 deletions ocaml/asmcomp/cmmgen.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -122,18 +122,22 @@ let get_field env ptr n dbg =
get_field_gen mut ptr n dbg

type rhs_kind =
| RHS_block of int
| RHS_infix of { blocksize : int; offset : int }
| RHS_floatblock of int
| RHS_block of Lambda.alloc_mode * int
| RHS_infix of { blocksize : int; offset : int; blockmode: Lambda.alloc_mode }
| RHS_floatblock of Lambda.alloc_mode * int
| RHS_nonrec
;;

let rec expr_size env = function
| Uvar id ->
begin try V.find_same id env with Not_found -> RHS_nonrec end
| Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
RHS_block (fundecls_size functions + List.length not_scanned_slots
+ List.length scanned_slots)
(* should all have the same mode *)
let fn_mode = (List.hd functions).mode in
List.iter (fun f -> assert (Lambda.eq_mode fn_mode f.mode)) functions;
RHS_block (fn_mode,
fundecls_size functions + List.length not_scanned_slots
+ List.length scanned_slots)
| Ulet(_str, _kind, id, exp, body) ->
expr_size (V.add (VP.var id) (expr_size env exp) env) body
| Uletrec(bindings, body) ->
Expand All @@ -143,24 +147,24 @@ let rec expr_size env = function
bindings env
in
expr_size env body
| Uprim(Pmakeblock _, args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray((Paddrarray | Pintarray), _, _), args, _) ->
RHS_block (List.length args)
| Uprim(Pmakearray(Pfloatarray, _, _), args, _) ->
RHS_floatblock (List.length args)
| Uprim(Pmakearray(Pgenarray, _, _), _, _) ->
| Uprim(Pmakeblock (_, _, _, mode), args, _) ->
RHS_block (mode, List.length args)
| Uprim(Pmakearray((Paddrarray | Pintarray), _, mode), args, _) ->
RHS_block (mode, List.length args)
| Uprim(Pmakearray(Pfloatarray, _, mode), args, _) ->
RHS_floatblock (mode, List.length args)
| Uprim(Pmakearray(Pgenarray, _, _mode), _, _) ->
(* Pgenarray is excluded from recursive bindings by the
check in Translcore.check_recursive_lambda *)
RHS_nonrec
| Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
RHS_block sz
RHS_block (Lambda.alloc_heap, sz)
| Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
assert false
| Uprim (Pduprecord (Record_extension _, sz), _, _) ->
RHS_block (sz + 1)
RHS_block (Lambda.alloc_heap, sz + 1)
| Uprim (Pduprecord (Record_float, sz), _, _) ->
RHS_floatblock sz
RHS_floatblock (Lambda.alloc_heap, sz)
| Uprim (Pccall { prim_name; _ }, closure::_, _)
when prim_name = "caml_check_value_is_closure" ->
(* Used for "-clambda-checks". *)
Expand All @@ -169,7 +173,8 @@ let rec expr_size env = function
expr_size env exp'
| Uoffset (exp, offset) ->
(match expr_size env exp with
| RHS_block blocksize -> RHS_infix { blocksize; offset }
| RHS_block (blockmode, blocksize) ->
RHS_infix { blocksize; offset; blockmode }
| RHS_nonrec -> RHS_nonrec
| _ -> assert false)
| Uregion exp ->
Expand Down Expand Up @@ -1379,14 +1384,19 @@ and transl_letrec env bindings cont =
Cop(Cextcall(prim, typ_val, [], true), args, dbg) in
let rec init_blocks = function
| [] -> fill_nonrec bsz
| (id, _exp, RHS_block sz) :: rem ->
| (_, _,
(RHS_block (Alloc_local, _) |
RHS_infix {blockmode=Alloc_local; _} |
RHS_floatblock (Alloc_local, _))) :: _ ->
Misc.fatal_error "Invalid stack allocation found"
| (id, _exp, RHS_block (Alloc_heap, sz)) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz],
init_blocks rem)
| (id, _exp, RHS_infix { blocksize; offset}) :: rem ->
| (id, _exp, RHS_infix { blocksize; offset; blockmode=Alloc_heap }) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy_infix"
[int_const dbg blocksize; int_const dbg offset],
init_blocks rem)
| (id, _exp, RHS_floatblock sz) :: rem ->
| (id, _exp, RHS_floatblock (Alloc_heap, sz)) :: rem ->
Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz],
init_blocks rem)
| (id, _exp, RHS_nonrec) :: rem ->
Expand Down