Skip to content

Commit a0062ad

Browse files
stedolanstedolan
committed
Allow local allocations for various primitives (oxcaml#43)
 - Boxed integers (Int32, Int64, Nativeint) - Floats (including Pfloatfield projections) - References Additionally, allow certain non-allocating primitives to be given local types: - Integer operations - fst and snd
1 parent 7a2165e commit a0062ad

41 files changed

Lines changed: 1058 additions & 857 deletions

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

‎asmcomp/cmm_helpers.ml‎

Lines changed: 58 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -58,6 +58,7 @@ let black_closure_header sz = black_block_header Obj.closure_tag sz
5858
let local_closure_header sz = local_block_header Obj.closure_tag sz
5959
let infix_header ofs = block_header Obj.infix_tag ofs
6060
let float_header = block_header Obj.double_tag (size_float / size_addr)
61+
let float_local_header = local_block_header Obj.double_tag (size_float / size_addr)
6162
let floatarray_header len =
6263
(* Zero-sized float arrays have tag zero for consistency with
6364
[caml_alloc_float_array]. *)
@@ -69,6 +70,9 @@ let string_header len =
6970
let boxedint32_header = block_header Obj.custom_tag 2
7071
let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
7172
let boxedintnat_header = block_header Obj.custom_tag 2
73+
let boxedint32_local_header = local_block_header Obj.custom_tag 2
74+
let boxedint64_local_header = local_block_header Obj.custom_tag (1 + 8 / size_addr)
75+
let boxedintnat_local_header = local_block_header Obj.custom_tag 2
7276
let caml_nativeint_ops = "caml_nativeint_ops"
7377
let caml_int32_ops = "caml_int32_ops"
7478
let caml_int64_ops = "caml_int64_ops"
@@ -88,7 +92,10 @@ let closure_info ~arity ~startenv =
8892
(add (shift_left (of_int startenv) 1)
8993
1n))
9094

91-
let alloc_float_header dbg = Cconst_natint (float_header, dbg)
95+
let alloc_float_header mode dbg =
96+
match mode with
97+
| Lambda.Alloc_heap -> Cconst_natint (float_header, dbg)
98+
| Lambda.Alloc_local -> Cconst_natint (float_local_header, dbg)
9299
let alloc_floatarray_header len dbg = Cconst_natint (floatarray_header len, dbg)
93100
let alloc_closure_header ~mode sz dbg =
94101
match (mode : Lambda.alloc_mode) with
@@ -97,9 +104,18 @@ let alloc_closure_header ~mode sz dbg =
97104
let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg)
98105
let alloc_closure_info ~arity ~startenv dbg =
99106
Cconst_natint (closure_info ~arity ~startenv, dbg)
100-
let alloc_boxedint32_header dbg = Cconst_natint (boxedint32_header, dbg)
101-
let alloc_boxedint64_header dbg = Cconst_natint (boxedint64_header, dbg)
102-
let alloc_boxedintnat_header dbg = Cconst_natint (boxedintnat_header, dbg)
107+
let alloc_boxedint32_header mode dbg =
108+
match mode with
109+
| Lambda.Alloc_heap -> Cconst_natint (boxedint32_header, dbg)
110+
| Lambda.Alloc_local -> Cconst_natint (boxedint32_local_header, dbg)
111+
let alloc_boxedint64_header mode dbg =
112+
match mode with
113+
| Lambda.Alloc_heap -> Cconst_natint (boxedint64_header, dbg)
114+
| Lambda.Alloc_local -> Cconst_natint (boxedint64_local_header, dbg)
115+
let alloc_boxedintnat_header mode dbg =
116+
match mode with
117+
| Lambda.Alloc_heap -> Cconst_natint (boxedintnat_header, dbg)
118+
| Lambda.Alloc_local -> Cconst_natint (boxedintnat_local_header, dbg)
103119

104120
(* Integers *)
105121

@@ -567,7 +583,7 @@ let test_bool dbg cmm =
567583

568584
(* Float *)
569585

570-
let box_float dbg c = Cop(Calloc Alloc_heap, [alloc_float_header dbg; c], dbg)
586+
let box_float dbg m c = Cop(Calloc m, [alloc_float_header m dbg; c], dbg)
571587

