Skip to content

Commit

Permalink
Allow local allocations for various primitives (ocaml-flambda#43)
Browse files Browse the repository at this point in the history 
  - 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
  • Loading branch information
@stedolan
stedolan committed Nov 15, 2021
1 parent 7a2165e commit a0062ad
Show file tree
Hide file tree
Showing 41 changed files with 1,058 additions and 857 deletions.
98 changes: 58 additions & 40 deletions asmcomp/cmm_helpers.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,6 +58,7 @@ let black_closure_header sz = black_block_header Obj.closure_tag sz
let local_closure_header sz = local_block_header Obj.closure_tag sz
let infix_header ofs = block_header Obj.infix_tag ofs
let float_header = block_header Obj.double_tag (size_float / size_addr)
let float_local_header = local_block_header Obj.double_tag (size_float / size_addr)
let floatarray_header len =
(* Zero-sized float arrays have tag zero for consistency with
[caml_alloc_float_array]. *)
Expand All @@ -69,6 +70,9 @@ let string_header len =
let boxedint32_header = block_header Obj.custom_tag 2
let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr)
let boxedintnat_header = block_header Obj.custom_tag 2
let boxedint32_local_header = local_block_header Obj.custom_tag 2
let boxedint64_local_header = local_block_header Obj.custom_tag (1 + 8 / size_addr)
let boxedintnat_local_header = local_block_header Obj.custom_tag 2
let caml_nativeint_ops = "caml_nativeint_ops"
let caml_int32_ops = "caml_int32_ops"
let caml_int64_ops = "caml_int64_ops"
Expand All @@ -88,7 +92,10 @@ let closure_info ~arity ~startenv =
(add (shift_left (of_int startenv) 1)
1n))

let alloc_float_header dbg = Cconst_natint (float_header, dbg)
let alloc_float_header mode dbg =
match mode with
| Lambda.Alloc_heap -> Cconst_natint (float_header, dbg)
| Lambda.Alloc_local -> Cconst_natint (float_local_header, dbg)
let alloc_floatarray_header len dbg = Cconst_natint (floatarray_header len, dbg)
let alloc_closure_header ~mode sz dbg =
match (mode : Lambda.alloc_mode) with
Expand All @@ -97,9 +104,18 @@ let alloc_closure_header ~mode sz dbg =
let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg)
let alloc_closure_info ~arity ~startenv dbg =
Cconst_natint (closure_info ~arity ~startenv, dbg)
let alloc_boxedint32_header dbg = Cconst_natint (boxedint32_header, dbg)
let alloc_boxedint64_header dbg = Cconst_natint (boxedint64_header, dbg)
let alloc_boxedintnat_header dbg = Cconst_natint (boxedintnat_header, dbg)
let alloc_boxedint32_header mode dbg =
match mode with
| Lambda.Alloc_heap -> Cconst_natint (boxedint32_header, dbg)
| Lambda.Alloc_local -> Cconst_natint (boxedint32_local_header, dbg)
let alloc_boxedint64_header mode dbg =
match mode with
| Lambda.Alloc_heap -> Cconst_natint (boxedint64_header, dbg)
| Lambda.Alloc_local -> Cconst_natint (boxedint64_local_header, dbg)
let alloc_boxedintnat_header mode dbg =
match mode with
| Lambda.Alloc_heap -> Cconst_natint (boxedintnat_header, dbg)
| Lambda.Alloc_local -> Cconst_natint (boxedintnat_local_header, dbg)

(* Integers *)

Expand Down Expand Up @@ -567,7 +583,7 @@ let test_bool dbg cmm =

(* Float *)

let box_float dbg c = Cop(Calloc Alloc_heap, [alloc_float_header dbg; c], dbg)
let box_float dbg m c = Cop(Calloc m, [alloc_float_header m dbg; c], dbg)

let unbox_float dbg =
map_tail
Expand Down Expand Up @@ -742,7 +758,7 @@ let unboxed_float_array_ref arr ofs dbg =
Cop(Cload (Double_u, Mutable),
[array_indexing log2_size_float arr ofs dbg], dbg)
let float_array_ref arr ofs dbg =
box_float dbg (unboxed_float_array_ref arr ofs dbg)
box_float dbg Alloc_heap (unboxed_float_array_ref arr ofs dbg)

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

let alloc_header_boxed_int (bi : Primitive.boxed_integer) =
let alloc_header_boxed_int (bi : Primitive.boxed_integer) mode dbg =
match bi with
Pnativeint -> alloc_boxedintnat_header
| Pint32 -> alloc_boxedint32_header
| Pint64 -> alloc_boxedint64_header
Pnativeint -> alloc_boxedintnat_header mode dbg
| Pint32 -> alloc_boxedint32_header mode dbg
| Pint64 -> alloc_boxedint64_header mode dbg

