Skip to content

Commit da037b6

Browse files
committed
More assertions for local alloc and letrec
1 parent 80d1383 commit da037b6

File tree

2 files changed

+47
-24
lines changed

2 files changed

+47
-24
lines changed

backend/cmmgen.ml

Lines changed: 30 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -148,18 +148,26 @@ let get_field env ptr n dbg =
148148
get_field_gen mut ptr n dbg
149149

150150
type rhs_kind =
151-
| RHS_block of int
151+
| RHS_block of Lambda.alloc_mode * int
152152
| RHS_infix of { blocksize : int; offset : int }
153-
| RHS_floatblock of int
153+
| RHS_floatblock of Lambda.alloc_mode * int
154154
| RHS_nonrec
155155
;;
156156

157+
let assert_not_local : Lambda.alloc_mode -> unit = function
158+
| Alloc_heap -> ()
159+
| Alloc_local -> Misc.fatal_error "Invalid stack allocation found"
160+
157161
let rec expr_size env = function
158162
| Uvar id ->
159163
begin try V.find_same id env with Not_found -> RHS_nonrec end
160164
| Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
161-
RHS_block (fundecls_size functions + List.length not_scanned_slots
162-
+ List.length scanned_slots)
165+
(* should all have the same mode *)
166+
let fn_mode = (List.hd functions).mode in
167+
List.iter (fun f -> assert (Lambda.eq_mode fn_mode f.mode)) functions;
168+
RHS_block (fn_mode,
169+
fundecls_size functions + List.length not_scanned_slots
170+
+ List.length scanned_slots)
163171
| Ulet(_str, _kind, id, exp, body) ->
164172
expr_size (V.add (VP.var id) (expr_size env exp) env) body
165173
| Uletrec(bindings, body) ->
@@ -169,24 +177,25 @@ let rec expr_size env = function
169177
bindings env
170178
in
171179
expr_size env body
172-
| Uprim(Pmakeblock _, args, _) ->
173-
RHS_block (List.length args)
174-
| Uprim(Pmakearray((Paddrarray | Pintarray), _, _), args, _) ->
175-
RHS_block (List.length args)
176-
| Uprim(Pmakearray(Pfloatarray, _, _), args, _) ->
177-
RHS_floatblock (List.length args)
178-
| Uprim(Pmakearray(Pgenarray, _, _), _, _) ->
180+
| Uprim(Pmakeblock (_, _, _, mode), args, _) ->
181+
RHS_block (mode, List.length args)
182+
| Uprim(Pmakearray((Paddrarray | Pintarray), _, mode), args, _) ->
183+
RHS_block (mode, List.length args)
184+
| Uprim(Pmakearray(Pfloatarray, _, mode), args, _) ->
185+
RHS_floatblock (mode, List.length args)
186+
| Uprim(Pmakearray(Pgenarray, _, mode), _, _) ->
187+
assert_not_local mode;
179188
(* Pgenarray is excluded from recursive bindings by the
180189
check in Translcore.check_recursive_lambda *)
181190
RHS_nonrec
182191
| Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
183-
RHS_block sz
192+
RHS_block (Lambda.alloc_heap, sz)
184193
| Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
185194
assert false
186195
| Uprim (Pduprecord (Record_extension _, sz), _, _) ->
187-
RHS_block (sz + 1)
196+
RHS_block (Lambda.alloc_heap, sz + 1)
188197
| Uprim (Pduprecord (Record_float, sz), _, _) ->
189-
RHS_floatblock sz
198+
RHS_floatblock (Lambda.alloc_heap, sz)
190199
| Uprim (Pccall { prim_name; _ }, closure::_, _)
191200
when prim_name = "caml_check_value_is_closure" ->
192201
(* Used for "-clambda-checks". *)
@@ -195,7 +204,9 @@ let rec expr_size env = function
195204
expr_size env exp'
196205
| Uoffset (exp, offset) ->
197206
(match expr_size env exp with
198-
| RHS_block blocksize -> RHS_infix { blocksize; offset }
207+
| RHS_block (mode, blocksize) ->
208+
assert_not_local mode;
209+
RHS_infix { blocksize; offset }
199210
| RHS_nonrec -> RHS_nonrec
200211
| _ -> assert false)
201212
| Uregion exp ->
@@ -1428,14 +1439,16 @@ and transl_letrec env bindings cont =
14281439
args, dbg) in
14291440
let rec init_blocks = function
14301441
| [] -> fill_nonrec bsz
1431-
| (id, _exp, RHS_block sz) :: rem ->
1442+
| (id, _exp, RHS_block (mode, sz)) :: rem ->
1443+
assert_not_local mode;
14321444
Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz],
14331445
init_blocks rem)
14341446
| (id, _exp, RHS_infix { blocksize; offset}) :: rem ->
14351447
Clet(id, op_alloc "caml_alloc_dummy_infix"
14361448
[int_const dbg blocksize; int_const dbg offset],
14371449
init_blocks rem)
1438-
| (id, _exp, RHS_floatblock sz) :: rem ->
1450+
| (id, _exp, RHS_floatblock (mode, sz)) :: rem ->
1451+
assert_not_local mode;
14391452
Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz],
14401453
init_blocks rem)
14411454
| (id, _exp, RHS_nonrec) :: rem ->