572588
let unbox_float dbg =
573589
map_tail
@@ -742,7 +758,7 @@ let unboxed_float_array_ref arr ofs dbg =
742758
Cop(Cload (Double_u, Mutable),
743759
[array_indexing log2_size_float arr ofs dbg], dbg)
744760
let float_array_ref arr ofs dbg =
745-
box_float dbg (unboxed_float_array_ref arr ofs dbg)
761+
box_float dbg Alloc_heap (unboxed_float_array_ref arr ofs dbg)
746762

747763
(* FIXME local arrays *)
748764
let addr_array_set arr ofs newval dbg =
@@ -1021,22 +1037,22 @@ let operations_boxed_int (bi : Primitive.boxed_integer) =
10211037
| Pint32 -> caml_int32_ops
10221038
| Pint64 -> caml_int64_ops
10231039

1024-
let alloc_header_boxed_int (bi : Primitive.boxed_integer) =
1040+
let alloc_header_boxed_int (bi : Primitive.boxed_integer) mode dbg =
10251041
match bi with
1026-
Pnativeint -> alloc_boxedintnat_header
1027-
| Pint32 -> alloc_boxedint32_header
1028-
| Pint64 -> alloc_boxedint64_header
1042+
Pnativeint -> alloc_boxedintnat_header mode dbg
1043+
| Pint32 -> alloc_boxedint32_header mode dbg
1044+
| Pint64 -> alloc_boxedint64_header mode dbg
10291045