let box_int_gen dbg (bi : Primitive.boxed_integer) arg =
let box_int_gen dbg (bi : Primitive.boxed_integer) mode arg =
let arg' =
if bi = Primitive.Pint32 && size_int = 8 then
if big_endian
then Cop(Clsl, [arg; Cconst_int (32, dbg)], dbg)
else sign_extend_32 dbg arg
else arg
in
Cop(Calloc Alloc_heap,
[alloc_header_boxed_int bi dbg;
Cop(Calloc mode,
[alloc_header_boxed_int bi mode dbg;
Cconst_symbol(operations_boxed_int bi, dbg);
arg'], dbg)

Expand Down Expand Up @@ -1360,11 +1376,11 @@ let unaligned_load size ptr idx dbg =
| Thirty_two -> unaligned_load_32 ptr idx dbg
| Sixty_four -> unaligned_load_64 ptr idx dbg

let box_sized size dbg exp =
let box_sized size mode dbg exp =
match (size : Clambda_primitives.memory_access_size) with
| Sixteen -> tag_int exp dbg
| Thirty_two -> box_int_gen dbg Pint32 exp
| Sixty_four -> box_int_gen dbg Pint64 exp
| Thirty_two -> box_int_gen dbg Pint32 mode exp
| Sixty_four -> box_int_gen dbg Pint64 mode exp

(* Simplification of some primitives into C calls *)

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

(* FIXME: On 32-bit, these will do heap allocations
even when local allocs are possible *)
let simplif_primitive_32bits :
Clambda_primitives.primitive -> Clambda_primitives.primitive = function
Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
Pbintofint (Pint64,_) -> Pccall (default_prim "caml_int64_of_int")
| Pintofbint Pint64 -> Pccall (default_prim "caml_int64_to_int")
| Pcvtbint(Pint32, Pint64) -> Pccall (default_prim "caml_int64_of_int32")
| Pcvtbint(Pint64, Pint32) -> Pccall (default_prim "caml_int64_to_int32")
| Pcvtbint(Pnativeint, Pint64) ->
| Pcvtbint(Pint32, Pint64,_) -> Pccall (default_prim "caml_int64_of_int32")
| Pcvtbint(Pint64, Pint32,_) -> Pccall (default_prim "caml_int64_to_int32")
| Pcvtbint(Pnativeint, Pint64,_) ->
Pccall (default_prim "caml_int64_of_nativeint")
| Pcvtbint(Pint64, Pnativeint) ->
| Pcvtbint(Pint64, Pnativeint,_) ->
Pccall (default_prim "caml_int64_to_nativeint")
| Pnegbint Pint64 -> Pccall (int64_native_prim "caml_int64_neg" 1
| Pnegbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_neg" 1
~alloc:false)
| Paddbint Pint64 -> Pccall (int64_native_prim "caml_int64_add" 2
| Paddbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_add" 2
~alloc:false)
| Psubbint Pint64 -> Pccall (int64_native_prim "caml_int64_sub" 2
| Psubbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_sub" 2
~alloc:false)
| Pmulbint Pint64 -> Pccall (int64_native_prim "caml_int64_mul" 2
| Pmulbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_mul" 2
~alloc:false)
| Pdivbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_div" 2
~alloc:true)
| Pmodbint {size=Pint64} -> Pccall (int64_native_prim "caml_int64_mod" 2
~alloc:true)
| Pandbint Pint64 -> Pccall (int64_native_prim "caml_int64_and" 2
| Pandbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_and" 2
~alloc:false)
| Porbint Pint64 -> Pccall (int64_native_prim "caml_int64_or" 2
| Porbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_or" 2
~alloc:false)
| Pxorbint Pint64 -> Pccall (int64_native_prim "caml_int64_xor" 2
| Pxorbint(Pint64,_) -> Pccall (int64_native_prim "caml_int64_xor" 2
~alloc:false)
| Plslbint Pint64 -> Pccall (default_prim "caml_int64_shift_left")
| Plsrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right_unsigned")
| Pasrbint Pint64 -> Pccall (default_prim "caml_int64_shift_right")
| Plslbint(Pint64,_) -> Pccall (default_prim "caml_int64_shift_left")
| Plsrbint(Pint64,_) -> Pccall (default_prim "caml_int64_shift_right_unsigned")
| Pasrbint(Pint64,_) -> Pccall (default_prim "caml_int64_shift_right")
| Pbintcomp(Pint64, Lambda.Ceq) -> Pccall (default_prim "caml_equal")
| Pbintcomp(Pint64, Lambda.Cne) -> Pccall (default_prim "caml_notequal")
| Pbintcomp(Pint64, Lambda.Clt) -> Pccall (default_prim "caml_lessthan")
Expand All @@ -1422,12 +1440,12 @@ let simplif_primitive_32bits :
Pccall (default_prim ("caml_ba_get_" ^ Int.to_string n))
| Pbigarrayset(_unsafe, n, Pbigarray_int64, _layout) ->
Pccall (default_prim ("caml_ba_set_" ^ Int.to_string n))
| Pstring_load(Sixty_four, _) -> Pccall (default_prim "caml_string_get64")
| Pbytes_load(Sixty_four, _) -> Pccall (default_prim "caml_bytes_get64")
| Pstring_load(Sixty_four, _, _) -> Pccall (default_prim "caml_string_get64")
| Pbytes_load(Sixty_four, _, _) -> Pccall (default_prim "caml_bytes_get64")
| Pbytes_set(Sixty_four, _) -> Pccall (default_prim "caml_bytes_set64")
| Pbigstring_load(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_get64")
| Pbigstring_load(Sixty_four,_,_) -> Pccall (default_prim "caml_ba_uint8_get64")
| Pbigstring_set(Sixty_four,_) -> Pccall (default_prim "caml_ba_uint8_set64")
| Pbbswap Pint64 -> Pccall (default_prim "caml_int64_bswap")
| Pbbswap (Pint64,_) -> Pccall (default_prim "caml_int64_bswap")
| p -> p

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

let string_load size unsafe arg1 arg2 dbg =
box_sized size dbg
let string_load size unsafe mode arg1 arg2 dbg =
box_sized size mode dbg
(bind "str" arg1 (fun str ->
bind "index" (untag_int arg2 dbg) (fun idx ->
check_bound unsafe size dbg
(string_length str dbg)
idx (unaligned_load size str idx dbg))))

let bigstring_load size unsafe arg1 arg2 dbg =
box_sized size dbg
let bigstring_load size unsafe mode arg1 arg2 dbg =
box_sized size mode dbg
(bind "ba" arg1 (fun ba ->
bind "index" (untag_int arg2 dbg) (fun idx ->
bind "ba_data"
Expand Down Expand Up @@ -2406,7 +2424,7 @@ let arrayref_safe kind arg1 arg2 dbg =
(get_header_without_profinfo arr dbg) dbg; idx],
int_array_ref arr idx dbg)))
| Pfloatarray ->
box_float dbg (
box_float dbg Alloc_heap (
bind "index" arg2 (fun idx ->
bind "arr" arg1 (fun arr ->
Csequence(
Expand Down
27 changes: 8 additions & 19 deletions asmcomp/cmm_helpers.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,12 +53,6 @@ val infix_header : int -> nativeint
(** Header for a boxed float value *)
val float_header : nativeint

(** Header for an unboxed float array of the given size *)
val floatarray_header : int -> nativeint

(** Header for a string (or bytes) of the given length *)
val string_header : int -> nativeint

(** Boxed integer headers *)
val boxedint32_header : nativeint
val boxedint64_header : nativeint
Expand All @@ -68,18 +62,10 @@ val boxedintnat_header : nativeint
val closure_info : arity:Clambda.arity -> startenv:int -> nativeint

(** Wrappers *)
(* FIXME: these all need mode params *)
val alloc_float_header : Debuginfo.t -> expression
val alloc_floatarray_header : int -> Debuginfo.t -> expression
val alloc_closure_header :
mode:Lambda.alloc_mode -> int -> Debuginfo.t -> expression
val alloc_infix_header : int -> Debuginfo.t -> expression
val alloc_closure_info :
arity:(Lambda.function_kind * int) -> startenv:int ->
Debuginfo.t -> expression
val alloc_boxedint32_header : Debuginfo.t -> expression
val alloc_boxedint64_header : Debuginfo.t -> expression
val alloc_boxedintnat_header : Debuginfo.t -> expression

(** Integers *)

Expand Down Expand Up @@ -176,7 +162,7 @@ val raise_symbol : Debuginfo.t -> string -> expression
val test_bool : Debuginfo.t -> expression -> expression

(** Float boxing and unboxing *)
val box_float : Debuginfo.t -> expression -> expression
val box_float : Debuginfo.t -> Lambda.alloc_mode -> expression -> expression
val unbox_float : Debuginfo.t -> expression -> expression

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

(** Box a given integer, without sharing of constants *)
val box_int_gen :
Debuginfo.t -> Primitive.boxed_integer -> expression -> expression
Debuginfo.t -> Primitive.boxed_integer -> Lambda.alloc_mode ->
expression -> expression

(** Unbox a given boxed integer *)
val unbox_int :
Expand Down Expand Up @@ -407,7 +394,7 @@ val unaligned_load :

(** [box_sized size dbg exp] *)
val box_sized :
Clambda_primitives.memory_access_size ->
Clambda_primitives.memory_access_size -> Lambda.alloc_mode ->
Debuginfo.t -> expression -> expression

(** Primitives *)
Expand Down Expand Up @@ -481,9 +468,11 @@ val stringref_safe : binary_primitive

(** Load by chunk from string/bytes, bigstring. Args: string, index *)
val string_load :
Clambda_primitives.memory_access_size -> Lambda.is_safe -> binary_primitive
Clambda_primitives.memory_access_size -> Lambda.is_safe ->
Lambda.alloc_mode -> binary_primitive
val bigstring_load :
Clambda_primitives.memory_access_size -> Lambda.is_safe -> binary_primitive
Clambda_primitives.memory_access_size -> Lambda.is_safe ->
Lambda.alloc_mode -> binary_primitive

(** Arrays *)

Expand Down
Loading

0 comments on commit a0062ad

Please sign in to comment.