@@ -123,15 +123,11 @@ let get_field env ptr n dbg =
123
123
124
124
type rhs_kind =
125
125
| RHS_block of Lambda .alloc_mode * int
126
- | RHS_infix of { blocksize : int ; offset : int }
126
+ | RHS_infix of { blocksize : int ; offset : int ; blockmode : Lambda .alloc_mode }
127
127
| RHS_floatblock of Lambda .alloc_mode * int
128
128
| RHS_nonrec
129
129
;;
130
130
131
- let assert_not_local : Lambda.alloc_mode -> unit = function
132
- | Alloc_heap -> ()
133
- | Alloc_local -> Misc. fatal_error " Invalid stack allocation found"
134
-
135
131
let rec expr_size env = function
136
132
| Uvar id ->
137
133
begin try V. find_same id env with Not_found -> RHS_nonrec end
@@ -158,7 +154,6 @@ let rec expr_size env = function
158
154
| Uprim (Pmakearray(Pfloatarray, _ , mode ), args , _ ) ->
159
155
RHS_floatblock (mode, List. length args)
160
156
| Uprim (Pmakearray(Pgenarray, _ , mode ), _ , _ ) ->
161
- assert_not_local mode;
162
157
(* Pgenarray is excluded from recursive bindings by the
163
158
check in Translcore.check_recursive_lambda *)
164
159
RHS_nonrec
@@ -178,9 +173,8 @@ let rec expr_size env = function
178
173
expr_size env exp'
179
174
| Uoffset (exp , offset ) ->
180
175
(match expr_size env exp with
181
- | RHS_block (mode , blocksize ) ->
182
- assert_not_local mode;
183
- RHS_infix { blocksize; offset }
176
+ | RHS_block (blockmode , blocksize ) ->
177
+ RHS_infix { blocksize; offset; blockmode }
184
178
| RHS_nonrec -> RHS_nonrec
185
179
| _ -> assert false )
186
180
| Uregion exp ->
@@ -1390,16 +1384,19 @@ and transl_letrec env bindings cont =
1390
1384
Cop (Cextcall (prim, typ_val, [] , true ), args, dbg) in
1391
1385
let rec init_blocks = function
1392
1386
| [] -> fill_nonrec bsz
1393
- | (id , _exp , RHS_block (mode , sz )) :: rem ->
1394
- assert_not_local mode;
1387
+ | (_, _,
1388
+ (RHS_block (Alloc_local , _) |
1389
+ RHS_infix {blockmode= Alloc_local ; _} |
1390
+ RHS_floatblock (Alloc_local , _))) :: _ ->
1391
+ Misc. fatal_error " Invalid stack allocation found"
1392
+ | (id , _exp , RHS_block (Alloc_heap, sz )) :: rem ->
1395
1393
Clet (id, op_alloc " caml_alloc_dummy" [int_const dbg sz],
1396
1394
init_blocks rem)
1397
- | (id , _exp , RHS_infix { blocksize; offset} ) :: rem ->
1395
+ | (id , _exp , RHS_infix { blocksize; offset; blockmode = Alloc_heap } ) :: rem ->
1398
1396
Clet (id, op_alloc " caml_alloc_dummy_infix"
1399
1397
[int_const dbg blocksize; int_const dbg offset],
1400
1398
init_blocks rem)
1401
- | (id , _exp , RHS_floatblock (mode , sz )) :: rem ->
1402
- assert_not_local mode;
1399
+ | (id , _exp , RHS_floatblock (Alloc_heap, sz )) :: rem ->
1403
1400
Clet (id, op_alloc " caml_alloc_dummy_float" [int_const dbg sz],
1404
1401
init_blocks rem)
1405
1402
| (id , _exp , RHS_nonrec) :: rem ->
0 commit comments