@@ -148,18 +148,26 @@ let get_field env ptr n dbg =
148
148
get_field_gen mut ptr n dbg
149
149
150
150
type rhs_kind =
151
- | RHS_block of int
151
+ | RHS_block of Lambda .alloc_mode * int
152
152
| RHS_infix of { blocksize : int ; offset : int }
153
- | RHS_floatblock of int
153
+ | RHS_floatblock of Lambda .alloc_mode * int
154
154
| RHS_nonrec
155
155
;;
156
156
157
+ let assert_not_local : Lambda.alloc_mode -> unit = function
158
+ | Alloc_heap -> ()
159
+ | Alloc_local -> Misc. fatal_error " Invalid stack allocation found"
160
+
157
161
let rec expr_size env = function
158
162
| Uvar id ->
159
163
begin try V. find_same id env with Not_found -> RHS_nonrec end
160
164
| 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)
163
171
| Ulet (_str , _kind , id , exp , body ) ->
164
172
expr_size (V. add (VP. var id) (expr_size env exp) env) body
165
173
| Uletrec (bindings , body ) ->
@@ -169,24 +177,25 @@ let rec expr_size env = function
169
177
bindings env
170
178
in
171
179
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;
179
188
(* Pgenarray is excluded from recursive bindings by the
180
189
check in Translcore.check_recursive_lambda *)
181
190
RHS_nonrec
182
191
| Uprim (Pduprecord ((Record_regular | Record_inlined _ ), sz ), _ , _ ) ->
183
- RHS_block sz
192
+ RHS_block ( Lambda. alloc_heap, sz)
184
193
| Uprim (Pduprecord (Record_unboxed _ , _ ), _ , _ ) ->
185
194
assert false
186
195
| Uprim (Pduprecord (Record_extension _ , sz ), _ , _ ) ->
187
- RHS_block (sz + 1 )
196
+ RHS_block (Lambda. alloc_heap, sz + 1 )
188
197
| Uprim (Pduprecord (Record_float, sz ), _ , _ ) ->
189
- RHS_floatblock sz
198
+ RHS_floatblock ( Lambda. alloc_heap, sz)
190
199
| Uprim (Pccall { prim_name; _ }, closure::_, _)
191
200
when prim_name = " caml_check_value_is_closure" ->
192
201
(* Used for "-clambda-checks". *)
@@ -195,7 +204,9 @@ let rec expr_size env = function
195
204
expr_size env exp'
196
205
| Uoffset (exp , offset ) ->
197
206
(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 }
199
210
| RHS_nonrec -> RHS_nonrec
200
211
| _ -> assert false )
201
212
| Uregion exp ->
@@ -1428,14 +1439,16 @@ and transl_letrec env bindings cont =
1428
1439
args, dbg) in
1429
1440
let rec init_blocks = function
1430
1441
| [] -> fill_nonrec bsz
1431
- | (id , _exp , RHS_block sz ) :: rem ->
1442
+ | (id , _exp , RHS_block (mode , sz )) :: rem ->
1443
+ assert_not_local mode;
1432
1444
Clet (id, op_alloc " caml_alloc_dummy" [int_const dbg sz],
1433
1445
init_blocks rem)
1434
1446
| (id , _exp , RHS_infix { blocksize; offset} ) :: rem ->
1435
1447
Clet (id, op_alloc " caml_alloc_dummy_infix"
1436
1448
[int_const dbg blocksize; int_const dbg offset],
1437
1449
init_blocks rem)
1438
- | (id , _exp , RHS_floatblock sz ) :: rem ->
1450
+ | (id , _exp , RHS_floatblock (mode , sz )) :: rem ->
1451
+ assert_not_local mode;
1439
1452
Clet (id, op_alloc " caml_alloc_dummy_float" [int_const dbg sz],
1440
1453
init_blocks rem)
1441
1454
| (id , _exp , RHS_nonrec) :: rem ->
0 commit comments