Skip to content

Commit 1b3f50a

Browse files
committed
Fix assertion in Cmmgen.expr_size
1 parent c040896 commit 1b3f50a

File tree

2 files changed

+22
-28
lines changed

2 files changed

+22
-28
lines changed

backend/cmmgen.ml

Lines changed: 11 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -149,15 +149,11 @@ let get_field env ptr n dbg =
149149

150150
type rhs_kind =
151151
| RHS_block of Lambda.alloc_mode * int
152-
| RHS_infix of { blocksize : int; offset : int }
152+
| RHS_infix of { blocksize : int; offset : int; blockmode: Lambda.alloc_mode }
153153
| 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-
161157
let rec expr_size env = function
162158
| Uvar id ->
163159
begin try V.find_same id env with Not_found -> RHS_nonrec end
@@ -184,7 +180,6 @@ let rec expr_size env = function
184180
| Uprim(Pmakearray(Pfloatarray, _, mode), args, _) ->
185181
RHS_floatblock (mode, List.length args)
186182
| Uprim(Pmakearray(Pgenarray, _, mode), _, _) ->
187-
assert_not_local mode;
188183
(* Pgenarray is excluded from recursive bindings by the
189184
check in Translcore.check_recursive_lambda *)
190185
RHS_nonrec
@@ -204,9 +199,8 @@ let rec expr_size env = function
204199
expr_size env exp'
205200
| Uoffset (exp, offset) ->
206201
(match expr_size env exp with
207-
| RHS_block (mode, blocksize) ->
208-
assert_not_local mode;
209-
RHS_infix { blocksize; offset }
202+
| RHS_block (blockmode, blocksize) ->
203+
RHS_infix { blocksize; offset; blockmode }
210204
| RHS_nonrec -> RHS_nonrec
211205
| _ -> assert false)
212206
| Uregion exp ->
@@ -1439,16 +1433,19 @@ and transl_letrec env bindings cont =
14391433
args, dbg) in
14401434
let rec init_blocks = function
14411435
| [] -> fill_nonrec bsz
1442-
| (id, _exp, RHS_block (mode, sz)) :: rem ->
1443-
assert_not_local mode;
1436+
| (_, _,
1437+
(RHS_block (Alloc_local, _) |
1438+
RHS_infix {blockmode=Alloc_local; _} |
1439+
RHS_floatblock (Alloc_local, _))) :: _ ->
1440+
Misc.fatal_error "Invalid stack allocation found"
1441+
| (id, _exp, RHS_block (Alloc_heap, sz)) :: rem ->
14441442
Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz],
14451443
init_blocks rem)
1446-
| (id, _exp, RHS_infix { blocksize; offset}) :: rem ->
1444+
| (id, _exp, RHS_infix { blocksize; offset; blockmode=Alloc_heap }) :: rem ->
14471445
Clet(id, op_alloc "caml_alloc_dummy_infix"
14481446
[int_const dbg blocksize; int_const dbg offset],
14491447
init_blocks rem)
1450-
| (id, _exp, RHS_floatblock (mode, sz)) :: rem ->
1451-
assert_not_local mode;
1448+
| (id, _exp, RHS_floatblock (Alloc_heap, sz)) :: rem ->
14521449
Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz],
14531450
init_blocks rem)
14541451
| (id, _exp, RHS_nonrec) :: rem ->

ocaml/asmcomp/cmmgen.ml

Lines changed: 11 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -123,15 +123,11 @@ let get_field env ptr n dbg =
123123

124124
type rhs_kind =
125125
| 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 }
127127
| RHS_floatblock of Lambda.alloc_mode * int
128128
| RHS_nonrec
129129
;;
130130

131-
let assert_not_local : Lambda.alloc_mode -> unit = function
132-
| Alloc_heap -> ()
133-
| Alloc_local -> Misc.fatal_error "Invalid stack allocation found"
134-
135131
let rec expr_size env = function
136132
| Uvar id ->
137133
begin try V.find_same id env with Not_found -> RHS_nonrec end
@@ -158,7 +154,6 @@ let rec expr_size env = function
158154
| Uprim(Pmakearray(Pfloatarray, _, mode), args, _) ->
159155
RHS_floatblock (mode, List.length args)
160156
| Uprim(Pmakearray(Pgenarray, _, mode), _, _) ->
161-
assert_not_local mode;
162157
(* Pgenarray is excluded from recursive bindings by the
163158
check in Translcore.check_recursive_lambda *)
164159
RHS_nonrec
@@ -178,9 +173,8 @@ let rec expr_size env = function
178173
expr_size env exp'
179174
| Uoffset (exp, offset) ->
180175
(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 }
184178
| RHS_nonrec -> RHS_nonrec
185179
| _ -> assert false)
186180
| Uregion exp ->
@@ -1390,16 +1384,19 @@ and transl_letrec env bindings cont =
13901384
Cop(Cextcall(prim, typ_val, [], true), args, dbg) in
13911385
let rec init_blocks = function
13921386
| [] -> 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 ->
13951393
Clet(id, op_alloc "caml_alloc_dummy" [int_const dbg sz],
13961394
init_blocks rem)
1397-
| (id, _exp, RHS_infix { blocksize; offset}) :: rem ->
1395+
| (id, _exp, RHS_infix { blocksize; offset; blockmode=Alloc_heap }) :: rem ->
13981396
Clet(id, op_alloc "caml_alloc_dummy_infix"
13991397
[int_const dbg blocksize; int_const dbg offset],
14001398
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 ->
14031400
Clet(id, op_alloc "caml_alloc_dummy_float" [int_const dbg sz],
14041401
init_blocks rem)
14051402
| (id, _exp, RHS_nonrec) :: rem ->

0 commit comments

Comments
 (0)