1030-
let box_int_gen dbg (bi : Primitive.boxed_integer) arg =
1046+
let box_int_gen dbg (bi : Primitive.boxed_integer) mode arg =
10311047
let arg' =
10321048
if bi = Primitive.Pint32 && size_int = 8 then
10331049
if big_endian
10341050
then Cop(Clsl, [arg; Cconst_int (32, dbg)], dbg)
10351051
else sign_extend_32 dbg arg
10361052
else arg
10371053
in
1038-
Cop(Calloc Alloc_heap,
1039-
[alloc_header_boxed_int bi dbg;
1054+
Cop(Calloc mode,
1055+
[alloc_header_boxed_int bi mode dbg;
10401056
Cconst_symbol(operations_boxed_int bi, dbg);
10411057
arg'], dbg)
10421058

@@ -1360,11 +1376,11 @@ let unaligned_load size ptr idx dbg =
13601376
| Thirty_two -> unaligned_load_32 ptr idx dbg
13611377
| Sixty_four -> unaligned_load_64 ptr idx dbg
13621378

1363-
let box_sized size dbg exp =
1379+
let box_sized size mode dbg exp =
13641380
match (size : Clambda_primitives.memory_access_size) with
13651381
| Sixteen -> tag_int exp dbg
1366-
| Thirty_two -> box_int_gen dbg Pint32 exp
1367-
| Sixty_four -> box_int_gen dbg Pint64 exp
1382+
| Thirty_two -> box_int_gen dbg Pint32 mode exp
1383+
| Sixty_four -> box_int_gen dbg Pint64 mode exp
13681384

13691385
(* Simplification of some primitives into C calls *)
13701386

@@ -1380,37 +1396,39 @@ let int64_native_prim name arity ~alloc =
13801396
~native_repr_args:(make_args arity)
13811397
~native_repr_res:u64
13821398

1399+
(* FIXME: On 32-bit, these will do heap allocations
1400+
even when local allocs are possible *)
13831401
let simplif_primitive_32bits :
13841402
Clambda_primitives.primitive -> Clambda_primitives.primitive = function
1385-
Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
1403+
Pbintofint (Pint64,_) -> Pccall (default_prim "caml_int64_of_int")
13861404
| Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int")
1387-
| Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32")
1388-
| Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32")
1389-
| Pcvtbint(Pnativeint, Pint64) ->
1405+
| Pcvtbint(Pint32, Pint64,_) -> Pccall (default_prim "caml_int64_of_int32")
1406+
| Pcvtbint(Pint64, Pint32,_) -> Pccall (default_prim "caml_int64_to_int32")
1407+
| Pcvtbint(Pnativeint, Pint64,_) ->
13901408
Pccall (default_prim "caml_int64_of_nativeint")
1391-
| Pcvtbint(Pint64, Pnativeint) ->
1409+
| Pcvtbint(Pint64, Pnativeint,_) ->
13921410
Pccall (default_prim "caml_int64_to_nativeint")
1393-
| Pnegbint Pint64 -> Pccall (int64_native_prim "caml_int64_neg" 1
1411+
| Pnegbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_neg" 1
13941412
~alloc:false)
1395-
| Paddbint Pint64 -> Pccall (int64_native_prim "caml_int64_add" 2
1413+
| Paddbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_add" 2
13961414
~alloc:false)
1397-
| Psubbint Pint64 -> Pccall (int64_native_prim "caml_int64_sub" 2
1415+
| Psubbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_sub" 2
13981416
~alloc:false)
1399-
| Pmulbint Pint64 -> Pccall (int64_native_prim "caml_int64_mul" 2
1417+
| Pmulbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_mul" 2
14001418
~alloc:false)
14011419
| Pdivbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_div" 2
14021420
~alloc:true)
14031421
| Pmodbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_mod" 2
14041422
~alloc:true)
1405-
| Pandbint Pint64 -> Pccall (int64_native_prim "caml_int64_and" 2
1423+
| Pandbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_and" 2
14061424
~alloc:false)
1407-
| Porbint Pint64 -> Pccall (int64_native_prim "caml_int64_or" 2
1425+
| Porbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_or" 2
14081426
~alloc:false)
1409-
| Pxorbint Pint64 -> Pccall (int64_native_prim "caml_int64_xor" 2
1427+
| Pxorbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_xor" 2
14101428
~alloc:false)
1411-
| Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left")
1412-
| Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
1413-
| Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
1429+
| Plslbint(Pint64,_) -> Pccall (default_prim "caml_int64_shift_left")
1430+
| Plsrbint(Pint64,_) -> Pccall (default_prim "caml_int64_shift_right_unsigned")
1431+
| Pasrbint(Pint64,_) -> Pccall (default_prim "caml_int64_shift_right")
14141432
| Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
14151433
| Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal")
14161434
| Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
@@ -1422,12 +1440,12 @@ let simplif_primitive_32bits :
14221440
Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n))
14231441
| Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
14241442
Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n))
1425-
| Pstring_load(Sixty_four, _) -> Pccall (default_prim "caml_string_get64")
1426-
| Pbytes_load(Sixty_four, _) -> Pccall (default_prim "caml_bytes_get64")
1443+
| Pstring_load(Sixty_four, _, _) -> Pccall (default_prim "caml_string_get64")
1444+
| Pbytes_load(Sixty_four, _, _) -> Pccall (default_prim "caml_bytes_get64")
14271445
| Pbytes_set(Sixty_four, _) -> Pccall (default_prim "caml_bytes_set64")
1428-
| Pbigstring_load(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_get64")
1446+
| Pbigstring_load(Sixty_four,_,_) -> Pccall (default_prim "caml_ba_uint8_get64")
14291447
| Pbigstring_set(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_set64")
1430-
| Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
1448+
| Pbbswap (Pint64,_) -> Pccall (default_prim "caml_int64_bswap")
14311449
| p -> p
14321450

14331451
let simplif_primitive p : Clambda_primitives.primitive =
@@ -2324,16 +2342,16 @@ let stringref_safe arg1 arg2 dbg =
23242342
Cop(Cload (Byte_unsigned, Mutable),
23252343
[add_int str idx dbg], dbg))))) dbg
23262344

2327-
let string_load size unsafe arg1 arg2 dbg =
2328-
box_sized size dbg
2345+
let string_load size unsafe mode arg1 arg2 dbg =
2346+
box_sized size mode dbg
23292347
(bind "str" arg1 (fun str ->
23302348
bind "index" (untag_int arg2 dbg) (fun idx ->
23312349
check_bound unsafe size dbg
23322350
(string_length str dbg)
23332351
idx (unaligned_load size str idx dbg))))
23342352

