diff --git a/backend/amd64/emit.mlp b/backend/amd64/emit.mlp index 950b92424f5..8b189540dd9 100644 --- a/backend/amd64/emit.mlp +++ b/backend/amd64/emit.mlp @@ -1046,7 +1046,8 @@ let emit_simd_instr op i = | SSE High_64_to_low_64 -> I.movhlps (arg i 1) (res i 0) | SSE Low_64_to_high_64 -> I.movlhps (arg i 1) (res i 0) | SSE Interleave_high_32 -> I.unpckhps (arg i 1) (res i 0) - | SSE Interleave_low_32 -> I.unpcklps (arg i 1) (res i 0) + | SSE (Interleave_low_32 | Interleave_low_32_regs) -> + I.unpcklps (arg i 1) (res i 0) | SSE Movemask_32 -> I.movmskps (arg i 0) (res i 0) | SSE (Shuffle_32 n) -> I.shufps (X86_dsl.int n) (arg i 1) (res i 0) | SSE2 Max_scalar_f64 -> I.maxsd (arg i 1) (res i 0) @@ -1568,6 +1569,8 @@ let emit_instr ~first ~fallthrough i = instr_for_floatop width floatop (arg i 1) (res i 0) | Lop(Iintofvalue | Ivalueofint | Ivectorcast Bits128) -> move i.arg.(0) i.res.(0) + | Lop(Iscalarcast Float32_as_float) -> + I.movss (arg i 0) (res i 0) | Lop(Iscalarcast (Float_of_int Float64)) -> I.cvtsi2sd (arg i 0) (res i 0) | Lop(Iscalarcast (Float_to_int Float64)) -> diff --git a/backend/amd64/proc.ml b/backend/amd64/proc.ml index 803bb5c444c..8fe7a24c8f7 100644 --- a/backend/amd64/proc.ml +++ b/backend/amd64/proc.ml @@ -796,7 +796,7 @@ let operation_supported = function | Cbswap _ | Cclz _ | Cctz _ | Ccmpi _ | Caddv | Cadda | Ccmpa _ - | Cnegf _ | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ + | Cnegf _ | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 | Cvalueofint | Cintofvalue | Ccmpf _ | Craise _ diff --git a/backend/amd64/regalloc_stack_operands.ml b/backend/amd64/regalloc_stack_operands.ml index 6124dce9e2b..08a0e562cc3 100644 --- a/backend/amd64/regalloc_stack_operands.ml +++ b/backend/amd64/regalloc_stack_operands.ml @@ -192,7 +192,8 @@ let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = May_still_have_spilled_registers | Op (Scalarcast (Float_of_int (Float32 | Float64) | Float_to_int (Float32 | Float64) | - Float_of_float32 | Float_to_float32) | + Float_of_float32 | Float_to_float32 | + Float32_as_float) | Vectorcast _) -> may_use_stack_operand_for_only_argument map instr ~has_result:true | Op (Const_symbol _) -> diff --git a/backend/amd64/reload.ml b/backend/amd64/reload.ml index c50dbb09d58..d2ae1d0f516 100644 --- a/backend/amd64/reload.ml +++ b/backend/amd64/reload.ml @@ -160,7 +160,8 @@ method! reload_operation op arg res = (arg', [|r|]) | Iscalarcast (Float_of_int (Float32 | Float64) | Float_to_int (Float32 | Float64) | - Float_of_float32 | Float_to_float32) -> + Float_of_float32 | Float_to_float32 | + Float32_as_float) -> (* Result must be in register, but argument can be on stack *) (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) | Iscalarcast (V128_to_scalar (Float64x2) | V128_of_scalar (Float64x2)) -> diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index 49ed76bc781..aea8db9b251 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -298,6 +298,12 @@ method! select_operation op args dbg = self#select_floatarith true width Imulf Ifloatmul args | Cdivf width -> self#select_floatarith false width Idivf Ifloatdiv args + | Cpackf32 -> + (* We must operate on registers. This is because if the second argument + was a float stack slot, the resulting UNPCKLPS instruction would + enforce the validity of loading it as a 128-bit memory location, + even though it only loads 64 bits. *) + Ispecific (Isimd (SSE Interleave_low_32_regs)), args (* Special cases overriding C implementations (regardless of [@@builtin]). *) | Cextcall { func = ("sqrt" as func); _ } | Cextcall { func = ("caml_int64_bits_of_float_unboxed" as func); _ } diff --git a/backend/amd64/simd.ml b/backend/amd64/simd.ml index 3b5b69215af..d6774d6a662 100644 --- a/backend/amd64/simd.ml +++ b/backend/amd64/simd.ml @@ -82,6 +82,7 @@ type sse_operation = | Low_64_to_high_64 | Interleave_high_32 | Interleave_low_32 + | Interleave_low_32_regs | Movemask_32 | Shuffle_32 of int @@ -305,14 +306,15 @@ let equal_operation_sse l r = | Low_64_to_high_64, Low_64_to_high_64 | Interleave_high_32, Interleave_high_32 | Interleave_low_32, Interleave_low_32 + | Interleave_low_32_regs, Interleave_low_32_regs | Movemask_32, Movemask_32 -> true | Cmp_f32 l, Cmp_f32 r when float_condition_equal l r -> true | Shuffle_32 l, Shuffle_32 r when Int.equal l r -> true | ( ( Add_f32 | Sub_f32 | Mul_f32 | Div_f32 | Max_f32 | Min_f32 | Rcp_f32 | Sqrt_f32 | Rsqrt_f32 | High_64_to_low_64 | Low_64_to_high_64 - | Interleave_high_32 | Interleave_low_32 | Movemask_32 | Cmp_f32 _ - | Shuffle_32 _ ), + | Interleave_high_32 | Interleave_low_32_regs | Interleave_low_32 + | Movemask_32 | Cmp_f32 _ | Shuffle_32 _ ), _ ) -> false @@ -637,6 +639,8 @@ let print_operation_sse printreg op ppf arg = fprintf ppf "interleave_high_32 %a %a" printreg arg.(0) printreg arg.(1) | Interleave_low_32 -> fprintf ppf "interleave_low_32 %a %a" printreg arg.(0) printreg arg.(1) + | Interleave_low_32_regs -> + fprintf ppf "interleave_low_32_regs %a %a" printreg arg.(0) printreg arg.(1) let print_operation_sse2 printreg op ppf arg = match op with @@ -922,7 +926,8 @@ let class_of_operation_bmi2 = function Deposit_64 | Extract_64 -> Pure let class_of_operation_sse = function | Cmp_f32 _ | Add_f32 | Sub_f32 | Mul_f32 | Div_f32 | Max_f32 | Min_f32 | Rcp_f32 | Sqrt_f32 | Rsqrt_f32 | High_64_to_low_64 | Low_64_to_high_64 - | Interleave_high_32 | Interleave_low_32 | Movemask_32 | Shuffle_32 _ -> + | Interleave_high_32 | Interleave_low_32 | Interleave_low_32_regs + | Movemask_32 | Shuffle_32 _ -> Pure let class_of_operation_sse2 = function diff --git a/backend/amd64/simd_proc.ml b/backend/amd64/simd_proc.ml index aaae42d17c5..b79a4dcb692 100644 --- a/backend/amd64/simd_proc.ml +++ b/backend/amd64/simd_proc.ml @@ -43,7 +43,7 @@ let register_behavior_sse = function | Interleave_low_32 | Interleave_high_32 | Shuffle_32 _ -> R_RM_to_fst | Rcp_f32 | Sqrt_f32 | Rsqrt_f32 -> RM_to_R - | High_64_to_low_64 | Low_64_to_high_64 -> R_R_to_fst + | Interleave_low_32_regs | High_64_to_low_64 | Low_64_to_high_64 -> R_R_to_fst | Movemask_32 -> R_to_R let register_behavior_sse2 = function diff --git a/backend/arm64/emit.mlp b/backend/arm64/emit.mlp index 4dbd87a2c74..d1f9914d3a0 100644 --- a/backend/arm64/emit.mlp +++ b/backend/arm64/emit.mlp @@ -554,7 +554,8 @@ module BR = Branch_relaxation.Make (struct | Lop (Ivectorcast _) -> 1 | Lop (Iscalarcast (Float_of_int Float64 | Float_to_int Float64)) -> 1 | Lop (Iscalarcast (Float_of_int Float32 | Float_to_int Float32 | - Float_of_float32 | Float_to_float32)) -> + Float_of_float32 | Float_to_float32 | + Float32_as_float)) -> (* CR mslater: (float32) arm64 *) Misc.fatal_error "float32 is not supported on this architecture" | Lop (Iscalarcast (V128_of_scalar _ | V128_to_scalar _)) -> @@ -784,7 +785,8 @@ let emit_instr i = | Lop(Iscalarcast (Float_of_int Float64)) -> ` scvtf {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop (Iscalarcast (Float_of_int Float32 | Float_to_int Float32 | - Float_of_float32 | Float_to_float32)) -> + Float_of_float32 | Float_to_float32 | + Float32_as_float)) -> (* CR mslater: (float32) arm64 *) Misc.fatal_error "float32 not supported on this architecture" | Lop(Iscalarcast (V128_of_scalar _ | V128_to_scalar _) | Ivectorcast _) -> diff --git a/backend/arm64/proc.ml b/backend/arm64/proc.ml index c2b0bb5834b..b18ad039cdf 100644 --- a/backend/arm64/proc.ml +++ b/backend/arm64/proc.ml @@ -489,9 +489,11 @@ let operation_supported = function (* CR mslater: (float32) arm64 *) | Cnegf Float32 | Cabsf Float32 | Caddf Float32 | Csubf Float32 | Cmulf Float32 | Cdivf Float32 + | Cpackf32 | Cvectorcast _ | Cscalarcast (Float_of_float32 | Float_to_float32 | Float_to_int Float32 | Float_of_int Float32 | - V128_of_scalar _ | V128_to_scalar _) + V128_of_scalar _ | V128_to_scalar _ | + Float32_as_float) -> false (* Not implemented *) | Cbswap _ | Capply _ | Cextcall _ | Cload _ | Calloc _ | Cstore _ diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index 2513c3aec0d..f36d0a6db67 100644 --- a/backend/cfg/cfg.ml +++ b/backend/cfg/cfg.ml @@ -287,6 +287,7 @@ let dump_op ppf = function | Valueofint -> Format.fprintf ppf "valueofint" | Intofvalue -> Format.fprintf ppf "intofvalue" | Vectorcast Bits128 -> Format.fprintf ppf "vec128->vec128" + | Scalarcast Float32_as_float -> Format.fprintf ppf "float32 as float" | Scalarcast (Float_of_int Float64) -> Format.fprintf ppf "int->float" | Scalarcast (Float_to_int Float64) -> Format.fprintf ppf "float->int" | Scalarcast (Float_of_int Float32) -> Format.fprintf ppf "int->float32" diff --git a/backend/cmm.ml b/backend/cmm.ml index 56d99380cda..2bacd8a5662 100644 --- a/backend/cmm.ml +++ b/backend/cmm.ml @@ -207,6 +207,7 @@ type vector_cast = | Bits128 type scalar_cast = + | Float32_as_float | Float_to_int of float_width | Float_of_int of float_width | Float_to_float32 @@ -248,6 +249,7 @@ type operation = | Cnegf of float_width | Cabsf of float_width | Caddf of float_width | Csubf of float_width | Cmulf of float_width | Cdivf of float_width + | Cpackf32 | Cvalueofint | Cintofvalue | Cvectorcast of vector_cast | Cscalarcast of scalar_cast @@ -563,25 +565,17 @@ let equal_float_width left right = let equal_scalar_cast left right = match left, right with + | Float32_as_float, Float32_as_float -> true | Float_to_float32, Float_to_float32 -> true | Float_of_float32, Float_of_float32 -> true | Float_to_int f1, Float_to_int f2 -> equal_float_width f1 f2 | Float_of_int f1, Float_of_int f2 -> equal_float_width f1 f2 | V128_to_scalar v1, V128_to_scalar v2 -> Primitive.equal_vec128_type v1 v2 | V128_of_scalar v1, V128_of_scalar v2 -> Primitive.equal_vec128_type v1 v2 - | Float_to_float32, (Float_of_float32 | Float_to_int _ | Float_of_int _ | - V128_to_scalar _ | V128_of_scalar _) - | Float_of_float32, (Float_to_float32 | Float_to_int _ | Float_of_int _ | - V128_to_scalar _ | V128_of_scalar _) - | Float_to_int _, (Float_of_float32 | Float_to_float32 | Float_of_int _ | - V128_to_scalar _ | V128_of_scalar _) - | Float_of_int _, (Float_of_float32 | Float_to_float32 | Float_to_int _ | - V128_to_scalar _ | V128_of_scalar _) - | V128_to_scalar _, (Float_of_float32 | Float_to_float32 | Float_to_int _ | - Float_of_int _ | V128_of_scalar _) - | V128_of_scalar _, (Float_of_float32 | Float_to_float32 | Float_to_int _ | - Float_of_int _ | V128_to_scalar _) - -> false + | (Float32_as_float | + Float_to_float32 | Float_of_float32 | + Float_to_int _ | Float_of_int _ | + V128_to_scalar _ | V128_of_scalar _), _ -> false let equal_float_comparison left right = match left, right with diff --git a/backend/cmm.mli b/backend/cmm.mli index 8d916ad944f..b48db22689d 100644 --- a/backend/cmm.mli +++ b/backend/cmm.mli @@ -182,6 +182,8 @@ type vector_cast = | Bits128 type scalar_cast = + (* CR mslater: move all bit-casts into a reinterpret_cast type *) + | Float32_as_float | Float_to_int of float_width | Float_of_int of float_width | Float_to_float32 @@ -228,6 +230,7 @@ type operation = | Cnegf of float_width | Cabsf of float_width | Caddf of float_width | Csubf of float_width | Cmulf of float_width | Cdivf of float_width + | Cpackf32 | Cvalueofint | Cintofvalue | Cvectorcast of vector_cast | Cscalarcast of scalar_cast diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index cd4077093e9..eed1515c942 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -1025,6 +1025,22 @@ let custom_ops_unboxed_int32_odd_array = Cconst_int (Config.custom_ops_struct_size, Debuginfo.none) ], Debuginfo.none ) +(* caml_unboxed_float32_array_ops refers to the first element of an array of two + custom ops. The array index indicates the number of (invalid) tailing + float32s (0 or 1). *) +let custom_ops_unboxed_float32_array = + Cconst_symbol + (Cmm.global_symbol "caml_unboxed_float32_array_ops", Debuginfo.none) + +let custom_ops_unboxed_float32_even_array = custom_ops_unboxed_float32_array + +let custom_ops_unboxed_float32_odd_array = + Cop + ( Caddi, + [ custom_ops_unboxed_float32_array; + Cconst_int (Config.custom_ops_struct_size, Debuginfo.none) ], + Debuginfo.none ) + let custom_ops_unboxed_int64_array = Cconst_symbol (Cmm.global_symbol "caml_unboxed_int64_array_ops", Debuginfo.none) @@ -1033,7 +1049,8 @@ let custom_ops_unboxed_nativeint_array = Cconst_symbol (Cmm.global_symbol "caml_unboxed_nativeint_array_ops", Debuginfo.none) -let unboxed_int32_array_length arr dbg = +let unboxed_packed_array_length arr dbg ~custom_ops_base_symbol + ~elements_per_word = (* Checking custom_ops is needed to determine if the array contains an odd or even number of elements *) let res = @@ -1054,17 +1071,27 @@ let unboxed_int32_array_length arr dbg = ( VP.create custom_ops_index_var, (* compute index into custom ops array *) lsr_int - (sub_int (Cvar custom_ops_var) - custom_ops_unboxed_int32_array dbg) + (sub_int (Cvar custom_ops_var) custom_ops_base_symbol dbg) (int ~dbg custom_ops_size_log2) dbg, - (* subtract index from length in int32s *) + (* subtract index from length in elements *) sub_int - (mul_int (Cvar num_words_var) (int ~dbg 2) dbg) + (mul_int (Cvar num_words_var) + (int ~dbg elements_per_word) + dbg) (Cvar custom_ops_index_var) dbg ) ) )) in tag_int res dbg +let unboxed_int32_array_length = + unboxed_packed_array_length + ~custom_ops_base_symbol:custom_ops_unboxed_int32_array ~elements_per_word:2 + +let unboxed_float32_array_length = + unboxed_packed_array_length + ~custom_ops_base_symbol:custom_ops_unboxed_float32_array + ~elements_per_word:2 + let unboxed_int64_or_nativeint_array_length arr dbg = let res = bind "arr" arr (fun arr -> @@ -1179,24 +1206,33 @@ let sign_extend_32 dbg e = [Cop (Clsl, [e; Cconst_int (32, dbg)], dbg); Cconst_int (32, dbg)], dbg ) -let unboxed_int32_array_ref arr index dbg = +let unboxed_packed_array_ref arr index dbg ~memory_chunk ~elements_per_word = bind "arr" arr (fun arr -> bind "index" index (fun index -> let index = - (* Need to skip the custom_operations field. We add 2 element - offsets not 1 since the call to [array_indexing], below, is in - terms of 32-bit words. Then we multiply the offset by 2 to get 4 - since we are manipulating a tagged int. *) - add_int index (int ~dbg 4) dbg + (* Need to skip the custom_operations field. We add + elements_per_word offsets not 1 since the call to + [array_indexing], below, is in terms of elements. Then we + multiply the offset by 2 since we are manipulating a tagged + int. *) + add_int index (int ~dbg (elements_per_word * 2)) dbg in let log2_size_addr = 2 in - (* N.B. The resulting value will be sign extended by the code - generated for a [Thirtytwo_signed] load. *) Cop - ( mk_load_mut Thirtytwo_signed, + ( mk_load_mut memory_chunk, [array_indexing log2_size_addr arr index dbg], dbg ))) +let unboxed_int32_array_ref = + (* N.B. The resulting value will be sign extended by the code generated for a + [Thirtytwo_signed] load. *) + unboxed_packed_array_ref ~memory_chunk:Thirtytwo_signed ~elements_per_word:2 + +let unboxed_float32_array_ref = + unboxed_packed_array_ref + ~memory_chunk:(Single { reg = Float32 }) + ~elements_per_word:2 + let unboxed_int64_or_nativeint_array_ref arr index dbg = bind "arr" arr (fun arr -> bind "index" index (fun index -> @@ -1207,20 +1243,29 @@ let unboxed_int64_or_nativeint_array_ref arr index dbg = in int_array_ref arr index dbg)) -let unboxed_int32_array_set arr ~index ~new_value dbg = +let unboxed_packed_array_set arr ~index ~new_value dbg ~memory_chunk + ~elements_per_word = bind "arr" arr (fun arr -> bind "index" index (fun index -> bind "new_value" new_value (fun new_value -> let index = - (* See comment in [unboxed_int32_array_ref]. *) - add_int index (int ~dbg 4) dbg + (* See comment in [unboxed_packed_array_ref]. *) + add_int index (int ~dbg (elements_per_word * 2)) dbg in let log2_size_addr = 2 in Cop - ( Cstore (Thirtytwo_signed, Assignment), + ( Cstore (memory_chunk, Assignment), [array_indexing log2_size_addr arr index dbg; new_value], dbg )))) +let unboxed_int32_array_set = + unboxed_packed_array_set ~memory_chunk:Thirtytwo_signed ~elements_per_word:2 + +let unboxed_float32_array_set = + unboxed_packed_array_set + ~memory_chunk:(Single { reg = Float32 }) + ~elements_per_word:2 + let unboxed_int64_or_nativeint_array_set arr ~index ~new_value dbg = bind "arr" arr (fun arr -> bind "index" index (fun index -> @@ -3076,9 +3121,7 @@ let arraylength kind arg dbg = (* Note: we only support 64 bit targets now, so this is ok for Punboxedfloatarray *) Cop (Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg) - | Punboxedfloatarray Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Punboxedfloatarray Pfloat32 -> unboxed_float32_array_length arg dbg | Punboxedintarray Pint64 | Punboxedintarray Pnativeint -> unboxed_int64_or_nativeint_array_length arg dbg | Punboxedintarray Pint32 -> unboxed_int32_array_length arg dbg @@ -3999,13 +4042,50 @@ let allocate_unboxed_int32_array ~elements (mode : Lambda.alloc_mode) dbg = in let custom_ops = (* For odd-length unboxed int32 arrays there are 32 bits spare at the end of - the block, which are never read. *) + the block, which are never read. They are initialized to the sign + extension of the last element. *) match num_elts with | Even -> custom_ops_unboxed_int32_even_array | Odd -> custom_ops_unboxed_int32_odd_array in Cop (Calloc mode, Cconst_natint (header, dbg) :: custom_ops :: payload, dbg) +let make_unboxed_float32_array_payload dbg unboxed_float32_list = + if Sys.big_endian + then + Misc.fatal_error "Big-endian platforms not yet supported for unboxed arrays"; + let rec aux acc = function + | [] -> Even, List.rev acc + | a :: [] -> Odd, List.rev (a :: acc) + | a :: b :: r -> + let i = + Cop + ( Cpackf32, + [ Cop (Cscalarcast Float32_as_float, [a], dbg); + Cop (Cscalarcast Float32_as_float, [b], dbg) ], + dbg ) + in + aux (i :: acc) r + in + aux [] unboxed_float32_list + +let allocate_unboxed_float32_array ~elements (mode : Lambda.alloc_mode) dbg = + let num_elts, payload = make_unboxed_float32_array_payload dbg elements in + let header = + let size = 1 (* custom_ops field *) + List.length payload in + match mode with + | Alloc_heap -> custom_header ~size + | Alloc_local -> custom_local_header ~size + in + let custom_ops = + (* For odd-length unboxed float32 arrays there are 32 bits spare at the end + of the block, which are never read. They are *not* initialized. *) + match num_elts with + | Even -> custom_ops_unboxed_float32_even_array + | Odd -> custom_ops_unboxed_float32_odd_array + in + Cop (Calloc mode, Cconst_natint (header, dbg) :: custom_ops :: payload, dbg) + let allocate_unboxed_int64_or_nativeint_array custom_ops ~elements (mode : Lambda.alloc_mode) dbg = let header = diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index de06fed3dcd..1c3327042a8 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -958,6 +958,11 @@ val atomic_compare_and_set : val emit_gc_roots_table : symbols:symbol list -> phrase list -> phrase list +(** Allocate a block to hold an unboxed float32 array for the given number of + elements. *) +val allocate_unboxed_float32_array : + elements:Cmm.expression list -> Lambda.alloc_mode -> Debuginfo.t -> expression + (** Allocate a block to hold an unboxed int32 array for the given number of elements. *) val allocate_unboxed_int32_array : @@ -973,6 +978,9 @@ val allocate_unboxed_int64_array : val allocate_unboxed_nativeint_array : elements:Cmm.expression list -> Lambda.alloc_mode -> Debuginfo.t -> expression +(** Compute the length of an unboxed float32 array. *) +val unboxed_float32_array_length : expression -> Debuginfo.t -> expression + (** Compute the length of an unboxed int32 array. *) val unboxed_int32_array_length : expression -> Debuginfo.t -> expression @@ -980,6 +988,10 @@ val unboxed_int32_array_length : expression -> Debuginfo.t -> expression val unboxed_int64_or_nativeint_array_length : expression -> Debuginfo.t -> expression +(** Read from an unboxed float32 array (without bounds check). *) +val unboxed_float32_array_ref : + expression -> expression -> Debuginfo.t -> expression + (** Read from an unboxed int32 array (without bounds check). *) val unboxed_int32_array_ref : expression -> expression -> Debuginfo.t -> expression @@ -989,6 +1001,14 @@ val unboxed_int32_array_ref : val unboxed_int64_or_nativeint_array_ref : expression -> expression -> Debuginfo.t -> expression +(** Update an unboxed float32 array (without bounds check). *) +val unboxed_float32_array_set : + expression -> + index:expression -> + new_value:expression -> + Debuginfo.t -> + expression + (** Update an unboxed int32 array (without bounds check). *) val unboxed_int32_array_set : expression -> diff --git a/backend/printcmm.ml b/backend/printcmm.ml index 2f1a1c12645..3838c70ba31 100644 --- a/backend/printcmm.ml +++ b/backend/printcmm.ml @@ -228,12 +228,14 @@ let operation d = function | Csubf Float32 -> "-f32" | Cmulf Float32 -> "*f32" | Cdivf Float32 -> "/f32" + | Cpackf32 -> "packf32" | Ccsel ret_typ -> to_string "csel %a" machtype ret_typ | Cvalueofint -> "valueofint" | Cintofvalue -> "intofvalue" | Cvectorcast Bits128 -> Printf.sprintf "vec128->vec128" + | Cscalarcast Float32_as_float -> "float32 as float" | Cscalarcast (Float_to_int Float64) -> "float->int" | Cscalarcast (Float_of_int Float64) -> "int->float" | Cscalarcast (Float_to_int Float32) -> "float32->int" diff --git a/backend/printmach.ml b/backend/printmach.ml index 440e9ede0a2..283ac0ce242 100644 --- a/backend/printmach.ml +++ b/backend/printmach.ml @@ -230,6 +230,7 @@ let operation' ?(print_reg = reg) op arg ppf res = | Ivectorcast Bits128 -> fprintf ppf "vec128->vec128 %a" reg arg.(0) + | Iscalarcast Float32_as_float -> fprintf ppf "float32 as float %a" reg arg.(0) | Iscalarcast (Float_of_int Float64) -> fprintf ppf "int->float %a" reg arg.(0) | Iscalarcast (Float_to_int Float64) -> fprintf ppf "float->int %a" reg arg.(0) | Iscalarcast (Float_of_int Float32) -> fprintf ppf "int->float32 %a" reg arg.(0) diff --git a/backend/selectgen.ml b/backend/selectgen.ml index c682283e78d..1d11299a8bc 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -175,11 +175,12 @@ let oper_result_type = function | Csubf Float64 | Cmulf Float64 | Cdivf Float64 -> typ_float | Cnegf Float32 | Cabsf Float32 | Caddf Float32 | Csubf Float32 | Cmulf Float32 | Cdivf Float32 -> typ_float32 + | Cpackf32 -> typ_float | Ccsel ty -> ty | Cvalueofint -> typ_val | Cintofvalue -> typ_int | Cvectorcast Bits128 -> typ_vec128 - | Cscalarcast (Float_of_float32 | Float_of_int Float64) -> typ_float + | Cscalarcast (Float32_as_float | Float_of_float32 | Float_of_int Float64) -> typ_float | Cscalarcast (Float_to_float32 | Float_of_int Float32) -> typ_float32 | Cscalarcast (Float_to_int (Float64 | Float32)) -> typ_int | Cscalarcast (V128_of_scalar _) -> typ_vec128 @@ -501,7 +502,7 @@ method is_simple_expr = function | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ | Ccsel _ - | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ + | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 | Cvectorcast _ | Cscalarcast _ | Cvalueofint | Cintofvalue | Ctuple_field _ @@ -559,7 +560,7 @@ method effects_of exp = | Ccsel _ | Cclz _ | Cctz _ | Cpopcnt | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ - | Cnegf _ | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ + | Cnegf _ | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 | Cvectorcast _ | Cscalarcast _ | Cvalueofint | Cintofvalue | Ccmpf _ -> EC.none diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index 0ceb297d708..12e0626a1b7 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -507,9 +507,9 @@ module Acc = struct | Set_of_closures _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ | Immutable_float_array _ - | Immutable_value_array _ | Empty_array _ | Immutable_int32_array _ - | Immutable_int64_array _ | Immutable_nativeint_array _ | Mutable_string _ - | Immutable_string _ -> + | Immutable_float32_array _ | Immutable_value_array _ | Empty_array _ + | Immutable_int32_array _ | Immutable_int64_array _ + | Immutable_nativeint_array _ | Mutable_string _ | Immutable_string _ -> Value_unknown in let symbol_approximations = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index c28f736c9b6..7d58ffee0e1 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -129,9 +129,7 @@ let convert_array_kind (kind : L.array_kind) : converted_array_kind = | Paddrarray -> Array_kind Values | Pintarray -> Array_kind Immediates | Pfloatarray | Punboxedfloatarray Pfloat64 -> Array_kind Naked_floats - | Punboxedfloatarray Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Punboxedfloatarray Pfloat32 -> Array_kind Naked_float32s | Punboxedintarray Pint32 -> Array_kind Naked_int32s | Punboxedintarray Pint64 -> Array_kind Naked_int64s | Punboxedintarray Pnativeint -> Array_kind Naked_nativeints @@ -142,12 +140,12 @@ let convert_array_kind_for_length kind : P.Array_kind_for_length.t = | Float_array_opt_dynamic -> Float_array_opt_dynamic module Array_ref_kind = struct - (* CR mslater: (float32) unboxed arrays *) type t = | Immediates | Values | Naked_floats_to_be_boxed of L.alloc_mode | Naked_floats + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints @@ -173,9 +171,7 @@ let convert_array_ref_kind (kind : L.array_ref_kind) : converted_array_ref_kind | Pintarray_ref -> Array_ref_kind Immediates | Pfloatarray_ref mode -> Array_ref_kind (Naked_floats_to_be_boxed mode) | Punboxedfloatarray_ref Pfloat64 -> Array_ref_kind Naked_floats - | Punboxedfloatarray_ref Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Punboxedfloatarray_ref Pfloat32 -> Array_ref_kind Naked_float32s | Punboxedintarray_ref Pint32 -> Array_ref_kind Naked_int32s | Punboxedintarray_ref Pint64 -> Array_ref_kind Naked_int64s | Punboxedintarray_ref Pnativeint -> Array_ref_kind Naked_nativeints @@ -188,6 +184,7 @@ let convert_array_ref_kind_for_length array_ref_kind : P.Array_kind_for_length.t | Array_ref_kind Immediates -> Array_kind Immediates | Array_ref_kind (Naked_floats | Naked_floats_to_be_boxed _) -> Array_kind Naked_floats + | Array_ref_kind Naked_float32s -> Array_kind Naked_float32s | Array_ref_kind Naked_int32s -> Array_kind Naked_int32s | Array_ref_kind Naked_int64s -> Array_kind Naked_int64s | Array_ref_kind Naked_nativeints -> Array_kind Naked_nativeints @@ -198,6 +195,7 @@ module Array_set_kind = struct | Values of P.Init_or_assign.t | Naked_floats | Naked_floats_to_be_unboxed + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints @@ -213,6 +211,7 @@ let convert_intermediate_array_set_kind (kind : Array_set_kind.t) : | Immediates -> Immediates | Values init_or_assign -> Values init_or_assign | Naked_floats | Naked_floats_to_be_unboxed -> Naked_floats + | Naked_float32s -> Naked_float32s | Naked_int32s -> Naked_int32s | Naked_int64s -> Naked_int64s | Naked_nativeints -> Naked_nativeints @@ -231,9 +230,7 @@ let convert_array_set_kind (kind : L.array_set_kind) : converted_array_set_kind | Pintarray_set -> Array_set_kind Immediates | Pfloatarray_set -> Array_set_kind Naked_floats_to_be_unboxed | Punboxedfloatarray_set Pfloat64 -> Array_set_kind Naked_floats - | Punboxedfloatarray_set Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Punboxedfloatarray_set Pfloat32 -> Array_set_kind Naked_float32s | Punboxedintarray_set Pint32 -> Array_set_kind Naked_int32s | Punboxedintarray_set Pint64 -> Array_set_kind Naked_int64s | Punboxedintarray_set Pnativeint -> Array_set_kind Naked_nativeints @@ -246,6 +243,7 @@ let convert_array_set_kind_for_length array_set_kind : P.Array_kind_for_length.t | Array_set_kind Immediates -> Array_kind Immediates | Array_set_kind (Naked_floats | Naked_floats_to_be_unboxed) -> Array_kind Naked_floats + | Array_set_kind Naked_float32s -> Array_kind Naked_float32s | Array_set_kind Naked_int32s -> Array_kind Naked_int32s | Array_set_kind Naked_int64s -> Array_kind Naked_int64s | Array_set_kind Naked_nativeints -> Array_kind Naked_nativeints @@ -265,8 +263,7 @@ let convert_array_kind_to_duplicate_array_kind (kind : L.array_kind) : | Pfloatarray | Punboxedfloatarray Pfloat64 -> Duplicate_array_kind (Naked_floats { length = None }) | Punboxedfloatarray Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false + Duplicate_array_kind (Naked_float32s { length = None }) | Punboxedintarray Pint32 -> Duplicate_array_kind (Naked_int32s { length = None }) | Punboxedintarray Pint64 -> @@ -596,7 +593,7 @@ let array_vector_access_validity_condition array ~size_int let width_in_scalars = match array_kind with | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 - | Naked_int32s -> 4 + | Naked_int32s | Naked_float32s -> 4 | Values -> Misc.fatal_error "Attempted to load/store a SIMD vector from/to a value array." @@ -820,6 +817,8 @@ let array_load_unsafe ~array ~index (array_ref_kind : Array_ref_kind.t) ~current_region | Naked_floats -> Binary (Array_load (Naked_floats, Scalar, Mutable), array, index) + | Naked_float32s -> + Binary (Array_load (Naked_float32s, Scalar, Mutable), array, index) | Naked_int32s -> Binary (Array_load (Naked_int32s, Scalar, Mutable), array, index) | Naked_int64s -> @@ -831,8 +830,8 @@ let array_set_unsafe ~array ~index ~new_value (array_set_kind : Array_set_kind.t) : H.expr_primitive = let new_value = match array_set_kind with - | Immediates | Values _ | Naked_floats | Naked_int32s | Naked_int64s - | Naked_nativeints -> + | Immediates | Values _ | Naked_floats | Naked_float32s | Naked_int32s + | Naked_int64s | Naked_nativeints -> new_value | Naked_floats_to_be_unboxed -> unbox_float new_value in diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index bbdc83e0d3b..efa8ac4c9c9 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -340,6 +340,7 @@ module With_subkind = struct | Immediate_array | Value_array | Generic_array + | Unboxed_float32_array | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array @@ -412,8 +413,8 @@ module With_subkind = struct | ( ( Anything | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _ | Float_block _ | Float_array | Immediate_array | Value_array - | Generic_array | Unboxed_int32_array | Unboxed_int64_array - | Unboxed_nativeint_array ), + | Generic_array | Unboxed_float32_array | Unboxed_int32_array + | Unboxed_int64_array | Unboxed_nativeint_array ), _ ) -> false @@ -466,6 +467,9 @@ module With_subkind = struct Format.fprintf ppf "%t=Value_array%t" colour Flambda_colours.pop | Generic_array -> Format.fprintf ppf "%t=Generic_array%t" colour Flambda_colours.pop + | Unboxed_float32_array -> + Format.fprintf ppf "%t=Unboxed_float32_array%t" colour + Flambda_colours.pop | Unboxed_int32_array -> Format.fprintf ppf "%t=Unboxed_int32_array%t" colour Flambda_colours.pop @@ -497,8 +501,8 @@ module With_subkind = struct | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _ | Float_block _ | Float_array | Immediate_array | Value_array - | Generic_array | Unboxed_int32_array | Unboxed_int64_array - | Unboxed_nativeint_array -> + | Generic_array | Unboxed_float32_array | Unboxed_int32_array + | Unboxed_int64_array | Unboxed_nativeint_array -> Misc.fatal_errorf "Subkind %a is not valid for kind %a" Subkind.print subkind print kind)); { kind; subkind } @@ -555,6 +559,8 @@ module With_subkind = struct let generic_array = create value Generic_array + let unboxed_float32_array = create value Unboxed_float32_array + let unboxed_int32_array = create value Unboxed_int32_array let unboxed_int64_array = create value Unboxed_int64_array @@ -661,9 +667,7 @@ module With_subkind = struct | Parrayval Paddrarray -> value_array | Parrayval Pgenarray -> generic_array | Parrayval (Punboxedfloatarray Pfloat64) -> float_array - | Parrayval (Punboxedfloatarray Pfloat32) -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Parrayval (Punboxedfloatarray Pfloat32) -> unboxed_float32_array | Parrayval (Punboxedintarray Pint32) -> unboxed_int32_array | Parrayval (Punboxedintarray Pint64) -> unboxed_int64_array | Parrayval (Punboxedintarray Pnativeint) -> unboxed_nativeint_array @@ -695,8 +699,8 @@ module With_subkind = struct ( Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _ | Float_block _ | Float_array | Immediate_array | Value_array - | Generic_array | Unboxed_int32_array | Unboxed_int64_array - | Unboxed_nativeint_array ) ) -> + | Generic_array | Unboxed_float32_array | Unboxed_int32_array + | Unboxed_int64_array | Unboxed_nativeint_array ) ) -> assert false (* see [create] *) @@ -716,8 +720,8 @@ module With_subkind = struct | Anything -> false | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Tagged_immediate | Variant _ | Float_block _ | Float_array - | Immediate_array | Value_array | Generic_array | Unboxed_int32_array - | Unboxed_int64_array | Unboxed_nativeint_array -> + | Immediate_array | Value_array | Generic_array | Unboxed_float32_array + | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array -> true let erase_subkind (t : t) : t = { t with subkind = Anything } diff --git a/middle_end/flambda2/kinds/flambda_kind.mli b/middle_end/flambda2/kinds/flambda_kind.mli index 8f529e89ec5..0097a1fd6e4 100644 --- a/middle_end/flambda2/kinds/flambda_kind.mli +++ b/middle_end/flambda2/kinds/flambda_kind.mli @@ -157,6 +157,7 @@ module With_subkind : sig | Immediate_array | Value_array | Generic_array + | Unboxed_float32_array | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array diff --git a/middle_end/flambda2/parser/fexpr.ml b/middle_end/flambda2/parser/fexpr.ml index a79eaaf8158..53961dab701 100644 --- a/middle_end/flambda2/parser/fexpr.ml +++ b/middle_end/flambda2/parser/fexpr.ml @@ -180,6 +180,7 @@ type array_kind = Flambda_primitive.Array_kind.t = | Immediates | Values | Naked_floats + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 6f9bd252f7d..f62b1ff8fc1 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -462,9 +462,10 @@ let array_set_kind_of_array_kind : | Immediates, _ -> Immediates | Naked_floats, _ -> Naked_floats | Values, ia -> Values (init_or_assign env ia) - | (Naked_int32s | Naked_int64s | Naked_nativeints), _ -> + | (Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints), _ -> Misc.fatal_error - "fexpr support for unboxed int32/64/nativeint arrays not yet implemented" + "fexpr support for unboxed float32/int32/64/nativeint arrays not yet \ + implemented" let ternop env (ternop : Fexpr.ternop) : Flambda_primitive.ternary_primitive = match ternop with diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index f5eb7d87559..2f94df9ec0c 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -437,9 +437,11 @@ let rec subkind (k : Flambda_kind.With_subkind.Subkind.t) : Fexpr.subkind = | Value_array -> Value_array | Generic_array -> Generic_array | Float_block { num_fields } -> Float_block { num_fields } - | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array -> + | Unboxed_float32_array | Unboxed_int32_array | Unboxed_int64_array + | Unboxed_nativeint_array -> Misc.fatal_error - "fexpr support for unboxed int32/64/nativeint arrays not yet implemented" + "fexpr support for unboxed float32/int32/64/nativeint arrays not yet \ + implemented" and variant_subkind consts non_consts : Fexpr.subkind = let consts = @@ -709,10 +711,11 @@ let static_const env (sc : Static_const.t) : Fexpr.static_data = Immutable_float_array (List.map (or_variable float env) elements) | Immutable_value_array elements -> Immutable_value_array (List.map (field_of_block env) elements) - | Immutable_int32_array _ | Immutable_int64_array _ - | Immutable_nativeint_array _ -> + | Immutable_float32_array _ | Immutable_int32_array _ + | Immutable_int64_array _ | Immutable_nativeint_array _ -> Misc.fatal_error - "fexpr support for unboxed int32/64/nativeint arrays not yet implemented" + "fexpr support for unboxed float32/int32/64/nativeint arrays not yet \ + implemented" | Empty_array array_kind -> Empty_array array_kind | Mutable_string { initial_value } -> Mutable_string { initial_value } | Immutable_string s -> Immutable_string s diff --git a/middle_end/flambda2/parser/print_fexpr.ml b/middle_end/flambda2/parser/print_fexpr.ml index 05001201dee..02f2714eab5 100644 --- a/middle_end/flambda2/parser/print_fexpr.ml +++ b/middle_end/flambda2/parser/print_fexpr.ml @@ -289,6 +289,7 @@ let array_kind ~space ppf (ak : array_kind) = | Values -> None | Immediates -> Some "imm" | Naked_floats -> Some "float" + | Naked_float32s -> Some "float32" | Naked_int32s -> Some "int32" | Naked_int64s -> Some "int64" | Naked_nativeints -> Some "nativeint" diff --git a/middle_end/flambda2/simplify/lifting/reification.ml b/middle_end/flambda2/simplify/lifting/reification.ml index 4adf1795fcd..7cd42881b82 100644 --- a/middle_end/flambda2/simplify/lifting/reification.ml +++ b/middle_end/flambda2/simplify/lifting/reification.ml @@ -57,9 +57,9 @@ let create_static_const dacc dbg (to_lift : T.to_lift) : RSC.t = | Boxed_int64 i -> RSC.create_boxed_int64 art (Const i) | Boxed_nativeint i -> RSC.create_boxed_nativeint art (Const i) | Boxed_vec128 v -> RSC.create_boxed_vec128 art (Const v) - | Immutable_float32_array { fields = _ } -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Immutable_float32_array { fields } -> + let fields = List.map (fun f -> Or_variable.Const f) fields in + RSC.create_immutable_float32_array art fields | Immutable_float_array { fields } -> let fields = List.map (fun f -> Or_variable.Const f) fields in RSC.create_immutable_float_array art fields diff --git a/middle_end/flambda2/simplify/rebuilt_static_const.ml b/middle_end/flambda2/simplify/rebuilt_static_const.ml index d0043300271..154703a6252 100644 --- a/middle_end/flambda2/simplify/rebuilt_static_const.ml +++ b/middle_end/flambda2/simplify/rebuilt_static_const.ml @@ -170,6 +170,9 @@ let create_immutable_naked_number_array builder are_rebuilding fields = let create_immutable_float_array = create_immutable_naked_number_array SC.immutable_float_array +let create_immutable_float32_array = + create_immutable_naked_number_array SC.immutable_float32_array + let create_immutable_int32_array = create_immutable_naked_number_array SC.immutable_int32_array @@ -224,9 +227,10 @@ let map_set_of_closures t ~f = | Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ | Immutable_float_array _ - | Immutable_int32_array _ | Immutable_int64_array _ - | Immutable_nativeint_array _ | Immutable_value_array _ | Empty_array _ - | Mutable_string _ | Immutable_string _ -> + | Immutable_float32_array _ | Immutable_int32_array _ + | Immutable_int64_array _ | Immutable_nativeint_array _ + | Immutable_value_array _ | Empty_array _ | Mutable_string _ + | Immutable_string _ -> t)) | Block_not_rebuilt _ | Set_of_closures_not_rebuilt _ | Code_not_rebuilt _ -> t diff --git a/middle_end/flambda2/simplify/rebuilt_static_const.mli b/middle_end/flambda2/simplify/rebuilt_static_const.mli index 8e4448ca9e8..f78af9006cd 100644 --- a/middle_end/flambda2/simplify/rebuilt_static_const.mli +++ b/middle_end/flambda2/simplify/rebuilt_static_const.mli @@ -77,6 +77,11 @@ val create_immutable_float_array : Numeric_types.Float_by_bit_pattern.t Or_variable.t list -> t +val create_immutable_float32_array : + Are_rebuilding_terms.t -> + Numeric_types.Float32_by_bit_pattern.t Or_variable.t list -> + t + val create_immutable_int32_array : Are_rebuilding_terms.t -> Int32.t Or_variable.t list -> t diff --git a/middle_end/flambda2/simplify/simplify_binary_primitive.ml b/middle_end/flambda2/simplify/simplify_binary_primitive.ml index 011345d5a94..3799cc832eb 100644 --- a/middle_end/flambda2/simplify/simplify_binary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_binary_primitive.ml @@ -1129,6 +1129,10 @@ let simplify_binary_primitive0 dacc original_prim (prim : P.binary_primitive) | Naked_nativeint -> Binary_int_comp_nativeint.simplify op) | Float_arith (Float64, op) -> Binary_float_arith.simplify op | Float_comp (Float64, op) -> Binary_float_comp.simplify op + (* Note: despite the fact that all float32s are representable as float64s, + float32 arithmetic operations need to be performed in 32-bit precision to + preserve rounding behavior. Such 32-bit operations are implemented by + flambda2_floats. *) | Float_arith (Float32, op) -> Binary_float32_arith.simplify op | Float_comp (Float32, op) -> Binary_float32_comp.simplify op | Phys_equal op -> simplify_phys_equal op diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index 5fade27386d..fc32199e095 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -353,6 +353,7 @@ let specialise_array_kind dacc (array_kind : P.Array_kind.t) ~array_ty : in match array_kind with | Naked_floats -> for_naked_number Naked_float + | Naked_float32s -> for_naked_number Naked_float32 | Naked_int32s -> for_naked_number Naked_int32 | Naked_int64s -> for_naked_number Naked_int64 | Naked_nativeints -> for_naked_number Naked_nativeint diff --git a/middle_end/flambda2/simplify/simplify_static_const.ml b/middle_end/flambda2/simplify/simplify_static_const.ml index 51348c093e3..ae42bdffec2 100644 --- a/middle_end/flambda2/simplify/simplify_static_const.ml +++ b/middle_end/flambda2/simplify/simplify_static_const.ml @@ -180,6 +180,9 @@ let simplify_static_const_of_kind_value dacc (static_const : Static_const.t) | Immutable_float_array fields -> rebuild_naked_number_array dacc ~bind_result_sym KS.naked_float T.this_naked_float RSC.create_immutable_float_array ~fields + | Immutable_float32_array fields -> + rebuild_naked_number_array dacc ~bind_result_sym KS.naked_float32 + T.this_naked_float32 RSC.create_immutable_float32_array ~fields | Immutable_int32_array fields -> rebuild_naked_number_array dacc ~bind_result_sym KS.naked_int32 T.this_naked_int32 RSC.create_immutable_int32_array ~fields diff --git a/middle_end/flambda2/simplify/simplify_ternary_primitive.ml b/middle_end/flambda2/simplify/simplify_ternary_primitive.ml index 0d29ba64b17..6043533b052 100644 --- a/middle_end/flambda2/simplify/simplify_ternary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_ternary_primitive.ml @@ -44,13 +44,15 @@ let simplify_array_set (array_set_kind : P.Array_set_kind.t) | Immediates (* We don't expect specialisation regressions from Immediates to Values. *) - | Naked_floats | Naked_int32s | Naked_int64s | Naked_nativeints -> + | Naked_floats | Naked_float32s | Naked_int32s | Naked_int64s + | Naked_nativeints -> Misc.fatal_errorf "Didn't expect array specialisation to yield array kind %a from \ array set kind %a:@ %a" P.Array_kind.print array_kind P.Array_set_kind.print array_set_kind Named.print original_term) | Naked_floats -> Naked_floats + | Naked_float32s -> Naked_float32s | Naked_int32s -> Naked_int32s | Naked_int64s -> Naked_int64s | Naked_nativeints -> Naked_nativeints diff --git a/middle_end/flambda2/terms/code_size.ml b/middle_end/flambda2/terms/code_size.ml index 7b83569726e..d500f9d237c 100644 --- a/middle_end/flambda2/terms/code_size.ml +++ b/middle_end/flambda2/terms/code_size.ml @@ -147,7 +147,7 @@ let array_load (kind : Flambda_primitive.Array_kind.t) = match kind with | Immediates -> 1 (* cadda + load *) | Naked_floats | Values -> 1 - | Naked_int32s | Naked_int64s | Naked_nativeints -> + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints -> (* more computation is needed because of the representation using a custom block *) 2 @@ -175,7 +175,8 @@ let array_set (kind : Flambda_primitive.Array_set_kind.t) = | Values (Assignment Heap) -> does_not_need_caml_c_call_extcall_size | Values (Assignment Local | Initialization) -> 1 | Immediates | Naked_floats -> 1 - | Naked_int32s | Naked_int64s | Naked_nativeints -> 2 (* as above *) + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints -> + 2 (* as above *) let string_or_bigstring_load kind width = let start_address_load = @@ -352,7 +353,7 @@ let unary_prim_size prim = (Immediates | Values | Naked_floats | Naked_int64s | Naked_nativeints) -> array_length_size - | Array_kind Naked_int32s -> + | Array_kind (Naked_int32s | Naked_float32s) -> (* There is a dynamic check here to see if the array has an odd or even number of elements *) array_length_size + 2 (* compare + load *) diff --git a/middle_end/flambda2/terms/flambda.ml b/middle_end/flambda2/terms/flambda.ml index 35ba62fa99d..a494bb41fb1 100644 --- a/middle_end/flambda2/terms/flambda.ml +++ b/middle_end/flambda2/terms/flambda.ml @@ -1426,9 +1426,10 @@ module Named = struct ( Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ | Immutable_float_array _ - | Mutable_string _ | Immutable_string _ | Empty_array _ - | Immutable_value_array _ | Immutable_int32_array _ - | Immutable_int64_array _ | Immutable_nativeint_array _ ) -> + | Immutable_float32_array _ | Mutable_string _ + | Immutable_string _ | Empty_array _ | Immutable_value_array _ + | Immutable_int32_array _ | Immutable_int64_array _ + | Immutable_nativeint_array _ ) -> acc) init end diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml index 77f42371577..58dafa568ea 100644 --- a/middle_end/flambda2/terms/flambda_primitive.ml +++ b/middle_end/flambda2/terms/flambda_primitive.ml @@ -209,6 +209,7 @@ module Array_kind = struct | Immediates | Values | Naked_floats + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints @@ -217,6 +218,7 @@ module Array_kind = struct match t with | Immediates -> Format.pp_print_string ppf "Immediates" | Naked_floats -> Format.pp_print_string ppf "Naked_floats" + | Naked_float32s -> Format.pp_print_string ppf "Naked_float32s" | Values -> Format.pp_print_string ppf "Values" | Naked_int32s -> Format.pp_print_string ppf "Naked_int32s" | Naked_int64s -> Format.pp_print_string ppf "Naked_int64s" @@ -228,6 +230,7 @@ module Array_kind = struct match t with | Immediates | Values -> K.value | Naked_floats -> K.naked_float + | Naked_float32s -> K.naked_float32 | Naked_int32s -> K.naked_int32 | Naked_int64s -> K.naked_int64 | Naked_nativeints -> K.naked_nativeint @@ -237,6 +240,7 @@ module Array_kind = struct | Immediates -> Flambda_kind.With_subkind.tagged_immediate | Values -> Flambda_kind.With_subkind.any_value | Naked_floats -> Flambda_kind.With_subkind.naked_float + | Naked_float32s -> Flambda_kind.With_subkind.naked_float32 | Naked_int32s -> Flambda_kind.With_subkind.naked_int32 | Naked_int64s -> Flambda_kind.With_subkind.naked_int64 | Naked_nativeints -> Flambda_kind.With_subkind.naked_nativeint @@ -244,6 +248,7 @@ module Array_kind = struct let for_empty_array t : Empty_array_kind.t = match t with | Immediates | Values | Naked_floats -> Values_or_immediates_or_naked_floats + | Naked_float32s -> Naked_float32s | Naked_int32s -> Naked_int32s | Naked_int64s -> Naked_int64s | Naked_nativeints -> Naked_nativeints @@ -254,6 +259,7 @@ module Array_set_kind = struct | Immediates | Values of Init_or_assign.t | Naked_floats + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints @@ -265,6 +271,7 @@ module Array_set_kind = struct Format.fprintf ppf "@[(Values %a)@]" Init_or_assign.print init_or_assign | Naked_floats -> Format.fprintf ppf "Naked_floats" + | Naked_float32s -> Format.pp_print_string ppf "Naked_float32s" | Naked_int32s -> Format.pp_print_string ppf "Naked_int32s" | Naked_int64s -> Format.pp_print_string ppf "Naked_int64s" | Naked_nativeints -> Format.pp_print_string ppf "Naked_nativeints" @@ -275,6 +282,7 @@ module Array_set_kind = struct match t with | Immediates | Values _ -> K.value | Naked_floats -> K.naked_float + | Naked_float32s -> K.naked_float32 | Naked_int32s -> K.naked_int32 | Naked_int64s -> K.naked_int64 | Naked_nativeints -> K.naked_nativeint @@ -284,6 +292,7 @@ module Array_set_kind = struct | Immediates -> Immediates | Values _ -> Values | Naked_floats -> Naked_floats + | Naked_float32s -> Naked_float32s | Naked_int32s -> Naked_int32s | Naked_int64s -> Naked_int64s | Naked_nativeints -> Naked_nativeints @@ -291,8 +300,8 @@ module Array_set_kind = struct let init_or_assign t : Init_or_assign.t = match t with | Values ia -> ia - | Immediates | Naked_floats | Naked_int32s | Naked_int64s | Naked_nativeints - -> + | Immediates | Naked_floats | Naked_float32s | Naked_int32s | Naked_int64s + | Naked_nativeints -> Assignment Alloc_mode.For_assignments.heap let element_kind t = @@ -300,6 +309,7 @@ module Array_set_kind = struct | Immediates -> Flambda_kind.With_subkind.tagged_immediate | Values _ -> Flambda_kind.With_subkind.any_value | Naked_floats -> Flambda_kind.With_subkind.naked_float + | Naked_float32s -> Flambda_kind.With_subkind.naked_float32 | Naked_int32s -> Flambda_kind.With_subkind.naked_int32 | Naked_int64s -> Flambda_kind.With_subkind.naked_int64 | Naked_nativeints -> Flambda_kind.With_subkind.naked_nativeint @@ -373,6 +383,7 @@ module Duplicate_array_kind = struct | Immediates | Values | Naked_floats of { length : Targetint_31_63.t option } + | Naked_float32s of { length : Targetint_31_63.t option } | Naked_int32s of { length : Targetint_31_63.t option } | Naked_int64s of { length : Targetint_31_63.t option } | Naked_nativeints of { length : Targetint_31_63.t option } @@ -387,6 +398,12 @@ module Duplicate_array_kind = struct @[(length@ %a)@]\ )@]" (Misc.Stdlib.Option.print Targetint_31_63.print) length + | Naked_float32s { length; } -> + Format.fprintf ppf + "@[(Naked_float32s@ \ + @[(length@ %a)@]\ + )@]" + (Misc.Stdlib.Option.print Targetint_31_63.print) length | Naked_int32s { length; } -> Format.fprintf ppf "@[(Naked_int32s@ \ @@ -411,6 +428,9 @@ module Duplicate_array_kind = struct | Immediates, Immediates | Values, Values -> 0 | Naked_floats { length = length1 }, Naked_floats { length = length2 } -> Option.compare Targetint_31_63.compare length1 length2 + | Naked_float32s { length = length1 }, Naked_float32s { length = length2 } + -> + Option.compare Targetint_31_63.compare length1 length2 | Naked_int32s { length = length1 }, Naked_int32s { length = length2 } -> Option.compare Targetint_31_63.compare length1 length2 | Naked_int64s { length = length1 }, Naked_int64s { length = length2 } -> @@ -424,6 +444,8 @@ module Duplicate_array_kind = struct | _, Values -> 1 | Naked_floats _, _ -> -1 | _, Naked_floats _ -> 1 + | Naked_float32s _, _ -> -1 + | _, Naked_float32s _ -> 1 | Naked_int32s _, _ -> -1 | _, Naked_int32s _ -> 1 | Naked_int64s _, _ -> -1 @@ -603,8 +625,8 @@ let reading_from_an_array (array_kind : Array_kind.t) (mutable_or_immutable : Mutability.t) = let effects : Effects.t = match array_kind with - | Immediates | Values | Naked_floats | Naked_int32s | Naked_int64s - | Naked_nativeints -> + | Immediates | Values | Naked_floats | Naked_float32s | Naked_int32s + | Naked_int64s | Naked_nativeints -> No_effects in let coeffects = diff --git a/middle_end/flambda2/terms/flambda_primitive.mli b/middle_end/flambda2/terms/flambda_primitive.mli index 9f697d4f455..727bd4a2c88 100644 --- a/middle_end/flambda2/terms/flambda_primitive.mli +++ b/middle_end/flambda2/terms/flambda_primitive.mli @@ -43,6 +43,7 @@ module Array_kind : sig | Naked_floats (** An array consisting of naked floats, represented using [Double_array_tag]. *) + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints @@ -120,6 +121,7 @@ module Array_set_kind : sig | Naked_floats (** An array consisting of naked floats, represented using [Double_array_tag]. *) + | Naked_float32s | Naked_int32s | Naked_int64s | Naked_nativeints @@ -158,6 +160,7 @@ module Duplicate_array_kind : sig | Immediates | Values | Naked_floats of { length : Targetint_31_63.t option } + | Naked_float32s of { length : Targetint_31_63.t option } | Naked_int32s of { length : Targetint_31_63.t option } | Naked_int64s of { length : Targetint_31_63.t option } | Naked_nativeints of { length : Targetint_31_63.t option } diff --git a/middle_end/flambda2/terms/static_const.ml b/middle_end/flambda2/terms/static_const.ml index 89b7ea82b87..ba90d9205d6 100644 --- a/middle_end/flambda2/terms/static_const.ml +++ b/middle_end/flambda2/terms/static_const.ml @@ -29,6 +29,8 @@ type t = Numeric_types.Float_by_bit_pattern.t Or_variable.t list | Immutable_float_array of Numeric_types.Float_by_bit_pattern.t Or_variable.t list + | Immutable_float32_array of + Numeric_types.Float32_by_bit_pattern.t Or_variable.t list | Immutable_int32_array of Int32.t Or_variable.t list | Immutable_int64_array of Int64.t Or_variable.t list | Immutable_nativeint_array of Targetint_32_64.t Or_variable.t list @@ -60,6 +62,11 @@ let immutable_float_array fields = | [] -> Empty_array Values_or_immediates_or_naked_floats | _ :: _ -> Immutable_float_array fields +let immutable_float32_array fields = + match fields with + | [] -> Empty_array Naked_float32s + | _ :: _ -> Immutable_float32_array fields + let immutable_int64_array fields = match fields with | [] -> Empty_array Naked_int64s @@ -150,6 +157,14 @@ let [@ocamlformat "disable"] print ppf t = ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") (Or_variable.print Numeric_types.Float_by_bit_pattern.print)) fields + | Immutable_float32_array fields -> + fprintf ppf "@[(%tImmutable_float32_array%t@ @[[| %a |]@])@]" + Flambda_colours.static_part + Flambda_colours.pop + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.pp_print_string ppf "@; ") + (Or_variable.print Numeric_types.Float32_by_bit_pattern.print)) + fields | Immutable_int32_array fields -> fprintf ppf "@[(%tImmutable_int32_array%t@ @[[| %a |]@])@]" Flambda_colours.static_part @@ -238,6 +253,10 @@ include Container_types.Make (struct Misc.Stdlib.List.compare (Or_variable.compare Numeric_types.Float_by_bit_pattern.compare) fields1 fields2 + | Immutable_float32_array fields1, Immutable_float32_array fields2 -> + Misc.Stdlib.List.compare + (Or_variable.compare Numeric_types.Float32_by_bit_pattern.compare) + fields1 fields2 | Immutable_int64_array fields1, Immutable_int64_array fields2 -> Misc.Stdlib.List.compare (Or_variable.compare Int64.compare) @@ -278,6 +297,8 @@ include Container_types.Make (struct | _, Immutable_float_block _ -> 1 | Immutable_float_array _, _ -> -1 | _, Immutable_float_array _ -> 1 + | Immutable_float32_array _, _ -> -1 + | _, Immutable_float32_array _ -> 1 | Immutable_int64_array _, _ -> -1 | _, Immutable_int64_array _ -> 1 | Immutable_int32_array _, _ -> -1 @@ -324,6 +345,7 @@ let free_names t = Name_occurrences.empty | Immutable_float_block fields | Immutable_float_array fields -> free_names_for_numeric_fields fields + | Immutable_float32_array fields -> free_names_for_numeric_fields fields | Immutable_int32_array fields -> free_names_for_numeric_fields fields | Immutable_int64_array fields -> free_names_for_numeric_fields fields | Immutable_nativeint_array fields -> free_names_for_numeric_fields fields @@ -379,6 +401,9 @@ let apply_renaming t renaming = | Immutable_float_array fields -> let fields' = apply_renaming_number_array_fields renaming fields in if fields' == fields then t else Immutable_float_array fields' + | Immutable_float32_array fields -> + let fields' = apply_renaming_number_array_fields renaming fields in + if fields' == fields then t else Immutable_float32_array fields' | Immutable_int32_array fields -> let fields' = apply_renaming_number_array_fields renaming fields in if fields' == fields then t else Immutable_int32_array fields' @@ -433,6 +458,7 @@ let ids_for_export t = Ids_for_export.empty | Immutable_float_block fields -> ids_for_export_number_array_fields fields | Immutable_float_array fields -> ids_for_export_number_array_fields fields + | Immutable_float32_array fields -> ids_for_export_number_array_fields fields | Immutable_int32_array fields -> ids_for_export_number_array_fields fields | Immutable_int64_array fields -> ids_for_export_number_array_fields fields | Immutable_nativeint_array fields -> @@ -444,7 +470,8 @@ let is_block t = match t with | Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ | Boxed_vec128 _ | Immutable_float_block _ - | Immutable_float_array _ | Immutable_int32_array _ | Immutable_int64_array _ + | Immutable_float_array _ | Immutable_float32_array _ + | Immutable_int32_array _ | Immutable_int64_array _ | Immutable_nativeint_array _ | Immutable_string _ | Mutable_string _ | Empty_array _ | Immutable_value_array _ -> true @@ -455,7 +482,8 @@ let is_set_of_closures t = | Set_of_closures _ -> true | Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ | Boxed_vec128 _ | Immutable_float_block _ - | Immutable_float_array _ | Immutable_int32_array _ | Immutable_int64_array _ + | Immutable_float_array _ | Immutable_float32_array _ + | Immutable_int32_array _ | Immutable_int64_array _ | Immutable_nativeint_array _ | Immutable_string _ | Mutable_string _ | Empty_array _ | Immutable_value_array _ -> false @@ -467,8 +495,8 @@ let can_share0 t = | Block (_, Immutable, _) | Set_of_closures _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ - | Immutable_float_array _ | Immutable_string _ | Empty_array _ - | Immutable_int32_array _ | Immutable_int64_array _ + | Immutable_float_array _ | Immutable_float32_array _ | Immutable_string _ + | Empty_array _ | Immutable_int32_array _ | Immutable_int64_array _ | Immutable_nativeint_array _ | Immutable_value_array _ -> true | Block (_, (Mutable | Immutable_unique), _) | Mutable_string _ -> false @@ -480,7 +508,8 @@ let must_be_set_of_closures t = | Set_of_closures set -> set | Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_nativeint _ | Boxed_vec128 _ | Immutable_float_block _ - | Immutable_float_array _ | Immutable_int32_array _ | Immutable_int64_array _ + | Immutable_float_array _ | Immutable_float32_array _ + | Immutable_int32_array _ | Immutable_int64_array _ | Immutable_nativeint_array _ | Empty_array _ | Immutable_value_array _ | Immutable_string _ | Mutable_string _ -> Misc.fatal_errorf "Not a set of closures:@ %a" print t @@ -508,18 +537,20 @@ let match_against_bound_static_pattern t (pat : Bound_static.Pattern.t) | ( ( Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ | Immutable_float_array _ - | Immutable_int32_array _ | Immutable_int64_array _ - | Immutable_nativeint_array _ | Immutable_value_array _ | Empty_array _ - | Immutable_string _ | Mutable_string _ ), + | Immutable_float32_array _ | Immutable_int32_array _ + | Immutable_int64_array _ | Immutable_nativeint_array _ + | Immutable_value_array _ | Empty_array _ | Immutable_string _ + | Mutable_string _ ), Block_like symbol ) -> block_like_callback symbol t | Set_of_closures _, (Block_like _ | Code _) | ( ( Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ | Immutable_float_array _ - | Immutable_int32_array _ | Immutable_int64_array _ - | Immutable_nativeint_array _ | Immutable_value_array _ | Empty_array _ - | Immutable_string _ | Mutable_string _ ), + | Immutable_float32_array _ | Immutable_int32_array _ + | Immutable_int64_array _ | Immutable_nativeint_array _ + | Immutable_value_array _ | Empty_array _ | Immutable_string _ + | Mutable_string _ ), (Set_of_closures _ | Code _) ) -> Misc.fatal_errorf "Mismatch on variety of [Static_const]:@ %a@ =@ %a" Bound_static.Pattern.print pat print t diff --git a/middle_end/flambda2/terms/static_const.mli b/middle_end/flambda2/terms/static_const.mli index b7be7170012..0ec407f4140 100644 --- a/middle_end/flambda2/terms/static_const.mli +++ b/middle_end/flambda2/terms/static_const.mli @@ -35,7 +35,8 @@ type t = private Numeric_types.Float_by_bit_pattern.t Or_variable.t list | Immutable_float_array of Numeric_types.Float_by_bit_pattern.t Or_variable.t list - (* CR mslater: (float32) unboxed arrays *) + | Immutable_float32_array of + Numeric_types.Float32_by_bit_pattern.t Or_variable.t list | Immutable_int32_array of Int32.t Or_variable.t list | Immutable_int64_array of Int64.t Or_variable.t list | Immutable_nativeint_array of Targetint_32_64.t Or_variable.t list @@ -81,6 +82,11 @@ val immutable_float_block : val immutable_float_array : Numeric_types.Float_by_bit_pattern.t Or_variable.t list -> t +(** This function can accept empty lists of fields; [Empty_array] will be + produced. *) +val immutable_float32_array : + Numeric_types.Float32_by_bit_pattern.t Or_variable.t list -> t + (** This function can accept empty lists of fields; [Empty_array] will be produced. *) val immutable_int32_array : Int32.t Or_variable.t list -> t diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 80b7e56815b..94f0354a1cf 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -150,6 +150,7 @@ let make_array ~dbg kind alloc_mode args = | Immediates | Values -> C.make_alloc ~mode dbg 0 args | Naked_floats -> C.make_float_alloc ~mode dbg (Tag.to_int Tag.double_array_tag) args + | Naked_float32s -> C.allocate_unboxed_float32_array ~elements:args mode dbg | Naked_int32s -> C.allocate_unboxed_int32_array ~elements:args mode dbg | Naked_int64s -> C.allocate_unboxed_int64_array ~elements:args mode dbg | Naked_nativeints -> @@ -169,6 +170,7 @@ let array_length ~dbg arr (kind : P.Array_kind.t) = width of floats is equal to the machine word width (see flambda2.ml). *) assert (C.wordsize_shift = C.numfloat_shift); C.arraylength Paddrarray arr dbg + | Naked_float32s -> C.unboxed_float32_array_length arr dbg | Naked_int32s -> C.unboxed_int32_array_length arr dbg | Naked_int64s | Naked_nativeints -> (* These need a special case as they are represented by custom blocks, even @@ -207,12 +209,13 @@ let array_load ~dbg (kind : P.Array_kind.t) C.unboxed_int64_or_nativeint_array_ref arr index dbg | Values, Scalar -> C.addr_array_ref arr index dbg | Naked_floats, Scalar -> C.unboxed_float_array_ref arr index dbg + | Naked_float32s, Scalar -> C.unboxed_float32_array_ref arr index dbg | Naked_int32s, Scalar -> C.unboxed_int32_array_ref arr index dbg | (Immediates | Naked_floats), Vec128 -> array_load_128 ~dbg ~element_width_log2:3 ~has_custom_ops:false arr index | (Naked_int64s | Naked_nativeints), Vec128 -> array_load_128 ~dbg ~element_width_log2:3 ~has_custom_ops:true arr index - | Naked_int32s, Vec128 -> + | (Naked_int32s | Naked_float32s), Vec128 -> array_load_128 ~dbg ~element_width_log2:2 ~has_custom_ops:true arr index | Values, Vec128 -> Misc.fatal_error "Attempted to load a SIMD vector from a value array." @@ -230,6 +233,8 @@ let array_set ~dbg (kind : P.Array_set_kind.t) | Immediates, Scalar -> C.int_array_set arr index new_value dbg | Values init, Scalar -> addr_array_store init ~arr ~index ~new_value dbg | Naked_floats, Scalar -> C.float_array_set arr index new_value dbg + | Naked_float32s, Scalar -> + C.unboxed_float32_array_set arr ~index ~new_value dbg | Naked_int32s, Scalar -> C.unboxed_int32_array_set arr ~index ~new_value dbg | (Naked_int64s | Naked_nativeints), Scalar -> @@ -240,7 +245,7 @@ let array_set ~dbg (kind : P.Array_set_kind.t) | (Naked_int64s | Naked_nativeints), Vec128 -> array_set_128 ~dbg ~element_width_log2:3 ~has_custom_ops:true arr index new_value - | Naked_int32s, Vec128 -> + | (Naked_int32s | Naked_float32s), Vec128 -> array_set_128 ~dbg ~element_width_log2:2 ~has_custom_ops:true arr index new_value | Values _, Vec128 -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index 0ce03d105f7..6eca29a4713 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -48,8 +48,9 @@ let machtype_of_kind (kind : Flambda_kind.With_subkind.t) = | Tagged_immediate -> Cmm.typ_int | Anything | Boxed_float32 | Boxed_float | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Variant _ | Float_block _ | Float_array - | Immediate_array | Unboxed_int32_array | Unboxed_int64_array - | Unboxed_nativeint_array | Value_array | Generic_array -> + | Immediate_array | Unboxed_float32_array | Unboxed_int32_array + | Unboxed_int64_array | Unboxed_nativeint_array | Value_array + | Generic_array -> Cmm.typ_val) | Naked_number Naked_float -> Cmm.typ_float | Naked_number Naked_float32 -> Cmm.typ_float32 @@ -66,8 +67,9 @@ let extended_machtype_of_kind (kind : Flambda_kind.With_subkind.t) = | Tagged_immediate -> Extended_machtype.typ_tagged_int | Anything | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Variant _ | Float_block _ | Float_array - | Immediate_array | Unboxed_int32_array | Unboxed_int64_array - | Unboxed_nativeint_array | Value_array | Generic_array -> + | Immediate_array | Unboxed_float32_array | Unboxed_int32_array + | Unboxed_int64_array | Unboxed_nativeint_array | Value_array + | Generic_array -> Extended_machtype.typ_val) | Naked_number Naked_float -> Extended_machtype.typ_float | Naked_number Naked_float32 -> Extended_machtype.typ_float32 @@ -85,8 +87,9 @@ let memory_chunk_of_kind (kind : Flambda_kind.With_subkind.t) : Cmm.memory_chunk | Tagged_immediate -> Word_int | Anything | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Variant _ | Float_block _ | Float_array - | Immediate_array | Unboxed_int32_array | Unboxed_int64_array - | Unboxed_nativeint_array | Value_array | Generic_array -> + | Immediate_array | Unboxed_float32_array | Unboxed_int32_array + | Unboxed_int64_array | Unboxed_nativeint_array | Value_array + | Generic_array -> Word_val) | Naked_number (Naked_int64 | Naked_nativeint | Naked_immediate) -> Word_int | Naked_number Naked_int32 -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_static.ml b/middle_end/flambda2/to_cmm/to_cmm_static.ml index 66feb52af95..0454b835ca3 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_static.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_static.ml @@ -58,36 +58,18 @@ type maybe_int32 = (* The index [i] is always in the units of the size of the integer concerned, not units of 64-bit words. *) -let rec static_unboxed_int_array_updates symb env res acc maybe_int32 i = - function +let rec static_unboxed_array_updates symb env res acc update_kind i = function | [] -> env, res, acc | sv :: r -> ( match (sv : _ Or_variable.t) with | Const _ -> - static_unboxed_int_array_updates symb env res acc maybe_int32 (i + 1) r - | Var (var, dbg) -> - let kind = - match maybe_int32 with - | Int64_or_nativeint -> UK.naked_int64s - | Int32 -> UK.naked_int32s - in - let env, res, acc = - C.make_update env res dbg kind ~symbol:(C.symbol ~dbg symb) var ~index:i - ~prev_updates:acc - in - static_unboxed_int_array_updates symb env res acc maybe_int32 (i + 1) r) - -let rec static_float_array_updates symb env res acc i = function - | [] -> env, res, acc - | sv :: r -> ( - match (sv : _ Or_variable.t) with - | Const _ -> static_float_array_updates symb env res acc (i + 1) r + static_unboxed_array_updates symb env res acc update_kind (i + 1) r | Var (var, dbg) -> let env, res, acc = - C.make_update env res dbg UK.naked_floats ~symbol:(C.symbol ~dbg symb) - var ~index:i ~prev_updates:acc + C.make_update env res dbg update_kind ~symbol:(C.symbol ~dbg symb) var + ~index:i ~prev_updates:acc in - static_float_array_updates symb env res acc (i + 1) r) + static_unboxed_array_updates symb env res acc update_kind (i + 1) r) let static_boxed_number ~kind ~env ~symbol ~default ~emit ~transl ~structured v res updates = @@ -134,12 +116,12 @@ let preallocate_set_of_closures (res, updates, env) ~closure_symbols let res = R.set_data res data in res, updates, env -let immutable_unboxed_int_array_payload update_kind num_fields ~elts ~to_int64 = +let immutable_unboxed_int_array_payload maybe_int32 num_fields ~elts ~to_int64 = let int64_of_elts = List.map (Or_variable.value_map ~default:0L ~f:to_int64) elts in let packed_int64s = - match update_kind with + match maybe_int32 with | Int32 -> let rec aux acc = function | [] -> List.rev acc @@ -154,14 +136,14 @@ let immutable_unboxed_int_array_payload update_kind num_fields ~elts ~to_int64 = assert (List.length packed_int64s = num_fields); List.map (fun i -> Cmm.Cint (Int64.to_nativeint i)) packed_int64s -let immutable_unboxed_int_array env res updates update_kind ~symbol ~elts +let immutable_unboxed_int_array env res updates maybe_int32 ~symbol ~elts ~to_int64 ~custom_ops_symbol = let sym = R.symbol res symbol in let num_elts = List.length elts in - let num_fields = - match update_kind with - | Int32 -> (1 + num_elts) / 2 - | Int64_or_nativeint -> num_elts + let num_fields, update_kind = + match maybe_int32 with + | Int32 -> (1 + num_elts) / 2, UK.naked_int32s + | Int64_or_nativeint -> num_elts, UK.naked_int64s in let header = C.black_custom_header @@ -175,12 +157,49 @@ let immutable_unboxed_int_array env res updates update_kind ~symbol ~elts | Some sym_off -> C.symbol_offset (Cmm.global_symbol sym_base) sym_off in address - :: immutable_unboxed_int_array_payload update_kind num_fields ~elts + :: immutable_unboxed_int_array_payload maybe_int32 num_fields ~elts ~to_int64 in let block = C.emit_block sym header static_fields in let env, res, updates = - static_unboxed_int_array_updates sym env res updates update_kind 0 elts + static_unboxed_array_updates sym env res updates update_kind 0 elts + in + env, R.set_data res block, updates + +let immutable_unboxed_float32_array env res updates ~symbol ~elts = + let sym = R.symbol res symbol in + let num_elts = List.length elts in + let num_fields = (1 + num_elts) / 2 in + let header = + C.black_custom_header + ~size:(1 (* for the custom_operations pointer *) + num_fields) + in + let payload = + (* If the array has odd length, the last 32 bits are implicitly initialized + to zero because the array is a static block. *) + List.map + (Or_variable.value_map ~default:(Cmm.Csingle 0.0) ~f:(fun f -> + (* All float32s are valid float64s, so round tripping through float + in Csingle will result in the same value (up to NaN bit + patterns). *) + Cmm.Csingle (Numeric_types.Float32_by_bit_pattern.to_float f))) + elts + in + let static_fields = + let sym_base = "caml_unboxed_float32_array_ops" in + let address = + match num_elts mod 2 = 0 with + | true -> C.symbol_address (Cmm.global_symbol sym_base) + | false -> + C.symbol_offset + (Cmm.global_symbol sym_base) + Config.custom_ops_struct_size + in + address :: payload + in + let block = C.emit_block sym header static_fields in + let env, res, updates = + static_unboxed_array_updates sym env res updates UK.naked_float32s 0 elts in env, R.set_data res block, updates @@ -276,8 +295,12 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) let static_fields = List.map aux fields in let sym = R.symbol res s in let float_array = C.emit_float_array_constant sym static_fields in - let env, res, e = static_float_array_updates sym env res updates 0 fields in + let env, res, e = + static_unboxed_array_updates sym env res updates UK.naked_floats 0 fields + in env, R.update_data res float_array, e + | Block_like symbol, Immutable_float32_array elts -> + immutable_unboxed_float32_array env res updates ~symbol ~elts | Block_like symbol, Immutable_int32_array elts -> assert (Arch.size_int = 8); immutable_unboxed_int_array env res updates Int32 ~symbol ~elts @@ -311,9 +334,13 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) let header = C.black_block_header 0 0 in let block = C.emit_block sym header [] in env, R.set_data res block, updates - | Block_like _s, Empty_array Naked_float32s -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Block_like s, Empty_array Naked_float32s -> + let block = + C.emit_block (R.symbol res s) + (C.black_custom_header ~size:1) + [C.symbol_address (Cmm.global_symbol "caml_unboxed_float32_array_ops")] + in + env, R.set_data res block, updates | Block_like s, Empty_array Naked_int32s -> let block = C.emit_block (R.symbol res s) @@ -347,9 +374,10 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) ( Block _ | Boxed_float _ | Boxed_float32 _ | Boxed_int32 _ | Boxed_int64 _ | Boxed_vec128 _ | Boxed_nativeint _ | Immutable_float_block _ | Immutable_float_array _ - | Immutable_int32_array _ | Immutable_int64_array _ - | Immutable_nativeint_array _ | Immutable_value_array _ | Empty_array _ - | Mutable_string _ | Immutable_string _ ) ) -> + | Immutable_float32_array _ | Immutable_int32_array _ + | Immutable_int64_array _ | Immutable_nativeint_array _ + | Immutable_value_array _ | Empty_array _ | Mutable_string _ + | Immutable_string _ ) ) -> Misc.fatal_errorf "Block-like constants cannot be bound by [Code] or [Set_of_closures] \ bindings:@ %a" diff --git a/middle_end/flambda2/types/grammar/more_type_creators.ml b/middle_end/flambda2/types/grammar/more_type_creators.ml index 06cc5bb7d21..64989cd7644 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.ml +++ b/middle_end/flambda2/types/grammar/more_type_creators.ml @@ -343,6 +343,9 @@ let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) | Float_array -> TG.mutable_array ~element_kind:(Ok Flambda_kind.With_subkind.naked_float) ~length:any_tagged_immediate alloc_mode + | Unboxed_float32_array -> + TG.mutable_array ~element_kind:(Ok Flambda_kind.With_subkind.naked_float32) + ~length:any_tagged_immediate alloc_mode | Unboxed_int32_array -> TG.mutable_array ~element_kind:(Ok Flambda_kind.With_subkind.naked_int32) ~length:any_tagged_immediate alloc_mode diff --git a/middle_end/flambda2/types/provers.ml b/middle_end/flambda2/types/provers.ml index c85581a4828..090aa3bff7c 100644 --- a/middle_end/flambda2/types/provers.ml +++ b/middle_end/flambda2/types/provers.ml @@ -603,8 +603,8 @@ let prove_is_immediates_array env t : unit proof_of_property = | Tagged_immediate -> Proved () | Anything | Boxed_float | Boxed_float32 | Boxed_int32 | Boxed_int64 | Boxed_nativeint | Boxed_vec128 | Variant _ | Float_block _ | Float_array - | Immediate_array | Value_array | Generic_array | Unboxed_int32_array - | Unboxed_int64_array | Unboxed_nativeint_array -> + | Immediate_array | Value_array | Generic_array | Unboxed_float32_array + | Unboxed_int32_array | Unboxed_int64_array | Unboxed_nativeint_array -> Unknown) | Value (Ok diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index 0f8141e684a..d700b4573d9 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -454,55 +454,43 @@ let comp_primitive stack_info p sz args = [Parrayset{s,u}]). *) | Parrayrefs (Pgenarray_ref _, index_kind) | Parrayrefs ((Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ - | Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _), + | Punboxedfloatarray_ref (Pfloat64 | Pfloat32) | Punboxedintarray_ref _), (Punboxed_int_index _ as index_kind)) -> Kccall(array_primitive index_kind "caml_array_get", 2) | Parrayrefs ((Punboxedfloatarray_ref Pfloat64 | Pfloatarray_ref _), Ptagged_int_index) -> Kccall("caml_floatarray_get", 2) - | Parrayrefs ((Punboxedintarray_ref _ | Paddrarray_ref | Pintarray_ref), - Ptagged_int_index) -> + | Parrayrefs ((Punboxedfloatarray_ref Pfloat32 | Punboxedintarray_ref _ + | Paddrarray_ref | Pintarray_ref), Ptagged_int_index) -> Kccall("caml_array_get_addr", 2) - | Parrayrefs (Punboxedfloatarray_ref Pfloat32, _) -> - Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" - Printlambda.primitive p | Parraysets (Pgenarray_set _, index_kind) | Parraysets ((Paddrarray_set _ | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _), + | Punboxedfloatarray_set (Pfloat64 | Pfloat32) | Punboxedintarray_set _), (Punboxed_int_index _ as index_kind)) -> Kccall(array_primitive index_kind "caml_array_set", 3) | Parraysets ((Punboxedfloatarray_set Pfloat64 | Pfloatarray_set), Ptagged_int_index) -> Kccall("caml_floatarray_set", 3) - | Parraysets ((Punboxedintarray_set _ | Paddrarray_set _ | Pintarray_set), - Ptagged_int_index) -> + | Parraysets ((Punboxedfloatarray_set Pfloat32 | Punboxedintarray_set _ + | Paddrarray_set _ | Pintarray_set), Ptagged_int_index) -> Kccall("caml_array_set_addr", 3) - | Parraysets (Punboxedfloatarray_set Pfloat32, _) -> - Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" - Printlambda.primitive p | Parrayrefu (Pgenarray_ref _, index_kind) | Parrayrefu ((Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ - | Punboxedfloatarray_ref Pfloat64 | Punboxedintarray_ref _), + | Punboxedfloatarray_ref (Pfloat64 | Pfloat32) | Punboxedintarray_ref _), (Punboxed_int_index _ as index_kind)) -> Kccall(array_primitive index_kind "caml_array_unsafe_get", 2) | Parrayrefu ((Punboxedfloatarray_ref Pfloat64 | Pfloatarray_ref _), Ptagged_int_index) -> Kccall("caml_floatarray_unsafe_get", 2) - | Parrayrefu (Punboxedfloatarray_ref Pfloat32, _) -> - Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" - Printlambda.primitive p - | Parrayrefu ((Punboxedintarray_ref _ | Paddrarray_ref | Pintarray_ref), - Ptagged_int_index) -> Kgetvectitem + | Parrayrefu ((Punboxedfloatarray_ref Pfloat32 | Punboxedintarray_ref _ + | Paddrarray_ref | Pintarray_ref), Ptagged_int_index) -> Kgetvectitem | Parraysetu (Pgenarray_set _, index_kind) | Parraysetu ((Paddrarray_set _ | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set Pfloat64 | Punboxedintarray_set _), + | Punboxedfloatarray_set (Pfloat64 | Pfloat32) | Punboxedintarray_set _), (Punboxed_int_index _ as index_kind)) -> Kccall(array_primitive index_kind "caml_array_unsafe_set", 3) | Parraysetu ((Punboxedfloatarray_set Pfloat64 | Pfloatarray_set), Ptagged_int_index) -> Kccall("caml_floatarray_unsafe_set", 3) - | Parraysetu ((Punboxedintarray_set _ | Paddrarray_set _ | Pintarray_set), - Ptagged_int_index) -> Ksetvectitem - | Parraysetu (Punboxedfloatarray_set Pfloat32, _) -> - Misc.fatal_errorf "Cannot use primitive %a for unboxed arrays in bytecode" - Printlambda.primitive p + | Parraysetu ((Punboxedfloatarray_set Pfloat32 | Punboxedintarray_set _ + | Paddrarray_set _ | Pintarray_set), Ptagged_int_index) -> Ksetvectitem | Pctconst c -> let const_name = match c with | Big_endian -> "big_endian" @@ -791,12 +779,13 @@ let rec comp_expr stack_info env exp sz cont = let cont = add_pseudo_event loc !compunit_name cont in comp_args stack_info env args sz (Kmake_faux_mixedblock (total_len, tag) :: cont) - | Lprim((Pmakearray (kind, _, _)) as p, args, loc) -> + | Lprim(Pmakearray (kind, _, _), args, loc) -> let cont = add_pseudo_event loc !compunit_name cont in begin match kind with (* arrays of unboxed types have the same representation as the boxed ones on bytecode *) - | Pintarray | Paddrarray | Punboxedintarray _ -> + | Pintarray | Paddrarray | Punboxedintarray _ + | Punboxedfloatarray Pfloat32 -> comp_args stack_info env args sz (Kmakeblock(List.length args, 0) :: cont) | Pfloatarray | Punboxedfloatarray Pfloat64 -> @@ -808,10 +797,6 @@ let rec comp_expr stack_info env exp sz cont = else comp_args stack_info env args sz (Kmakeblock(List.length args, 0) :: Kccall("caml_make_array", 1) :: cont) - | Punboxedfloatarray Pfloat32 -> - Misc.fatal_errorf - "Cannot use Pmakeblock for unboxed float32 arrays in bytecode" - Printlambda.primitive p end | Lprim((Presume|Prunstack), args, _) -> let nargs = List.length args - 1 in diff --git a/ocaml/lambda/transl_array_comprehension.ml b/ocaml/lambda/transl_array_comprehension.ml index 2af6b8af7a2..2eec81015f6 100644 --- a/ocaml/lambda/transl_array_comprehension.ml +++ b/ocaml/lambda/transl_array_comprehension.ml @@ -699,6 +699,8 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing = (* The representations of these two are the same, it's only accesses that differ. *) Immutable StrictOpt, make_float_vect ~loc array_size.var + | Fixed_size, Punboxedfloatarray Pfloat32 -> + Immutable StrictOpt, make_unboxed_float32_vect ~loc array_size.var | Fixed_size, Punboxedintarray Pint32 -> Immutable StrictOpt, make_unboxed_int32_vect ~loc array_size.var | Fixed_size, Punboxedintarray Pint64 -> @@ -712,9 +714,8 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing = Mutable, Resizable_array.make ~loc array_kind (float 0.) | Dynamic_size, Punboxedfloatarray Pfloat64 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_float 0.) - | (Fixed_size | Dynamic_size), Punboxedfloatarray Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false + | Dynamic_size, Punboxedfloatarray Pfloat32 -> + Mutable, Resizable_array.make ~loc array_kind (unboxed_float32 0.) | Dynamic_size, Punboxedintarray Pint32 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_int32 0l) | Dynamic_size, Punboxedintarray Pint64 -> @@ -808,12 +809,9 @@ let body ~loc ~array_kind ~array_size ~array_sizing ~array ~index ~body = set_element_in_bounds elt.var, Pvalue Pintval (* [unit] is immediate *) )) | Pintarray | Paddrarray | Pfloatarray - | Punboxedfloatarray Pfloat64 + | Punboxedfloatarray (Pfloat64 | Pfloat32) | Punboxedintarray _ -> set_element_in_bounds body - | Punboxedfloatarray Pfloat32 -> - (* CR mslater: (float32) unboxed arrays *) - assert false in Lsequence (set_element_known_kind_in_bounds, Lassign (index.id, index.var + l1)) diff --git a/ocaml/lambda/transl_comprehension_utils.ml b/ocaml/lambda/transl_comprehension_utils.ml index e4a22b61f9a..92e63e0f36c 100644 --- a/ocaml/lambda/transl_comprehension_utils.ml +++ b/ocaml/lambda/transl_comprehension_utils.ml @@ -39,6 +39,9 @@ module Lambda_utils = struct let unboxed_float f = Lconst (Const_base (Const_unboxed_float (Float.to_string f))) + let unboxed_float32 f = + Lconst (Const_base (Const_unboxed_float32 (Float.to_string f))) + let unboxed_int32 i = Lconst (Const_base (Const_unboxed_int32 i)) let unboxed_int64 i = Lconst (Const_base (Const_unboxed_int64 i)) @@ -172,6 +175,8 @@ module Lambda_utils = struct let make_float_vect = unary "caml_make_float_vect" + let make_unboxed_float32_vect = unary "caml_make_unboxed_float32_vect" + let make_unboxed_int32_vect = unary "caml_make_unboxed_int32_vect" let make_unboxed_int64_vect = unary "caml_make_unboxed_int64_vect" diff --git a/ocaml/lambda/transl_comprehension_utils.mli b/ocaml/lambda/transl_comprehension_utils.mli index f0bf82a4b67..eaa7f1cbec7 100644 --- a/ocaml/lambda/transl_comprehension_utils.mli +++ b/ocaml/lambda/transl_comprehension_utils.mli @@ -59,6 +59,8 @@ module Lambda_utils : sig (** Unboxed floats and ints *) val unboxed_float : float -> lambda + val unboxed_float32 : float -> lambda + val unboxed_int32 : Int32.t -> lambda val unboxed_int64 : Int64.t -> lambda @@ -141,6 +143,9 @@ module Lambda_utils : sig uninitialized *) val make_float_vect : loc:scoped_location -> lambda -> lambda + (** Like [make_float_vect] but for unboxed float32 arrays. *) + val make_unboxed_float32_vect : loc:scoped_location -> lambda -> lambda + (** Like [make_float_vect] but for unboxed int32 arrays. *) val make_unboxed_int32_vect : loc:scoped_location -> lambda -> lambda diff --git a/ocaml/runtime/array.c b/ocaml/runtime/array.c index ab323e7788b..5f834ae8c32 100644 --- a/ocaml/runtime/array.c +++ b/ocaml/runtime/array.c @@ -30,23 +30,22 @@ static const mlsize_t mlsize_t_max = -1; /* Unboxed arrays */ -static int no_polymorphic_compare(value v1, value v2) +CAMLprim int caml_unboxed_array_no_polymorphic_compare(value v1, value v2) { caml_failwith("Polymorphic comparison is not permitted for unboxed arrays"); } -static intnat no_polymorphic_hash(value v) +CAMLprim intnat caml_unboxed_array_no_polymorphic_hash(value v) { caml_failwith("Polymorphic hash is not permitted for unboxed arrays"); } -static void unboxed_array_serialize(value v, uintnat* bsize_32, - uintnat* bsize_64) +CAMLprim void caml_unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64) { caml_failwith("Marshalling is not yet implemented for unboxed arrays"); } -static uintnat unboxed_array_deserialize(void* dst) +CAMLprim uintnat caml_unboxed_array_deserialize(void* dst) { caml_failwith("Marshalling is not yet implemented for unboxed arrays"); } @@ -58,18 +57,18 @@ static uintnat unboxed_array_deserialize(void* dst) CAMLexport struct custom_operations caml_unboxed_int32_array_ops[2] = { { "_unboxed_int32_even_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }, { "_unboxed_int32_odd_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }, }; @@ -77,10 +76,10 @@ CAMLexport struct custom_operations caml_unboxed_int32_array_ops[2] = { CAMLexport struct custom_operations caml_unboxed_int64_array_ops = { "_unboxed_int64_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }; @@ -88,10 +87,10 @@ CAMLexport struct custom_operations caml_unboxed_int64_array_ops = { CAMLexport struct custom_operations caml_unboxed_nativeint_array_ops = { "_unboxed_nativeint_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }; diff --git a/ocaml/runtime/float32.c b/ocaml/runtime/float32.c index 63e1ed9ac49..44c2c977cd7 100644 --- a/ocaml/runtime/float32.c +++ b/ocaml/runtime/float32.c @@ -25,6 +25,7 @@ #include #include #include +#include #include "caml/alloc.h" #include "caml/fail.h" @@ -540,3 +541,63 @@ CAMLprim value caml_float32_of_string(value vs) caml_failwith("float32_of_string"); return Val_unit; /* not reached */ } + +/* Defined in array.c */ + +CAMLextern int caml_unboxed_array_no_polymorphic_compare(value v1, value v2); +CAMLextern intnat caml_unboxed_array_no_polymorphic_hash(value v); +CAMLextern void caml_unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64); +CAMLextern uintnat caml_unboxed_array_deserialize(void* dst); +CAMLextern value caml_make_vect(value len, value init); + +CAMLexport const struct custom_operations caml_unboxed_float32_array_ops[2] = { + { "_unboxed_float32_even_array", + custom_finalize_default, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, + custom_compare_ext_default, + custom_fixed_length_default }, + { "_unboxed_float32_odd_array", + custom_finalize_default, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, + custom_compare_ext_default, + custom_fixed_length_default }, +}; + +CAMLprim value caml_make_unboxed_float32_vect(value len) +{ + /* This is only used on 64-bit targets. */ + + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_wosize) caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = (num_elements + 1) / 2; + + return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], + num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) +{ + return caml_make_vect(len, caml_copy_float32(0.0f)); +} + +/* [MM] [TODO]: Not consistent with the memory model. See the discussion in + https://github.com/ocaml-multicore/ocaml-multicore/pull/822. */ +CAMLprim value caml_unboxed_float32_vect_blit(value a1, value ofs1, value a2, + value ofs2, value n) +{ + /* See memory model [MM] notes in memory.c */ + atomic_thread_fence(memory_order_acquire); + // Need to skip the custom_operations field + memmove((float *)((uintnat *)a2 + 1) + Long_val(ofs2), + (float *)((uintnat *)a1 + 1) + Long_val(ofs1), + Long_val(n) * sizeof(float)); + return Val_unit; +} diff --git a/ocaml/runtime4/array.c b/ocaml/runtime4/array.c index 0fd028887f2..6ffe8301227 100644 --- a/ocaml/runtime4/array.c +++ b/ocaml/runtime4/array.c @@ -30,23 +30,22 @@ static const mlsize_t mlsize_t_max = -1; /* Unboxed arrays */ -static int no_polymorphic_compare(value v1, value v2) +CAMLprim int caml_unboxed_array_no_polymorphic_compare(value v1, value v2) { caml_failwith("Polymorphic comparison is not permitted for unboxed arrays"); } -static intnat no_polymorphic_hash(value v) +CAMLprim intnat caml_unboxed_array_no_polymorphic_hash(value v) { caml_failwith("Polymorphic hash is not permitted for unboxed arrays"); } -static void unboxed_array_serialize(value v, uintnat* bsize_32, - uintnat* bsize_64) +CAMLprim void caml_unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64) { caml_failwith("Marshalling is not yet implemented for unboxed arrays"); } -static uintnat unboxed_array_deserialize(void* dst) +CAMLprim uintnat caml_unboxed_array_deserialize(void* dst) { caml_failwith("Marshalling is not yet implemented for unboxed arrays"); } @@ -58,18 +57,18 @@ static uintnat unboxed_array_deserialize(void* dst) CAMLexport struct custom_operations caml_unboxed_int32_array_ops[2] = { { "_unboxed_int32_even_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }, { "_unboxed_int32_odd_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }, }; @@ -77,10 +76,10 @@ CAMLexport struct custom_operations caml_unboxed_int32_array_ops[2] = { CAMLexport struct custom_operations caml_unboxed_int64_array_ops = { "_unboxed_int64_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }; @@ -88,10 +87,10 @@ CAMLexport struct custom_operations caml_unboxed_int64_array_ops = { CAMLexport struct custom_operations caml_unboxed_nativeint_array_ops = { "_unboxed_nativeint_array", custom_finalize_default, - no_polymorphic_compare, - no_polymorphic_hash, - unboxed_array_serialize, - unboxed_array_deserialize, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, custom_compare_ext_default, custom_fixed_length_default }; diff --git a/ocaml/runtime4/float32.c b/ocaml/runtime4/float32.c index 05ef89d348e..26db37d7cc9 100644 --- a/ocaml/runtime4/float32.c +++ b/ocaml/runtime4/float32.c @@ -25,6 +25,7 @@ #include #include #include +#include #include "caml/alloc.h" #include "caml/fail.h" @@ -540,3 +541,59 @@ CAMLprim value caml_float32_of_string(value vs) caml_failwith("float32_of_string"); return Val_unit; /* not reached */ } + +/* Defined in array.c */ + +CAMLextern int caml_unboxed_array_no_polymorphic_compare(value v1, value v2); +CAMLextern intnat caml_unboxed_array_no_polymorphic_hash(value v); +CAMLextern void caml_unboxed_array_serialize(value v, uintnat* bsize_32, uintnat* bsize_64); +CAMLextern uintnat caml_unboxed_array_deserialize(void* dst); +CAMLextern value caml_make_vect(value len, value init); + +CAMLexport struct custom_operations caml_unboxed_float32_array_ops[2] = { + { "_unboxed_float32_even_array", + custom_finalize_default, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, + custom_compare_ext_default, + custom_fixed_length_default }, + { "_unboxed_float32_odd_array", + custom_finalize_default, + caml_unboxed_array_no_polymorphic_compare, + caml_unboxed_array_no_polymorphic_hash, + caml_unboxed_array_serialize, + caml_unboxed_array_deserialize, + custom_compare_ext_default, + custom_fixed_length_default }, +}; + +CAMLprim value caml_make_unboxed_float32_vect(value len) +{ + /* This is only used on 64-bit targets. */ + + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_wosize) caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = (num_elements + 1) / 2; + + return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], + num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) +{ + return caml_make_vect(len, caml_copy_float32(0.0f)); +} + +CAMLprim value caml_unboxed_float32_vect_blit(value a1, value ofs1, value a2, + value ofs2, value n) +{ + // Need to skip the custom_operations field + memmove((float *)((uintnat *)a2 + 1) + Long_val(ofs2), + (float *)((uintnat *)a1 + 1) + Long_val(ofs1), + Long_val(n) * sizeof(float)); + return Val_unit; +} diff --git a/ocaml/testsuite/tests/typing-layouts-arrays/basics.ml b/ocaml/testsuite/tests/typing-layouts-arrays/basics.ml index e1ec4e0186c..ee2c72d3a0f 100644 --- a/ocaml/testsuite/tests/typing-layouts-arrays/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts-arrays/basics.ml @@ -2,12 +2,13 @@ include stable; flambda2; { - flags = "-extension layouts_alpha"; + flags = "-extension layouts_alpha -extension small_numbers"; expect; }{ - flags = "-extension layouts_beta"; + flags = "-extension layouts_beta -extension small_numbers"; expect; }{ + flags = "-extension small_numbers"; expect; } *) @@ -24,12 +25,14 @@ type t2 = int32# array type t3 = int64# array type t4 = nativeint# array type t5 = t_any array +type t6 = float32# array type ('a : float64) t1' = 'a array type ('a : bits32) t2' = 'a array type ('a : bits64) t3' = 'a array type ('a : word) t4' = 'a array type ('a : any) t5' = 'a array +type ('a : float32) t6' = 'a array [%%expect{| type t_any : any @@ -38,11 +41,13 @@ type t2 = int32# array type t3 = int64# array type t4 = nativeint# array type t5 = t_any array +type t6 = float32# array type ('a : float64) t1' = 'a array type ('a : bits32) t2' = 'a array type ('a : bits64) t3' = 'a array type ('a : word) t4' = 'a array type ('a : any) t5' = 'a array +type ('a : float32) t6' = 'a array |}];; (*****************************) @@ -71,6 +76,11 @@ let v4 = [| #1n |] val v4 : nativeint# array = [||] |}];; +let v5 = [| #1.s |] +[%%expect{| +val v5 : float32# array = [||] +|}];; + (****************************************) (* Test 3: Array operations do not work *) @@ -176,6 +186,18 @@ Error: Floatarray primitives can't be used on arrays containing unboxed types. |}];; +external get : float32# array -> int -> float = "%floatarray_safe_get" +let d (x : float32# array) = get x 0 + +[%%expect{| +external get : float32# array -> int -> float = "%floatarray_safe_get" +Line 2, characters 29-36: +2 | let d (x : float32# array) = get x 0 + ^^^^^^^ +Error: Floatarray primitives can't be used on arrays containing + unboxed types. +|}];; + (**************************) (* Test 5: [@layout_poly] *) @@ -184,6 +206,7 @@ let f1 (x : float# array) = get x 0 let f2 (x : int32# array) = get x 0 let f3 (x : int64# array) = get x 0 let f4 (x : nativeint# array) = get x 0 +let f5 (x : float32# array) = get x 0 [%%expect{| external get : ('a : any). 'a array -> int -> 'a = "%array_safe_get" @@ -192,6 +215,7 @@ val f1 : float# array -> float# = val f2 : int32# array -> int32# = val f3 : int64# array -> int64# = val f4 : nativeint# array -> nativeint# = +val f5 : float32# array -> float32# = |}];; external[@layout_poly] set : ('a : any). 'a array -> int -> 'a -> unit = "%array_safe_set" @@ -199,6 +223,7 @@ let f1 (x : float# array) v = set x 0 v let f2 (x : int32# array) v = set x 0 v let f3 (x : int64# array) v = set x 0 v let f4 (x : nativeint# array) v = set x 0 v +let f5 (x : float32# array) v = set x 0 v [%%expect{| external set : ('a : any). 'a array -> int -> 'a -> unit = "%array_safe_set" @@ -207,6 +232,7 @@ val f1 : float# array -> float# -> unit = val f2 : int32# array -> int32# -> unit = val f3 : int64# array -> int64# -> unit = val f4 : nativeint# array -> nativeint# -> unit = +val f5 : float32# array -> float32# -> unit = |}] (***********************************) @@ -275,6 +301,17 @@ Line 2, characters 30-44: Error: This kind of expression is not allowed as right-hand side of `let rec' |}] +let _ = + let[@warning "-10"] rec x = [| x |]; #42l in + ();; + +[%%expect{| +Line 2, characters 30-43: +2 | let[@warning "-10"] rec x = [| x |]; #42l in + ^^^^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of `let rec' +|}] + let _ = let[@warning "-10"] rec x = [| x |]; #42L in ();; @@ -285,3 +322,25 @@ Line 2, characters 30-43: ^^^^^^^^^^^^^ Error: This kind of expression is not allowed as right-hand side of `let rec' |}] + +let _ = + let[@warning "-10"] rec x = [| x |]; #42n in + ();; + +[%%expect{| +Line 2, characters 30-43: +2 | let[@warning "-10"] rec x = [| x |]; #42n in + ^^^^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of `let rec' +|}] + +let _ = + let[@warning "-10"] rec x = [| x |]; #42.0s in + ();; + +[%%expect{| +Line 2, characters 30-45: +2 | let[@warning "-10"] rec x = [| x |]; #42.0s in + ^^^^^^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of `let rec' +|}] diff --git a/ocaml/testsuite/tests/typing-layouts-arrays/test_float32_u_array.ml b/ocaml/testsuite/tests/typing-layouts-arrays/test_float32_u_array.ml new file mode 100644 index 00000000000..07977f3f172 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-arrays/test_float32_u_array.ml @@ -0,0 +1,210 @@ +(* TEST + readonly_files = "gen_u_array.ml test_gen_u_array.ml"; + modules = "${readonly_files}"; + include beta; + flambda2; + { + flags = "-extension small_numbers"; + bytecode; + }{ + flags = "-extension small_numbers"; + native; + }{ + flags = "-extension layouts_beta -extension small_numbers"; + bytecode; + }{ + flags = "-extension layouts_beta -extension small_numbers"; + native; + } +*) +(* Test compilation correctness for array of unboxed float32s. General + tests around type-checking should go to [basics.ml]. *) + +module Float32_I = struct + include Beta.Float32 + let max_val = max_float + let min_val = min_float + let rand f = of_float (Random.float (to_float f)) + let print f = Format.printf "%f" (to_float f) +end + +module Float32_array : Test_gen_u_array.S = struct + include Stdlib.Array + type element_t = float32 + type t = element_t array + let map_to_array f a = map f a + let map_from_array f a = map f a + let max_length = Sys.max_array_length + let equal = for_all2 (fun x y -> x = y) + module I = Float32_I +end +module _ = Test_gen_u_array.Test (Float32_array) + +module Float32_u_array0 : Gen_u_array.S0 + with type element_t = float32# + and type ('a : any) array_t = 'a array = struct + + type element_t = float32# + type ('a : any) array_t = 'a array + type element_arg = unit -> element_t + type t = element_t array + external length : ('a : float32). 'a array -> int = "%array_length" + external get: ('a : float32). 'a array -> int -> 'a = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: ('a : float32). 'a array -> int -> 'a -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: ('a : float32). 'a array -> int -> 'a = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: ('a : float32). 'a array -> int -> 'a -> unit = "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external unsafe_create : ('a : float32). int -> 'a array = + "caml_make_unboxed_float32_vect_bytecode" "caml_make_unboxed_float32_vect" + external unsafe_blit : ('a : float32). + 'a array -> int -> 'a array -> int -> int -> unit = + "caml_array_blit" "caml_unboxed_float32_vect_blit" + let empty () = [||] + external to_boxed : ('a : float32) -> (float32[@local_opt]) = "%box_float32" + let compare_element x y = Float32.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module Float32_u_array = Gen_u_array.Make (Float32_u_array0) +module Float32_u_array_boxed : Test_gen_u_array.S with type t = float32# array = Test_gen_u_array.Make_boxed (struct + module M = Float32_u_array + module I = Float32_I + module E = struct + open Beta.Float32_u + let to_boxed x = to_float32 (x ()) + let of_boxed x () = of_float32 x + end +end) +module _ = Test_gen_u_array.Test (Float32_u_array_boxed) + + +(* Extra tests for array expressions and patterns *) +module A = Float32_u_array_boxed +module I = Float32_u_array_boxed.I + +let check_i a = + let rec check_i_upto a i = + if i >= 0 then begin + assert (A.get a i = I.of_int i); + check_i_upto a (i - 1); + end + in + check_i_upto a (A.length a - 1) + +let check_eq_f f arr = A.iteri (fun i x -> assert (x = f i)) arr +let check_all_the_same v arr = A.iter (fun x -> assert (x = v)) arr + +let check_inval f arg = + match f arg with + | _ -> assert false + | exception (Invalid_argument _) -> () + | exception _ -> assert false + +let () = + (* empty arrays *) + let test_empty_array arr = + check_inval (fun a -> A.get a 0) arr; + check_inval (fun a -> A.get a 1) arr; + check_inval (fun a -> A.get a (-1)) arr; + check_inval (fun a -> A.set a 0 (I.of_int 0)) arr; + check_inval (fun a -> A.set a 1 (I.of_int 0)) arr; + check_inval (fun a -> A.set a (-1) (I.of_int 0)) arr + in + let r : A.t = [||] in + test_empty_array r; + let r = A.make (Sys.opaque_identity 0) (I.of_int 0) in + test_empty_array r; + + (* static blocks *) + let r = [| +#0.s;#1.s;#2.s;#3.s;#4.s;#5.s;#6.s;#7.s;#8.s;#9.s;#10.s;#11.s;#12.s;#13.s;#14.s;#15.s;#16.s;#17.s; +#18.s;#19.s;#20.s;#21.s;#22.s;#23.s;#24.s;#25.s;#26.s;#27.s;#28.s;#29.s;#30.s;#31.s;#32.s;#33.s;#34.s;#35.s; +#36.s;#37.s;#38.s;#39.s;#40.s;#41.s;#42.s;#43.s;#44.s;#45.s;#46.s;#47.s;#48.s;#49.s;#50.s;#51.s;#52.s;#53.s; +#54.s;#55.s;#56.s;#57.s;#58.s;#59.s;#60.s;#61.s;#62.s;#63.s;#64.s;#65.s;#66.s;#67.s;#68.s;#69.s;#70.s;#71.s; +#72.s;#73.s;#74.s;#75.s;#76.s;#77.s;#78.s;#79.s;#80.s;#81.s;#82.s;#83.s;#84.s;#85.s;#86.s;#87.s;#88.s;#89.s; +#90.s;#91.s;#92.s;#93.s;#94.s;#95.s;#96.s;#97.s;#98.s;#99.s; |] + in + check_i r; + let r = [| +#0.s;#1.s;#2.s;#3.s;#4.s;#5.s;#6.s;#7.s;#8.s;#9.s;#10.s;#11.s;#12.s;#13.s;#14.s;#15.s;#16.s;#17.s; +#18.s;#19.s;#20.s;#21.s;#22.s;#23.s;#24.s;#25.s;#26.s;#27.s;#28.s;#29.s;#30.s;#31.s;#32.s;#33.s;#34.s;#35.s; +#36.s;#37.s;#38.s;#39.s;#40.s;#41.s;#42.s;#43.s;#44.s;#45.s;#46.s;#47.s;#48.s;#49.s;#50.s;#51.s;#52.s;#53.s; +#54.s;#55.s;#56.s;#57.s;#58.s;#59.s;#60.s;#61.s;#62.s;#63.s;#64.s;#65.s;#66.s;#67.s;#68.s;#69.s;#70.s;#71.s; +#72.s;#73.s;#74.s;#75.s;#76.s;#77.s;#78.s;#79.s;#80.s;#81.s;#82.s;#83.s;#84.s;#85.s;#86.s;#87.s;#88.s;#89.s; +#90.s;#91.s;#92.s;#93.s;#94.s;#95.s;#96.s;#97.s;#98.s;#99.s;#100.s; |] + in + check_i r; + let r = [|-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;-#123.s;|] in + check_all_the_same (I.of_int (-123)) r; + let r = + [|-#1.s; #1.s; -#1.s; #1.s; -#1.s; #1.s; -#1.s; #1.s; -#1.s;|] + in + check_eq_f (fun idx -> if (idx mod 2) = 0 then I.of_int (-1) else I.of_int 1) r; + let r = + [|#1.s; -#1.s; #1.s; -#1.s; #1.s; -#1.s; #1.s; -#1.s;|] + in + check_eq_f (fun idx -> if (idx mod 2) = 0 then I.of_int (1) else I.of_int (-1)) r; + (* dynamic blocks *) + let[@inline never] f x = x in + let r = [| + f #0.s;f #1.s;f #2.s;f #3.s;f #4.s;f #5.s;f #6.s;f #7.s;f #8.s;f #9.s;f #10.s;f #11.s;f #12.s;f #13.s;f #14.s; + f #15.s;f #16.s;f #17.s;f #18.s;f #19.s;f #20.s;f #21.s;f #22.s;f #23.s;f #24.s;f #25.s;f #26.s;f #27.s;f #28.s;f #29.s; + f #30.s;f #31.s;f #32.s;f #33.s;f #34.s;f #35.s;f #36.s;f #37.s;f #38.s;f #39.s;f #40.s;f #41.s;f #42.s;f #43.s;f #44.s; + f #45.s;f #46.s;f #47.s;f #48.s;f #49.s;f #50.s;f #51.s;f #52.s;f #53.s;f #54.s;f #55.s;f #56.s;f #57.s;f #58.s;f #59.s; + f #60.s;f #61.s;f #62.s;f #63.s;f #64.s;f #65.s;f #66.s;f #67.s;f #68.s;f #69.s;f #70.s;f #71.s;f #72.s;f #73.s;f #74.s; + f #75.s;f #76.s;f #77.s;f #78.s;f #79.s;f #80.s;f #81.s;f #82.s;f #83.s;f #84.s;f #85.s;f #86.s;f #87.s;f #88.s;f #89.s; + f #90.s;f #91.s;f #92.s;f #93.s;f #94.s;f #95.s;f #96.s;f #97.s;f #98.s;f #99.s; |] + in + check_i r; + let r = [| + f #0.s;f #1.s;f #2.s;f #3.s;f #4.s;f #5.s;f #6.s;f #7.s;f #8.s;f #9.s;f #10.s;f #11.s;f #12.s;f #13.s;f #14.s; + f #15.s;f #16.s;f #17.s;f #18.s;f #19.s;f #20.s;f #21.s;f #22.s;f #23.s;f #24.s;f #25.s;f #26.s;f #27.s;f #28.s;f #29.s; + f #30.s;f #31.s;f #32.s;f #33.s;f #34.s;f #35.s;f #36.s;f #37.s;f #38.s;f #39.s;f #40.s;f #41.s;f #42.s;f #43.s;f #44.s; + f #45.s;f #46.s;f #47.s;f #48.s;f #49.s;f #50.s;f #51.s;f #52.s;f #53.s;f #54.s;f #55.s;f #56.s;f #57.s;f #58.s;f #59.s; + f #60.s;f #61.s;f #62.s;f #63.s;f #64.s;f #65.s;f #66.s;f #67.s;f #68.s;f #69.s;f #70.s;f #71.s;f #72.s;f #73.s;f #74.s; + f #75.s;f #76.s;f #77.s;f #78.s;f #79.s;f #80.s;f #81.s;f #82.s;f #83.s;f #84.s;f #85.s;f #86.s;f #87.s;f #88.s;f #89.s; + f #90.s;f #91.s;f #92.s;f #93.s;f #94.s;f #95.s;f #96.s;f #97.s;f #98.s;f #99.s;f #100.s; |] + in + check_i r; + let r = + [|f (-#123.s);f (-#123.s);f (-#123.s);f (-#123.s);f (-#123.s);f (-#123.s);f (-#123.s);f (-#123.s);f (-#123.s);|] + in + check_all_the_same (I.of_int (-123)) r; + check_i [| #0.s; ((fun x -> x) #1.s)|]; + check_i [| #0.s; ((fun x -> x) #1.s); #2.s|]; + let r = + [|f (-#1.s);f (#1.s);f (-#1.s);f (#1.s);f (-#1.s);f (#1.s);f (-#1.s);f (#1.s);f (-#1.s);|] + in + check_eq_f (fun idx -> if (idx mod 2) = 0 then I.of_int (-1) else I.of_int 1) r; + let r = + [|f (#1.s);f (-#1.s);f (#1.s);f (-#1.s);f (#1.s);f (-#1.s);f (#1.s);f (-#1.s);|] + in + check_eq_f (fun idx -> if (idx mod 2) = 0 then I.of_int (1) else I.of_int (-1)) r; + () + + +(* expression and patterns *) +let () = + let ( = ) = Beta.Float32_u.equal in + (* match statement *) + let d = [| #1.s; #2.s |] in + (match d with + | [| a; b |] -> + assert (a = #1.s); + assert (b = #2.s) + | _ -> assert false); + + (* let statement pattern *) + let a = [||] in + let b = [| #1.s |] in + let c = A.append a b in + let[@warning "-8"] [| d |] = c in + assert (d = #1.s); + + (* function argument pattern *) + let[@warning "-8"] f [| b |] = b in + assert (f [| #1.s |] = #1.s); + ()