middle_end/flambda2/from_lambda/dissect_letrec.ml

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -187,6 +187,10 @@ let is_simple (lam : Lambda.lambda) =
187187
match lam with Lvar _ | Lconst _ -> true | _ -> false
188188
[@@ocaml.warning "-fragile-match"]
189189

190+
let assert_not_local : Lambda.alloc_mode -> unit = function
191+
| Alloc_heap -> ()
192+
| Alloc_local -> Misc.fatal_error "Invalid stack allocation found"
193+
190194
let dead_code lam letrec =
191195
(* Some cases generate code without effects, and bound to nothing. We use this
192196
function to insert it as [Lsequence] in [effects], for documentation. It
@@ -203,6 +207,7 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
203207
(lam : Lambda.lambda) (letrec : letrec) =
204208
match lam with
205209
| Lfunction funct -> (
210+
assert_not_local funct.mode;
206211
match current_let with
207212
| Some current_let when Ident.Set.mem current_let.ident recursive_set ->
208213
{ letrec with functions = (current_let.ident, funct) :: letrec.functions }
@@ -221,6 +226,10 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
221226
| None -> dead_code lam letrec)
222227
| Lprim (((Pmakeblock _ | Pmakearray _ | Pduprecord _) as prim), args, dbg)
223228
when not (List.for_all is_simple args) ->
229+
(match prim with
230+
| Pmakeblock (_, _, _, mode) | Pmakearray (_, _, mode) ->
231+
assert_not_local mode
232+
| _ -> ());
224233
(* If there are some non-trivial expressions as arguments, we first extract
225234
the arguments (to let-bound variables) before deconstructing. Arguments
226235
could contain side effects and other blocks declarations. *)
@@ -246,15 +255,16 @@ let rec prepare_letrec (recursive_set : Ident.Set.t)
246255
defs
247256
in
248257
prepare_letrec recursive_set current_let lam letrec
249-
| Lprim (Pmakeblock _, args, _)
250-
| Lprim (Pmakearray ((Paddrarray | Pintarray), _, _), args, _) -> (
258+
| Lprim (Pmakeblock (_, _, _, mode), args, _)
259+
| Lprim (Pmakearray ((Paddrarray | Pintarray), _, mode), args, _) -> (
260+
assert_not_local mode;
251261
match current_let with
252262
| Some cl -> build_block cl (List.length args) (Normal 0) lam letrec
253-
| None ->
254-
dead_code lam letrec
255-
(* We know that [args] are all "simple" at this point, so no effects *))
256-
| Lprim (Pmakearray (Pfloatarray, _, _), args, _)
257-
| Lprim (Pmakefloatblock _, args, _) -> (
263+
| None -> dead_code lam letrec
264+
(* We know that [args] are all "simple" at this point, so no effects *))
265+
| Lprim (Pmakearray (Pfloatarray, _, mode), args, _)
266+
| Lprim (Pmakefloatblock (_, mode), args, _) -> (
267+
assert_not_local mode;
258268
match current_let with
259269
| Some cl -> build_block cl (List.length args) Boxed_float lam letrec
260270
| None -> dead_code lam letrec)

0 commit comments

Comments
 (0)