2335-
let bigstring_load size unsafe arg1 arg2 dbg =
2336-
box_sized size dbg
2353+
let bigstring_load size unsafe mode arg1 arg2 dbg =
2354+
box_sized size mode dbg
23372355
(bind "ba" arg1 (fun ba ->
23382356
bind "index" (untag_int arg2 dbg) (fun idx ->
23392357
bind "ba_data"
@@ -2406,7 +2424,7 @@ let arrayref_safe kind arg1 arg2 dbg =
24062424
(get_header_without_profinfo arr dbg) dbg; idx],
24072425
int_array_ref arr idx dbg)))
24082426
| Pfloatarray ->
2409-
box_float dbg (
2427+
box_float dbg Alloc_heap (
24102428
bind "index" arg2 (fun idx ->
24112429
bind "arr" arg1 (fun arr ->
24122430
Csequence(

‎asmcomp/cmm_helpers.mli‎

Lines changed: 8 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -53,12 +53,6 @@ val infix_header : int -> nativeint
5353
(** Header for a boxed float value *)
5454
val float_header : nativeint
5555

56-
(** Header for an unboxed float array of the given size *)
57-
val floatarray_header : int -> nativeint
58-
59-
(** Header for a string (or bytes) of the given length *)
60-
val string_header : int -> nativeint
61-
6256
(** Boxed integer headers *)
6357
val boxedint32_header : nativeint
6458
val boxedint64_header : nativeint
@@ -68,18 +62,10 @@ val boxedintnat_header : nativeint
6862
val closure_info : arity:Clambda.arity -> startenv:int -> nativeint
6963

7064
(** Wrappers *)
71-
(* FIXME: these all need mode params *)
72-
val alloc_float_header : Debuginfo.t -> expression
73-
val alloc_floatarray_header : int -> Debuginfo.t -> expression
74-
val alloc_closure_header :
75-
mode:Lambda.alloc_mode -> int -> Debuginfo.t -> expression
7665
val alloc_infix_header : int -> Debuginfo.t -> expression
7766
val alloc_closure_info :
7867
arity:(Lambda.function_kind * int) -> startenv:int ->
7968
Debuginfo.t -> expression
80-
val alloc_boxedint32_header : Debuginfo.t -> expression
81-
val alloc_boxedint64_header : Debuginfo.t -> expression
82-
val alloc_boxedintnat_header : Debuginfo.t -> expression
8369

8470
(** Integers *)
8571

@@ -176,7 +162,7 @@ val raise_symbol : Debuginfo.t -> string -> expression
176162
val test_bool : Debuginfo.t -> expression -> expression
177163

178164
(** Float boxing and unboxing *)
179-
val box_float : Debuginfo.t -> expression -> expression
165+
val box_float : Debuginfo.t -> Lambda.alloc_mode -> expression -> expression
180166
val unbox_float : Debuginfo.t -> expression -> expression
181167

182168
(** Complex number creation and access *)
@@ -373,7 +359,8 @@ val caml_int64_ops : string
373359

374360
(** Box a given integer, without sharing of constants *)
375361
val box_int_gen :
376-
Debuginfo.t -> Primitive.boxed_integer -> expression -> expression
362+
Debuginfo.t -> Primitive.boxed_integer -> Lambda.alloc_mode ->
363+
expression -> expression
377364

378365
(** Unbox a given boxed integer *)
379366
val unbox_int :
@@ -407,7 +394,7 @@ val unaligned_load :
407394

408395
(** [box_sized size dbg exp] *)
409396
val box_sized :
410-
Clambda_primitives.memory_access_size ->
397+
Clambda_primitives.memory_access_size -> Lambda.alloc_mode ->
411398
Debuginfo.t -> expression -> expression
412399

413400
(** Primitives *)
@@ -481,9 +468,11 @@ val stringref_safe : binary_primitive
481468

482469
(** Load by chunk from string/bytes, bigstring. Args: string, index *)
483470
val string_load :
484-
Clambda_primitives.memory_access_size -> Lambda.is_safe -> binary_primitive
471+
Clambda_primitives.memory_access_size -> Lambda.is_safe ->
472+
Lambda.alloc_mode -> binary_primitive
485473
val bigstring_load :
486-
Clambda_primitives.memory_access_size -> Lambda.is_safe -> binary_primitive
474+
Clambda_primitives.memory_access_size -> Lambda.is_safe ->
475+
Lambda.alloc_mode -> binary_primitive
487476

488477
(** Arrays *)
489478

0 commit comments

Comments
 (0)