diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index e1673e409a9..6756edbff88 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -1704,6 +1704,7 @@ let curry_function_sym function_kind arity result = let bigarray_elt_size_in_bytes : Lambda.bigarray_kind -> int = function | Pbigarray_unknown -> assert false | Pbigarray_float32 -> 4 + | Pbigarray_float32_t -> 4 | Pbigarray_float64 -> 8 | Pbigarray_sint8 -> 1 | Pbigarray_uint8 -> 1 @@ -1719,6 +1720,7 @@ let bigarray_elt_size_in_bytes : Lambda.bigarray_kind -> int = function let bigarray_word_kind : Lambda.bigarray_kind -> memory_chunk = function | Pbigarray_unknown -> assert false | Pbigarray_float32 -> Single { reg = Float64 } + | Pbigarray_float32_t -> Single { reg = Float32 } | Pbigarray_float64 -> Double | Pbigarray_sint8 -> Byte_signed | Pbigarray_uint8 -> Byte_unsigned @@ -2173,6 +2175,15 @@ let unaligned_set_64 ptr idx newval dbg = [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8], dbg ) ) ) ) +let unaligned_load_f32 ptr idx dbg = + Cop (mk_load_mut (Single { reg = Float32 }), [add_int ptr idx dbg], dbg) + +let unaligned_set_f32 ptr idx newval dbg = + Cop + ( Cstore (Single { reg = Float32 }, Assignment), + [add_int ptr idx dbg; newval], + dbg ) + let unaligned_load_128 ptr idx dbg = assert (size_vec128 = 16); Cop (mk_load_mut Onetwentyeight_unaligned, [add_int ptr idx dbg], dbg) diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index a12c68b7f2a..e28b87889cd 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -392,6 +392,11 @@ val unaligned_load_32 : expression -> expression -> Debuginfo.t -> expression val unaligned_set_32 : expression -> expression -> expression -> Debuginfo.t -> expression +val unaligned_load_f32 : expression -> expression -> Debuginfo.t -> expression + +val unaligned_set_f32 : + expression -> expression -> expression -> Debuginfo.t -> expression + val unaligned_load_64 : expression -> expression -> Debuginfo.t -> expression val unaligned_set_64 : diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index eca2d21f640..065cd6e1481 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -930,16 +930,18 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _ - | Pstring_load_64 _ | Pstring_load_128 _ | Pbytes_load_16 _ - | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _ - | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ - | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ - | Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ - | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pfloatarray_load_128 _ - | Pfloat_array_load_128 _ | Pint_array_load_128 _ - | Punboxed_float_array_load_128 _ | Punboxed_int32_array_load_128 _ - | Punboxed_int64_array_load_128 _ | Punboxed_nativeint_array_load_128 _ - | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _ + | Pstring_load_f32 _ | Pstring_load_64 _ | Pstring_load_128 _ + | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_f32 _ + | Pbytes_load_64 _ | Pbytes_load_128 _ | Pbytes_set_16 _ | Pbytes_set_32 _ + | Pbytes_set_f32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ + | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_f32 _ + | Pbigstring_load_64 _ | Pbigstring_load_128 _ | Pbigstring_set_16 _ + | Pbigstring_set_32 _ | Pbigstring_set_f32 _ | Pbigstring_set_64 _ + | Pbigstring_set_128 _ | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ + | Pint_array_load_128 _ | Punboxed_float_array_load_128 _ + | Punboxed_int32_array_load_128 _ | Punboxed_int64_array_load_128 _ + | Punboxed_nativeint_array_load_128 _ | Pfloatarray_set_128 _ + | Pfloat_array_set_128 _ | Pint_array_set_128 _ | Punboxed_float_array_set_128 _ | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ | Punboxed_nativeint_array_set_128 _ | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque _ diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 277f6f05072..160d2f103bd 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -291,6 +291,7 @@ let transform_primitive env (prim : L.primitive) args loc = Primitive (L.Pnot, [L.Lprim (Punboxed_float_comp (bf, CFge), args, loc)], loc) | Pbigarrayref (_unsafe, num_dimensions, kind, layout), args -> ( + (* CR mshinwell: factor out with the [Pbigarrayset] case *) match P.Bigarray_kind.from_lambda kind, P.Bigarray_layout.from_lambda layout with @@ -299,7 +300,19 @@ let transform_primitive env (prim : L.primitive) args loc = if 1 <= num_dimensions && num_dimensions <= 3 then let arity = 1 + num_dimensions in - let name = "caml_ba_get_" ^ string_of_int num_dimensions in + let is_float32_t = + match kind with + | Pbigarray_float32_t -> "float32_" + | Pbigarray_unknown | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 + | Pbigarray_uint16 | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int | Pbigarray_complex32 + | Pbigarray_complex64 -> + "" + in + let name = + "caml_ba_" ^ is_float32_t ^ "get_" ^ string_of_int num_dimensions + in let desc = Lambda.simple_prim_on_values ~name ~arity ~alloc:true in Primitive (L.Pccall desc, args, loc) else @@ -316,7 +329,19 @@ let transform_primitive env (prim : L.primitive) args loc = if 1 <= num_dimensions && num_dimensions <= 3 then let arity = 2 + num_dimensions in - let name = "caml_ba_set_" ^ string_of_int num_dimensions in + let is_float32_t = + match kind with + | Pbigarray_float32_t -> "float32_" + | Pbigarray_unknown | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 + | Pbigarray_uint16 | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int | Pbigarray_complex32 + | Pbigarray_complex64 -> + "" + in + let name = + "caml_ba_" ^ is_float32_t ^ "set_" ^ string_of_int num_dimensions + in let desc = Lambda.simple_prim_on_values ~name ~arity ~alloc:true in Primitive (L.Pccall desc, args, loc) else @@ -589,22 +614,27 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pstringrefs | Pbytesrefs | Pbytessets | Pstring_load_16 false | Pstring_load_32 (false, _) + | Pstring_load_f32 (false, _) | Pstring_load_64 (false, _) | Pstring_load_128 { unsafe = false; _ } | Pbytes_load_16 false | Pbytes_load_32 (false, _) + | Pbytes_load_f32 (false, _) | Pbytes_load_64 (false, _) | Pbytes_load_128 { unsafe = false; _ } | Pbytes_set_16 false | Pbytes_set_32 false + | Pbytes_set_f32 false | Pbytes_set_64 false | Pbytes_set_128 { unsafe = false; _ } | Pbigstring_load_16 { unsafe = false } | Pbigstring_load_32 { unsafe = false; mode = _; boxed = _ } + | Pbigstring_load_f32 { unsafe = false; mode = _; boxed = _ } | Pbigstring_load_64 { unsafe = false; mode = _; boxed = _ } | Pbigstring_load_128 { unsafe = false; _ } | Pbigstring_set_16 { unsafe = false } | Pbigstring_set_32 { unsafe = false; boxed = _ } + | Pbigstring_set_f32 { unsafe = false; boxed = _ } | Pbigstring_set_64 { unsafe = false; boxed = _ } | Pbigstring_set_128 { unsafe = false; _ } | Pfloatarray_load_128 { unsafe = false; _ } @@ -662,37 +692,44 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbigarrayref ( true, _, - ( Pbigarray_float32 | Pbigarray_float64 | Pbigarray_sint8 - | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 | Pbigarray_caml_int - | Pbigarray_native_int | Pbigarray_complex32 | Pbigarray_complex64 ), + ( Pbigarray_float32 | Pbigarray_float32_t | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 + | Pbigarray_uint16 | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int | Pbigarray_complex32 + | Pbigarray_complex64 ), _ ) | Pbigarrayset ( true, _, - ( Pbigarray_float32 | Pbigarray_float64 | Pbigarray_sint8 - | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 | Pbigarray_caml_int - | Pbigarray_native_int | Pbigarray_complex32 | Pbigarray_complex64 ), + ( Pbigarray_float32 | Pbigarray_float32_t | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 + | Pbigarray_uint16 | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int | Pbigarray_complex32 + | Pbigarray_complex64 ), (Pbigarray_c_layout | Pbigarray_fortran_layout) ) | Pstring_load_16 true | Pstring_load_32 (true, _) + | Pstring_load_f32 (true, _) | Pstring_load_64 (true, _) | Pstring_load_128 { unsafe = true; _ } | Pbytes_load_16 true | Pbytes_load_32 (true, _) + | Pbytes_load_f32 (true, _) | Pbytes_load_64 (true, _) | Pbytes_load_128 { unsafe = true; _ } | Pbytes_set_16 true | Pbytes_set_32 true + | Pbytes_set_f32 true | Pbytes_set_64 true | Pbytes_set_128 { unsafe = true; _ } | Pbigstring_load_16 { unsafe = true } | Pbigstring_load_32 { unsafe = true; mode = _; boxed = _ } + | Pbigstring_load_f32 { unsafe = true; mode = _; boxed = _ } | Pbigstring_load_64 { unsafe = true; mode = _; boxed = _ } | Pbigstring_load_128 { unsafe = true; _ } | Pbigstring_set_16 { unsafe = true } | Pbigstring_set_32 { unsafe = true; boxed = _ } + | Pbigstring_set_f32 { unsafe = true; boxed = _ } | Pbigstring_set_64 { unsafe = true; boxed = _ } | Pbigstring_set_128 { unsafe = true; _ } | Pfloatarray_load_128 { unsafe = true; _ } 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 46027a914a0..d7f43bc40f3 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -425,7 +425,7 @@ let actual_max_length_for_string_like_access ~size_int ~access_size length = match (size : Flambda_primitive.string_accessor_width) with | Eight -> 0 | Sixteen -> 1 - | Thirty_two -> 3 + | Thirty_two | Single -> 3 | Sixty_four -> 7 | One_twenty_eight _ -> 15 in @@ -433,7 +433,7 @@ let actual_max_length_for_string_like_access ~size_int ~access_size length = in match (access_size : Flambda_primitive.string_accessor_width) with | Eight -> length (* micro-optimization *) - | Sixteen | Thirty_two | Sixty_four | One_twenty_eight _ -> + | Sixteen | Thirty_two | Single | Sixty_four | One_twenty_eight _ -> let offset = length_offset_of_size access_size in let reduced_length = H.Prim @@ -489,7 +489,7 @@ let checked_string_or_bytes_access ~dbg ~size_int ~access_size ~primitive kind | One_twenty_eight { aligned = true } -> Misc.fatal_error "flambda2 cannot yet check string/bytes aligned access safety" - | Eight | Sixteen | Thirty_two | Sixty_four + | Eight | Sixteen | Thirty_two | Single | Sixty_four | One_twenty_eight { aligned = false } -> ()); checked_access ~dbg ~primitive @@ -503,7 +503,7 @@ let checked_bigstring_access ~dbg ~size_int ~access_size ~primitive arg1 arg2 = | One_twenty_eight { aligned = true } -> checked_alignment ~dbg ~primitive ~conditions:[bigstring_alignment_validity_condition arg1 16 arg2] - | Eight | Sixteen | Thirty_two | Sixty_four + | Eight | Sixteen | Thirty_two | Single | Sixty_four | One_twenty_eight { aligned = false } -> primitive in @@ -521,12 +521,14 @@ let string_like_load_unsafe ~access_size kind mode ~boxed string index tag_int | Thirty_two, Some mode -> if boxed then box_bint Pint32 mode ~current_region else Fun.id + | Single, Some mode -> + if boxed then box_float32 mode ~current_region else Fun.id | Sixty_four, Some mode -> if boxed then box_bint Pint64 mode ~current_region else Fun.id | One_twenty_eight _, Some mode -> if boxed then box_vec128 mode ~current_region else Fun.id | (Eight | Sixteen), Some _ - | (Thirty_two | Sixty_four | One_twenty_eight _), None -> + | (Thirty_two | Single | Sixty_four | One_twenty_eight _), None -> Misc.fatal_error "Inconsistent alloc_mode for string or bytes load" in wrap (Binary (String_or_bigstring_load (kind, access_size), string, index)) @@ -565,6 +567,7 @@ let bytes_like_set_unsafe ~access_size kind ~boxed bytes index new_value = assert (not boxed); untag_int | Thirty_two -> if boxed then unbox_bint Pint32 else Fun.id + | Single -> if boxed then unbox_float32 else Fun.id | Sixty_four -> if boxed then unbox_bint Pint64 else Fun.id | One_twenty_eight _ -> if boxed then unbox_vec128 else Fun.id in @@ -1298,9 +1301,15 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pstring_load_32 (true (* unsafe *), mode), [[str]; [index]] -> [ string_like_load_unsafe ~access_size:Thirty_two String ~boxed:true (Some mode) str index ~current_region ] + | Pstring_load_f32 (true (* unsafe *), mode), [[str]; [index]] -> + [ string_like_load_unsafe ~access_size:Single String ~boxed:true (Some mode) + str index ~current_region ] | Pbytes_load_32 (true (* unsafe *), mode), [[bytes]; [index]] -> [ string_like_load_unsafe ~access_size:Thirty_two Bytes ~boxed:true (Some mode) bytes index ~current_region ] + | Pbytes_load_f32 (true (* unsafe *), mode), [[bytes]; [index]] -> + [ string_like_load_unsafe ~access_size:Single Bytes ~boxed:true (Some mode) + bytes index ~current_region ] | Pstring_load_64 (true (* unsafe *), mode), [[str]; [index]] -> [ string_like_load_unsafe ~access_size:Sixty_four String ~boxed:true (Some mode) str index ~current_region ] @@ -1321,6 +1330,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pstring_load_32 (false (* safe *), mode), [[str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two String (Some mode) ~boxed:true str index ~current_region ] + | Pstring_load_f32 (false (* safe *), mode), [[str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Single String + (Some mode) ~boxed:true str index ~current_region ] | Pstring_load_64 (false (* safe *), mode), [[str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four String (Some mode) ~boxed:true str index ~current_region ] @@ -1334,6 +1346,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pbytes_load_32 (false (* safe *), mode), [[bytes]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bytes ~boxed:true (Some mode) bytes index ~current_region ] + | Pbytes_load_f32 (false (* safe *), mode), [[bytes]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Single Bytes ~boxed:true + (Some mode) bytes index ~current_region ] | Pbytes_load_64 (false (* safe *), mode), [[bytes]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four Bytes ~boxed:true (Some mode) bytes index ~current_region ] @@ -1347,6 +1362,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pbytes_set_32 true (* unsafe *), [[bytes]; [index]; [new_value]] -> [ bytes_like_set_unsafe ~access_size:Thirty_two Bytes ~boxed:true bytes index new_value ] + | Pbytes_set_f32 true (* unsafe *), [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_unsafe ~access_size:Single Bytes ~boxed:true bytes index + new_value ] | Pbytes_set_64 true (* unsafe *), [[bytes]; [index]; [new_value]] -> [ bytes_like_set_unsafe ~access_size:Sixty_four Bytes ~boxed:true bytes index new_value ] @@ -1360,6 +1378,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pbytes_set_32 false (* safe *), [[bytes]; [index]; [new_value]] -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bytes ~boxed:true bytes index new_value ] + | Pbytes_set_f32 false (* safe *), [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Single Bytes ~boxed:true + bytes index new_value ] | Pbytes_set_64 false (* safe *), [[bytes]; [index]; [new_value]] -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bytes ~boxed:true bytes index new_value ] @@ -1740,6 +1761,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pbigstring_load_32 { unsafe = true; mode; boxed }, [[big_str]; [index]] -> [ string_like_load_unsafe ~access_size:Thirty_two Bigstring (Some mode) ~boxed big_str index ~current_region ] + | Pbigstring_load_f32 { unsafe = true; mode; boxed }, [[big_str]; [index]] -> + [ string_like_load_unsafe ~access_size:Single Bigstring (Some mode) ~boxed + big_str index ~current_region ] | Pbigstring_load_64 { unsafe = true; mode; boxed }, [[big_str]; [index]] -> [ string_like_load_unsafe ~access_size:Sixty_four Bigstring (Some mode) ~boxed big_str index ~current_region ] @@ -1754,6 +1778,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pbigstring_load_32 { unsafe = false; mode; boxed }, [[big_str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring (Some mode) ~boxed big_str index ~current_region ] + | Pbigstring_load_f32 { unsafe = false; mode; boxed }, [[big_str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Single Bigstring + (Some mode) ~boxed big_str index ~current_region ] | Pbigstring_load_64 { unsafe = false; mode; boxed }, [[big_str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Sixty_four Bigstring (Some mode) ~boxed big_str index ~current_region ] @@ -1769,6 +1796,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_unsafe ~access_size:Thirty_two Bigstring ~boxed bigstring index new_value ] + | ( Pbigstring_set_f32 { unsafe = true; boxed }, + [[bigstring]; [index]; [new_value]] ) -> + [ bytes_like_set_unsafe ~access_size:Single Bigstring ~boxed bigstring index + new_value ] | ( Pbigstring_set_64 { unsafe = true; boxed }, [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_unsafe ~access_size:Sixty_four Bigstring ~boxed bigstring @@ -1785,6 +1816,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring ~boxed bigstring index new_value ] + | ( Pbigstring_set_f32 { unsafe = false; boxed }, + [[bigstring]; [index]; [new_value]] ) -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Single Bigstring ~boxed + bigstring index new_value ] | ( Pbigstring_set_64 { unsafe = false; boxed }, [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bigstring @@ -1932,13 +1967,14 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pfloatcomp (_, _) | Punboxed_float_comp (_, _) | Pstringrefu | Pbytesrefu | Pstringrefs | Pbytesrefs | Pstring_load_16 _ - | Pstring_load_32 _ | Pstring_load_64 _ | Pstring_load_128 _ - | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ - | Pbytes_load_128 _ | Pisout | Paddbint _ | Psubbint _ | Pmulbint _ - | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ - | Pasrbint _ | Pfield_computed _ | Pdivbint _ | Pmodbint _ - | Psetfloatfield _ | Psetufloatfield _ | Pbintcomp _ | Punboxed_int_comp _ - | Psetmixedfield _ | Pbigstring_load_16 _ | Pbigstring_load_32 _ + | Pstring_load_32 _ | Pstring_load_f32 _ | Pstring_load_64 _ + | Pstring_load_128 _ | Pbytes_load_16 _ | Pbytes_load_32 _ + | Pbytes_load_f32 _ | Pbytes_load_64 _ | Pbytes_load_128 _ | Pisout + | Paddbint _ | Psubbint _ | Pmulbint _ | Pandbint _ | Porbint _ + | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pfield_computed _ + | Pdivbint _ | Pmodbint _ | Psetfloatfield _ | Psetufloatfield _ + | Pbintcomp _ | Punboxed_int_comp _ | Psetmixedfield _ + | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_f32 _ | Pbigstring_load_64 _ | Pbigstring_load_128 _ | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _ | Punboxed_float_array_load_128 _ | Punboxed_int32_array_load_128 _ @@ -1975,12 +2011,13 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pfloatarray_set | Punboxedfloatarray_set _ | Punboxedintarray_set _ ), _ ) - | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ - | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ - | Pbigstring_set_128 _ | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ - | Pint_array_set_128 _ | Punboxed_float_array_set_128 _ - | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ - | Punboxed_nativeint_array_set_128 _ | Patomic_cas ), + | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _ | Pbytes_set_64 _ + | Pbytes_set_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pbigstring_set_f32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ + | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _ + | Punboxed_float_array_set_128 _ | Punboxed_int32_array_set_128 _ + | Punboxed_int64_array_set_128 _ | Punboxed_nativeint_array_set_128 _ + | Patomic_cas ), ( [] | [_] | [_; _] diff --git a/middle_end/flambda2/parser/fexpr.ml b/middle_end/flambda2/parser/fexpr.ml index 10bb5bc1469..cd66d8f53dd 100644 --- a/middle_end/flambda2/parser/fexpr.ml +++ b/middle_end/flambda2/parser/fexpr.ml @@ -330,6 +330,7 @@ type string_accessor_width = Flambda_primitive.string_accessor_width = | Eight | Sixteen | Thirty_two + | Single | Sixty_four | One_twenty_eight of { aligned : bool } diff --git a/middle_end/flambda2/parser/print_fexpr.ml b/middle_end/flambda2/parser/print_fexpr.ml index b93e97f16ca..3091e4d361a 100644 --- a/middle_end/flambda2/parser/print_fexpr.ml +++ b/middle_end/flambda2/parser/print_fexpr.ml @@ -489,6 +489,7 @@ let string_accessor_width ppf saw = | Eight -> "8" | Sixteen -> "16" | Thirty_two -> "32" + | Single -> "f32" | Sixty_four -> "64" | One_twenty_eight { aligned = false } -> "128u" | One_twenty_eight { aligned = true } -> "128a") diff --git a/middle_end/flambda2/terms/code_size.ml b/middle_end/flambda2/terms/code_size.ml index 42f01c49c1f..cf21e1a6a99 100644 --- a/middle_end/flambda2/terms/code_size.ml +++ b/middle_end/flambda2/terms/code_size.ml @@ -186,7 +186,7 @@ let string_or_bigstring_load kind width = desirable ? *) | Sixteen -> 2 (* add, load (allow_unaligned_access) *) (* 7 (not allow_unaligned_access) *) - | Thirty_two -> 2 (* add, load (allow_unaligned_access) *) + | Thirty_two | Single -> 2 (* add, load (allow_unaligned_access) *) (* 17 (not allow_unaligned_access) *) | Sixty_four -> if arch32 then does_not_need_caml_c_call_extcall_size else 2 (* add, load (allow_unaligned_access) *) diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml index dbca2acfe35..37c912a8ac7 100644 --- a/middle_end/flambda2/terms/flambda_primitive.ml +++ b/middle_end/flambda2/terms/flambda_primitive.ml @@ -620,6 +620,7 @@ let print_equality_comparison ppf op = module Bigarray_kind = struct type t = | Float32 + | Float32_t | Float64 | Sint8 | Uint8 @@ -635,6 +636,7 @@ module Bigarray_kind = struct let element_kind t = match t with | Float32 | Float64 -> K.naked_float + | Float32_t -> K.naked_float32 | Sint8 | Uint8 | Sint16 | Uint16 -> K.naked_immediate | Int32 -> K.naked_int32 | Int64 -> K.naked_int64 @@ -648,6 +650,7 @@ module Bigarray_kind = struct let fprintf = Format.fprintf in match t with | Float32 -> fprintf ppf "Float32" + | Float32_t -> fprintf ppf "Float32_t" | Float64 -> fprintf ppf "Float64" | Sint8 -> fprintf ppf "Sint8" | Uint8 -> fprintf ppf "Uint8" @@ -664,6 +667,7 @@ module Bigarray_kind = struct match kind with | Pbigarray_unknown -> None | Pbigarray_float32 -> Some Float32 + | Pbigarray_float32_t -> Some Float32_t | Pbigarray_float64 -> Some Float64 | Pbigarray_sint8 -> Some Sint8 | Pbigarray_uint8 -> Some Uint8 @@ -679,6 +683,7 @@ module Bigarray_kind = struct let to_lambda t : Lambda.bigarray_kind = match t with | Float32 -> Pbigarray_float32 + | Float32_t -> Pbigarray_float32_t | Float64 -> Pbigarray_float64 | Sint8 -> Pbigarray_sint8 | Uint8 -> Pbigarray_uint8 @@ -714,8 +719,8 @@ let reading_from_a_bigarray kind = ( Effects.Only_generative_effects Immutable, Coeffects.Has_coeffects, Placement.Strict ) - | Float32 | Float64 | Sint8 | Uint8 | Sint16 | Uint16 | Int32 | Int64 - | Int_width_int | Targetint_width_int -> + | Float32 | Float32_t | Float64 | Sint8 | Uint8 | Sint16 | Uint16 | Int32 + | Int64 | Int_width_int | Targetint_width_int -> Effects.No_effects, Coeffects.Has_coeffects, Placement.Strict (* The bound checks are taken care of outside the array primitive (using an @@ -723,8 +728,8 @@ let reading_from_a_bigarray kind = lambda_to_flambda_primitives.ml). *) let writing_to_a_bigarray kind = match (kind : Bigarray_kind.t) with - | Float32 | Float64 | Sint8 | Uint8 | Sint16 | Uint16 | Int32 | Int64 - | Int_width_int | Targetint_width_int | Complex32 + | Float32 | Float32_t | Float64 | Sint8 | Uint8 | Sint16 | Uint16 | Int32 + | Int64 | Int_width_int | Targetint_width_int | Complex32 | Complex64 (* Technically, the write of a complex generates read of fields from the given complex, but since those reads are immutable, there is no @@ -757,6 +762,7 @@ type string_accessor_width = | Eight | Sixteen | Thirty_two + | Single | Sixty_four | One_twenty_eight of { aligned : bool } @@ -766,6 +772,7 @@ let print_string_accessor_width ppf w = | Eight -> fprintf ppf "8" | Sixteen -> fprintf ppf "16" | Thirty_two -> fprintf ppf "32" + | Single -> fprintf ppf "f32" | Sixty_four -> fprintf ppf "64" | One_twenty_eight { aligned = false } -> fprintf ppf "128u" | One_twenty_eight { aligned = true } -> fprintf ppf "128a" @@ -775,6 +782,7 @@ let byte_width_of_string_accessor_width width = | Eight -> 1 | Sixteen -> 2 | Thirty_two -> 4 + | Single -> 4 | Sixty_four -> 8 | One_twenty_eight _ -> 16 @@ -782,6 +790,7 @@ let kind_of_string_accessor_width width = match width with | Eight | Sixteen -> K.value | Thirty_two -> K.naked_int32 + | Single -> K.naked_float32 | Sixty_four -> K.naked_int64 | One_twenty_eight _ -> K.naked_vec128 @@ -1622,6 +1631,7 @@ let result_kind_of_binary_primitive p : result_kind = | String_or_bigstring_load (_, (Eight | Sixteen)) -> Singleton K.naked_immediate | String_or_bigstring_load (_, Thirty_two) -> Singleton K.naked_int32 + | String_or_bigstring_load (_, Single) -> Singleton K.naked_float32 | String_or_bigstring_load (_, Sixty_four) -> Singleton K.naked_int64 | String_or_bigstring_load (_, One_twenty_eight _) -> Singleton K.naked_vec128 | Bigarray_load (_, kind, _) -> Singleton (Bigarray_kind.element_kind kind) @@ -1774,6 +1784,8 @@ let args_kind_of_ternary_primitive p = string_or_bytes_kind, bytes_or_bigstring_index_kind, K.naked_immediate | Bytes_or_bigstring_set (Bytes, Thirty_two) -> string_or_bytes_kind, bytes_or_bigstring_index_kind, K.naked_int32 + | Bytes_or_bigstring_set (Bytes, Single) -> + string_or_bytes_kind, bytes_or_bigstring_index_kind, K.naked_float32 | Bytes_or_bigstring_set (Bytes, Sixty_four) -> string_or_bytes_kind, bytes_or_bigstring_index_kind, K.naked_int64 | Bytes_or_bigstring_set (Bytes, One_twenty_eight _) -> @@ -1782,6 +1794,8 @@ let args_kind_of_ternary_primitive p = bigstring_kind, bytes_or_bigstring_index_kind, K.naked_immediate | Bytes_or_bigstring_set (Bigstring, Thirty_two) -> bigstring_kind, bytes_or_bigstring_index_kind, K.naked_int32 + | Bytes_or_bigstring_set (Bigstring, Single) -> + bigstring_kind, bytes_or_bigstring_index_kind, K.naked_float32 | Bytes_or_bigstring_set (Bigstring, Sixty_four) -> bigstring_kind, bytes_or_bigstring_index_kind, K.naked_int64 | Bytes_or_bigstring_set (Bigstring, One_twenty_eight _) -> diff --git a/middle_end/flambda2/terms/flambda_primitive.mli b/middle_end/flambda2/terms/flambda_primitive.mli index 58b4af6a287..6fcfbee4ad0 100644 --- a/middle_end/flambda2/terms/flambda_primitive.mli +++ b/middle_end/flambda2/terms/flambda_primitive.mli @@ -206,6 +206,11 @@ type equality_comparison = module Bigarray_kind : sig type t = | Float32 + | Float32_t + (** [Float32_t] is used for bigarrays that contain (unboxed) float32 + values and are read and written to using the [float32] type. This + is in contrast to [Float32] bigarrays, where the accesses are done + at type [float]. *) | Float64 | Sint8 | Uint8 @@ -237,6 +242,7 @@ type string_accessor_width = | Eight | Sixteen | Thirty_two + | Single | Sixty_four | One_twenty_eight of { aligned : bool } diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index bdd893e48a7..5d74c7ea064 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -293,6 +293,7 @@ let string_like_load_aux ~dbg width ~str ~index = | Eight -> C.load ~dbg Byte_unsigned Mutable ~addr:(C.add_int str index dbg) | Sixteen -> C.unaligned_load_16 str index dbg | Thirty_two -> C.sign_extend_32 dbg (C.unaligned_load_32 str index dbg) + | Single -> C.unaligned_load_f32 str index dbg | Sixty_four -> C.unaligned_load_64 str index dbg | One_twenty_eight { aligned = true } -> C.aligned_load_128 str index dbg | One_twenty_eight { aligned = false } -> C.unaligned_load_128 str index dbg @@ -314,6 +315,7 @@ let bytes_or_bigstring_set_aux ~dbg width ~bytes ~index ~new_value = C.store ~dbg Byte_unsigned Assignment ~addr ~new_value | Sixteen -> C.unaligned_set_16 bytes index new_value dbg | Thirty_two -> C.unaligned_set_32 bytes index new_value dbg + | Single -> C.unaligned_set_f32 bytes index new_value dbg | Sixty_four -> C.unaligned_set_64 bytes index new_value dbg | One_twenty_eight { aligned = false } -> C.unaligned_set_128 bytes index new_value dbg diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index 7b110aa7f1b..431f6d6c6c7 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -140,11 +140,15 @@ let preserve_tailcall_for_prim = function | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ - | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ | Pstring_load_128 _ - | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _ - | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ - | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ - | Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_f32 _ + | Pstring_load_64 _ | Pstring_load_128 _ + | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_f32 _ + | Pbytes_load_64 _ | Pbytes_load_128 _ + | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _ + | Pbytes_set_64 _ | Pbytes_set_128 _ + | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_f32 _ + | Pbigstring_load_64 _ | Pbigstring_load_128 _ + | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_f32 _ | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _ | Punboxed_float_array_load_128 _ | Punboxed_int32_array_load_128 _ | Punboxed_int64_array_load_128 _ | Punboxed_nativeint_array_load_128 _ @@ -441,12 +445,15 @@ let comp_primitive stack_info p sz args = | Pbytessetu -> Ksetbyteschar | Pstring_load_16(_) -> Kccall("caml_string_get16", 2) | Pstring_load_32(_) -> Kccall("caml_string_get32", 2) + | Pstring_load_f32(_) -> Kccall("caml_string_getf32", 2) | Pstring_load_64(_) -> Kccall("caml_string_get64", 2) | Pbytes_set_16(_) -> Kccall("caml_bytes_set16", 3) | Pbytes_set_32(_) -> Kccall("caml_bytes_set32", 3) + | Pbytes_set_f32(_) -> Kccall("caml_bytes_setf32", 3) | Pbytes_set_64(_) -> Kccall("caml_bytes_set64", 3) | Pbytes_load_16(_) -> Kccall("caml_bytes_get16", 2) | Pbytes_load_32(_) -> Kccall("caml_bytes_get32", 2) + | Pbytes_load_f32(_) -> Kccall("caml_bytes_getf32", 2) | Pbytes_load_64(_) -> Kccall("caml_bytes_get64", 2) | Parraylength _ -> Kvectlength (* In bytecode, nothing is ever actually stack-allocated, so we ignore the @@ -536,14 +543,18 @@ let comp_primitive stack_info p sz args = | Pbintcomp(_, Cgt) | Punboxed_int_comp(_, Cgt) -> Kccall("caml_greaterthan", 2) | Pbintcomp(_, Cle) | Punboxed_int_comp(_, Cle) -> Kccall("caml_lessequal", 2) | Pbintcomp(_, Cge) | Punboxed_int_comp(_, Cge) -> Kccall("caml_greaterequal", 2) + | Pbigarrayref(_, n, Pbigarray_float32_t, _) -> Kccall("caml_ba_float32_get_" ^ Int.to_string n, n + 1) + | Pbigarrayset(_, n, Pbigarray_float32_t, _) -> Kccall("caml_ba_float32_set_" ^ Int.to_string n, n + 2) | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ Int.to_string n, n + 1) | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ Int.to_string n, n + 2) | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ Int.to_string n, 1) | Pbigstring_load_16(_) -> Kccall("caml_ba_uint8_get16", 2) | Pbigstring_load_32(_) -> Kccall("caml_ba_uint8_get32", 2) + | Pbigstring_load_f32(_) -> Kccall("caml_ba_uint8_getf32", 2) | Pbigstring_load_64(_) -> Kccall("caml_ba_uint8_get64", 2) | Pbigstring_set_16(_) -> Kccall("caml_ba_uint8_set16", 3) | Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3) + | Pbigstring_set_f32(_) -> Kccall("caml_ba_uint8_setf32", 3) | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) | Pbswap16 -> Kccall("caml_bswap16", 1) | Pbbswap(bi,_) -> comp_bint_primitive bi "bswap" args diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 4f31559f70a..8c33dcbc488 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -239,25 +239,30 @@ type primitive = (* load/set 16,32,64,128 bits from a string: (unsafe)*) | Pstring_load_16 of bool | Pstring_load_32 of bool * alloc_mode + | Pstring_load_f32 of bool * alloc_mode | Pstring_load_64 of bool * alloc_mode | Pstring_load_128 of { unsafe : bool; mode: alloc_mode } | Pbytes_load_16 of bool | Pbytes_load_32 of bool * alloc_mode + | Pbytes_load_f32 of bool * alloc_mode | Pbytes_load_64 of bool * alloc_mode | Pbytes_load_128 of { unsafe : bool; mode: alloc_mode } | Pbytes_set_16 of bool | Pbytes_set_32 of bool + | Pbytes_set_f32 of bool | Pbytes_set_64 of bool | Pbytes_set_128 of { unsafe : bool } (* load/set 16,32,64,128 bits from a (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) | Pbigstring_load_16 of { unsafe : bool } | Pbigstring_load_32 of { unsafe : bool; mode: alloc_mode; boxed : bool } + | Pbigstring_load_f32 of { unsafe : bool; mode: alloc_mode; boxed : bool } | Pbigstring_load_64 of { unsafe : bool; mode: alloc_mode; boxed : bool } | Pbigstring_load_128 of { aligned : bool; unsafe : bool; mode: alloc_mode; boxed : bool } | Pbigstring_set_16 of { unsafe : bool } | Pbigstring_set_32 of { unsafe : bool; boxed : bool } + | Pbigstring_set_f32 of { unsafe : bool; boxed : bool } | Pbigstring_set_64 of { unsafe : bool; boxed : bool } | Pbigstring_set_128 of { aligned : bool; unsafe : bool; boxed : bool } (* load/set SIMD vectors in GC-managed arrays *) @@ -425,7 +430,8 @@ and boxed_vector = and bigarray_kind = Pbigarray_unknown - | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_float32 | Pbigarray_float32_t + | Pbigarray_float64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_int32 | Pbigarray_int64 @@ -1751,6 +1757,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function Some alloc_heap | Pstring_load_16 _ | Pbytes_load_16 _ -> None | Pstring_load_32 (_, m) | Pbytes_load_32 (_, m) + | Pstring_load_f32 (_, m) | Pbytes_load_f32 (_, m) | Pstring_load_64 (_, m) | Pbytes_load_64 (_, m) | Pstring_load_128 { mode = m; _ } | Pbytes_load_128 { mode = m; _ } | Pfloatarray_load_128 { mode = m; _ } @@ -1761,15 +1768,18 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Punboxed_int64_array_load_128 { mode = m; _ } | Punboxed_nativeint_array_load_128 { mode = m; _ } | Pget_header m -> Some m - | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ -> None + | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _ + | Pbytes_set_64 _ | Pbytes_set_128 _ -> None | Pbigstring_load_16 _ -> None | Pbigstring_load_32 { mode = m; boxed = true; _ } + | Pbigstring_load_f32 { mode = m; boxed = true; _ } | Pbigstring_load_64 { mode = m; boxed = true; _ } | Pbigstring_load_128 { mode = m; boxed = true; _ } -> Some m | Pbigstring_load_32 { boxed = false; _ } + | Pbigstring_load_f32 { boxed = false; _ } | Pbigstring_load_64 { boxed = false; _ } | Pbigstring_load_128 { boxed = false; _ } -> None - | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_f32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _ | Punboxed_float_array_set_128 _ | Punboxed_int32_array_set_128 _ @@ -1860,8 +1870,9 @@ let primitive_result_layout (p : primitive) = | Pignore | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ | Poffsetref _ | Psetufloatfield _ | Psetmixedfield _ | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _ - | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ - | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ + | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _ | Pbytes_set_64 _ + | Pbytes_set_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_f32 _ + | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _ | Punboxed_float_array_set_128 _ | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ | Punboxed_nativeint_array_set_128 _ @@ -1913,6 +1924,9 @@ let primitive_result_layout (p : primitive) = | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 { boxed = true; _ } -> layout_boxedint Pint32 + | Pstring_load_f32 _ | Pbytes_load_f32 _ + | Pbigstring_load_f32 { boxed = true; _ } -> + layout_boxed_float Pfloat32 | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 { boxed = true; _ } -> layout_boxedint Pint64 @@ -1920,6 +1934,7 @@ let primitive_result_layout (p : primitive) = | Pbigstring_load_128 { boxed = true; _ } -> layout_boxed_vector (Pvec128 Int8x16) | Pbigstring_load_32 { boxed = false; _ } -> layout_unboxed_int Pint32 + | Pbigstring_load_f32 { boxed = false; _ } -> layout_unboxed_float Pfloat32 | Pbigstring_load_64 { boxed = false; _ } -> layout_unboxed_int Pint64 | Pbigstring_load_128 { boxed = false; _ } -> layout_unboxed_vector (Pvec128 Int8x16) @@ -1939,6 +1954,7 @@ let primitive_result_layout (p : primitive) = | Pbigarray_float32 -> (* float32 bigarrays return 64-bit floats for backward compatibility. *) layout_boxed_float Pfloat64 + | Pbigarray_float32_t -> layout_boxed_float Pfloat32 | Pbigarray_float64 -> layout_boxed_float Pfloat64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 330d1e74361..95699b5051d 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -225,25 +225,30 @@ type primitive = (* load/set 16,32,64,128 bits from a string: (unsafe)*) | Pstring_load_16 of bool | Pstring_load_32 of bool * alloc_mode + | Pstring_load_f32 of bool * alloc_mode | Pstring_load_64 of bool * alloc_mode | Pstring_load_128 of { unsafe : bool; mode: alloc_mode } | Pbytes_load_16 of bool | Pbytes_load_32 of bool * alloc_mode + | Pbytes_load_f32 of bool * alloc_mode | Pbytes_load_64 of bool * alloc_mode | Pbytes_load_128 of { unsafe : bool; mode: alloc_mode } | Pbytes_set_16 of bool | Pbytes_set_32 of bool + | Pbytes_set_f32 of bool | Pbytes_set_64 of bool | Pbytes_set_128 of { unsafe : bool } (* load/set 16,32,64,128 bits from a (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) | Pbigstring_load_16 of { unsafe : bool } | Pbigstring_load_32 of { unsafe : bool; mode: alloc_mode; boxed : bool } + | Pbigstring_load_f32 of { unsafe : bool; mode: alloc_mode; boxed : bool } | Pbigstring_load_64 of { unsafe : bool; mode: alloc_mode; boxed : bool } | Pbigstring_load_128 of { aligned : bool; unsafe : bool; mode: alloc_mode; boxed : bool } | Pbigstring_set_16 of { unsafe : bool } | Pbigstring_set_32 of { unsafe : bool; boxed : bool } + | Pbigstring_set_f32 of { unsafe : bool; boxed : bool } | Pbigstring_set_64 of { unsafe : bool; boxed : bool } | Pbigstring_set_128 of { aligned : bool; unsafe : bool; boxed : bool } (* load/set SIMD vectors in GC-managed arrays *) @@ -429,7 +434,8 @@ and boxed_vector = and bigarray_kind = Pbigarray_unknown - | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_float32 | Pbigarray_float32_t + | Pbigarray_float64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_int32 | Pbigarray_int64 diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index 44055f00d72..2c45f920741 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -282,6 +282,7 @@ let print_bigarray name unsafe kind ppf layout = (match kind with | Pbigarray_unknown -> "generic" | Pbigarray_float32 -> "float32" + | Pbigarray_float32_t -> "float32_t" | Pbigarray_float64 -> "float64" | Pbigarray_sint8 -> "sint8" | Pbigarray_uint8 -> "uint8" @@ -643,6 +644,9 @@ let primitive ppf = function | Pstring_load_32(unsafe, m) -> if unsafe then fprintf ppf "string.unsafe_get32%s" (alloc_kind m) else fprintf ppf "string.get32%s" (alloc_kind m) + | Pstring_load_f32(unsafe, m) -> + if unsafe then fprintf ppf "string.unsafe_getf32%s" (alloc_kind m) + else fprintf ppf "string.getf32%s" (alloc_kind m) | Pstring_load_64(unsafe, m) -> if unsafe then fprintf ppf "string.unsafe_get64%s" (alloc_kind m) else fprintf ppf "string.get64%s" (alloc_kind m) @@ -656,6 +660,9 @@ let primitive ppf = function | Pbytes_load_32(unsafe,m) -> if unsafe then fprintf ppf "bytes.unsafe_get32%s" (alloc_kind m) else fprintf ppf "bytes.get32%s" (alloc_kind m) + | Pbytes_load_f32(unsafe,m) -> + if unsafe then fprintf ppf "bytes.unsafe_getf32%s" (alloc_kind m) + else fprintf ppf "bytes.getf32%s" (alloc_kind m) | Pbytes_load_64(unsafe,m) -> if unsafe then fprintf ppf "bytes.unsafe_get64%s" (alloc_kind m) else fprintf ppf "bytes.get64%s" (alloc_kind m) @@ -669,6 +676,9 @@ let primitive ppf = function | Pbytes_set_32(unsafe) -> if unsafe then fprintf ppf "bytes.unsafe_set32" else fprintf ppf "bytes.set32" + | Pbytes_set_f32(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_setf32" + else fprintf ppf "bytes.setf32" | Pbytes_set_64(unsafe) -> if unsafe then fprintf ppf "bytes.unsafe_set64" else fprintf ppf "bytes.set64" @@ -682,6 +692,9 @@ let primitive ppf = function | Pbigstring_load_32 { unsafe; mode = m } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_get32%s" (alloc_kind m) else fprintf ppf "bigarray.array1.get32%s" (alloc_kind m) + | Pbigstring_load_f32 { unsafe; mode = m } -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_getf32%s" (alloc_kind m) + else fprintf ppf "bigarray.array1.getf32%s" (alloc_kind m) | Pbigstring_load_64 { unsafe; mode = m } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_get64%s" (alloc_kind m) else fprintf ppf "bigarray.array1.get64%s" (alloc_kind m) @@ -699,6 +712,9 @@ let primitive ppf = function | Pbigstring_set_32 { unsafe } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" else fprintf ppf "bigarray.array1.set32" + | Pbigstring_set_f32 { unsafe } -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_setf32" + else fprintf ppf "bigarray.array1.setf32" | Pbigstring_set_64 { unsafe } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" else fprintf ppf "bigarray.array1.set64" @@ -877,22 +893,27 @@ let name_of_primitive = function | Pbigarraydim _ -> "Pbigarraydim" | Pstring_load_16 _ -> "Pstring_load_16" | Pstring_load_32 _ -> "Pstring_load_32" + | Pstring_load_f32 _ -> "Pstring_load_f32" | Pstring_load_64 _ -> "Pstring_load_64" | Pstring_load_128 _ -> "Pstring_load_128" | Pbytes_load_16 _ -> "Pbytes_load_16" | Pbytes_load_32 _ -> "Pbytes_load_32" + | Pbytes_load_f32 _ -> "Pbytes_load_f32" | Pbytes_load_64 _ -> "Pbytes_load_64" | Pbytes_load_128 _ -> "Pbytes_load_128" | Pbytes_set_16 _ -> "Pbytes_set_16" | Pbytes_set_32 _ -> "Pbytes_set_32" + | Pbytes_set_f32 _ -> "Pbytes_set_f32" | Pbytes_set_64 _ -> "Pbytes_set_64" | Pbytes_set_128 _ -> "Pbytes_set_128" | Pbigstring_load_16 _ -> "Pbigstring_load_16" | Pbigstring_load_32 _ -> "Pbigstring_load_32" + | Pbigstring_load_f32 _ -> "Pbigstring_load_f32" | Pbigstring_load_64 _ -> "Pbigstring_load_64" | Pbigstring_load_128 _ -> "Pbigstring_load_128" | Pbigstring_set_16 _ -> "Pbigstring_set_16" | Pbigstring_set_32 _ -> "Pbigstring_set_32" + | Pbigstring_set_f32 _ -> "Pbigstring_set_f32" | Pbigstring_set_64 _ -> "Pbigstring_set_64" | Pbigstring_set_128 _ -> "Pbigstring_set_128" | Pfloatarray_load_128 _ -> "Pfloatarray_load_128" diff --git a/ocaml/lambda/tmc.ml b/ocaml/lambda/tmc.ml index 730ee3a7660..09c17fa1d66 100644 --- a/ocaml/lambda/tmc.ml +++ b/ocaml/lambda/tmc.ml @@ -941,11 +941,15 @@ let rec choice ctx t = (* more common cases... *) | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ - | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_64 _ | Pstring_load_128 _ - | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _ - | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ - | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ - | Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pstring_load_16 _ | Pstring_load_32 _ | Pstring_load_f32 _ + | Pstring_load_64 _ | Pstring_load_128 _ + | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_f32 _ + | Pbytes_load_64 _ | Pbytes_load_128 _ + | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _ + | Pbytes_set_64 _ | Pbytes_set_128 _ + | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_f32 _ + | Pbigstring_load_64 _ | Pbigstring_load_128 _ + | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_f32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index 939a5185f89..66e2baf3164 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -490,6 +490,54 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Primitive ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), 5); + | "%caml_ba_float32_ref_1" -> + Primitive + ((Pbigarrayref(false, 1, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 2); + | "%caml_ba_float32_ref_2" -> + Primitive + ((Pbigarrayref(false, 2, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 3); + | "%caml_ba_float32_ref_3" -> + Primitive + ((Pbigarrayref(false, 3, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 4); + | "%caml_ba_float32_set_1" -> + Primitive + ((Pbigarrayset(false, 1, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 3); + | "%caml_ba_float32_set_2" -> + Primitive + ((Pbigarrayset(false, 2, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 4); + | "%caml_ba_float32_set_3" -> + Primitive + ((Pbigarrayset(false, 3, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 5); + | "%caml_ba_float32_unsafe_ref_1" -> + Primitive + ((Pbigarrayref(true, 1, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 2); + | "%caml_ba_float32_unsafe_ref_2" -> + Primitive + ((Pbigarrayref(true, 2, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 3); + | "%caml_ba_float32_unsafe_ref_3" -> + Primitive + ((Pbigarrayref(true, 3, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 4); + | "%caml_ba_float32_unsafe_set_1" -> + Primitive + ((Pbigarrayset(true, 1, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 3); + | "%caml_ba_float32_unsafe_set_2" -> + Primitive + ((Pbigarrayset(true, 2, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 4); + | "%caml_ba_float32_unsafe_set_3" -> + Primitive + ((Pbigarrayset(true, 3, Pbigarray_float32_t, Pbigarray_unknown_layout)), + 5); | "%caml_ba_dim_1" -> Primitive ((Pbigarraydim(1)), 1) | "%caml_ba_dim_2" -> Primitive ((Pbigarraydim(2)), 1) | "%caml_ba_dim_3" -> Primitive ((Pbigarraydim(3)), 1) @@ -497,6 +545,8 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%caml_string_get16u" -> Primitive ((Pstring_load_16(true)), 2) | "%caml_string_get32" -> Primitive ((Pstring_load_32(false, mode)), 2) | "%caml_string_get32u" -> Primitive ((Pstring_load_32(true, mode)), 2) + | "%caml_string_getf32" -> Primitive ((Pstring_load_f32(false, mode)), 2) + | "%caml_string_getf32u" -> Primitive ((Pstring_load_f32(true, mode)), 2) | "%caml_string_get64" -> Primitive ((Pstring_load_64(false, mode)), 2) | "%caml_string_get64u" -> Primitive ((Pstring_load_64(true, mode)), 2) | "%caml_string_getu128" -> @@ -507,6 +557,8 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%caml_string_set16u" -> Primitive ((Pbytes_set_16(true)), 3) | "%caml_string_set32" -> Primitive ((Pbytes_set_32(false)), 3) | "%caml_string_set32u" -> Primitive ((Pbytes_set_32(true)), 3) + | "%caml_string_setf32" -> Primitive ((Pbytes_set_f32(false)), 3) + | "%caml_string_setf32u" -> Primitive ((Pbytes_set_f32(true)), 3) | "%caml_string_set64" -> Primitive ((Pbytes_set_64(false)), 3) | "%caml_string_set64u" -> Primitive ((Pbytes_set_64(true)), 3) | "%caml_string_setu128" -> @@ -517,6 +569,8 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%caml_bytes_get16u" -> Primitive ((Pbytes_load_16(true)), 2) | "%caml_bytes_get32" -> Primitive ((Pbytes_load_32(false, mode)), 2) | "%caml_bytes_get32u" -> Primitive ((Pbytes_load_32(true, mode)), 2) + | "%caml_bytes_getf32" -> Primitive ((Pbytes_load_f32(false, mode)), 2) + | "%caml_bytes_getf32u" -> Primitive ((Pbytes_load_f32(true, mode)), 2) | "%caml_bytes_get64" -> Primitive ((Pbytes_load_64(false, mode)), 2) | "%caml_bytes_get64u" -> Primitive ((Pbytes_load_64(true, mode)), 2) | "%caml_bytes_getu128" -> @@ -527,6 +581,8 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%caml_bytes_set16u" -> Primitive ((Pbytes_set_16(true)), 3) | "%caml_bytes_set32" -> Primitive ((Pbytes_set_32(false)), 3) | "%caml_bytes_set32u" -> Primitive ((Pbytes_set_32(true)), 3) + | "%caml_bytes_setf32" -> Primitive ((Pbytes_set_f32(false)), 3) + | "%caml_bytes_setf32u" -> Primitive ((Pbytes_set_f32(true)), 3) | "%caml_bytes_set64" -> Primitive ((Pbytes_set_64(false)), 3) | "%caml_bytes_set64u" -> Primitive ((Pbytes_set_64(true)), 3) | "%caml_bytes_setu128" -> @@ -541,6 +597,10 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Primitive ((Pbigstring_load_32 { unsafe = false; mode; boxed = true }), 2) | "%caml_bigstring_get32u" -> Primitive ((Pbigstring_load_32 { unsafe = true; mode; boxed = true }), 2) + | "%caml_bigstring_getf32" -> + Primitive ((Pbigstring_load_f32 { unsafe = false; mode; boxed = true }), 2) + | "%caml_bigstring_getf32u" -> + Primitive ((Pbigstring_load_f32 { unsafe = true; mode; boxed = true }), 2) | "%caml_bigstring_get64" -> Primitive ((Pbigstring_load_64 { unsafe = false; mode; boxed = true }), 2) | "%caml_bigstring_get64u" -> @@ -565,6 +625,10 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Primitive ((Pbigstring_set_32 { unsafe = false; boxed = true }), 3) | "%caml_bigstring_set32u" -> Primitive ((Pbigstring_set_32 { unsafe = true; boxed = true }), 3) + | "%caml_bigstring_setf32" -> + Primitive ((Pbigstring_set_f32 { unsafe = false; boxed = true }), 3) + | "%caml_bigstring_setf32u" -> + Primitive ((Pbigstring_set_f32 { unsafe = true; boxed = true }), 3) | "%caml_bigstring_set64" -> Primitive ((Pbigstring_set_64 { unsafe = false; boxed = true }), 3) | "%caml_bigstring_set64u" -> @@ -587,11 +651,18 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%caml_bigstring_get32u#" -> Primitive ((Pbigstring_load_32 { unsafe = true; mode; boxed = false }), 2) + | "%caml_bigstring_getf32#" -> + Primitive ((Pbigstring_load_f32 { unsafe = false; mode; boxed = false }), + 2) + | "%caml_bigstring_getf32u#" -> + Primitive ((Pbigstring_load_f32 { unsafe = true; mode; boxed = false }), + 2) | "%caml_bigstring_get64#" -> Primitive ((Pbigstring_load_64 { unsafe = false; mode; boxed = false }), 2) | "%caml_bigstring_get64u#" -> - Primitive ((Pbigstring_load_64 { unsafe = true; mode; boxed = false }), 2) + Primitive ((Pbigstring_load_64 { unsafe = true; mode; boxed = false }), + 2) | "%caml_bigstring_getu128#" -> Primitive ((Pbigstring_load_128 {aligned = false; unsafe = false; mode; boxed = false }), 2) @@ -608,6 +679,10 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Primitive ((Pbigstring_set_32 { unsafe = false; boxed = false }), 3) | "%caml_bigstring_set32u#" -> Primitive ((Pbigstring_set_32 { unsafe = true; boxed = false }), 3) + | "%caml_bigstring_setf32#" -> + Primitive ((Pbigstring_set_f32 { unsafe = false; boxed = false }), 3) + | "%caml_bigstring_setf32u#" -> + Primitive ((Pbigstring_set_f32 { unsafe = true; boxed = false }), 3) | "%caml_bigstring_set64#" -> Primitive ((Pbigstring_set_64 { unsafe = false; boxed = false }), 3) | "%caml_bigstring_set64u#" -> @@ -660,7 +735,6 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Primitive ((Pfloatarray_set_128 {unsafe = false}), 3) | "%caml_floatarray_set128u" -> Primitive ((Pfloatarray_set_128 {unsafe = true}), 3) - (* CR mslater: (float32) unboxed arrays *) | "%caml_unboxed_float_array_set128" -> Primitive ((Punboxed_float_array_set_128 {unsafe = false}), 3) | "%caml_unboxed_float_array_set128u" -> @@ -1460,11 +1534,13 @@ let lambda_primitive_needs_event_after = function | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ | Punboxed_int_comp _ | Pcompare_bints _ | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ | Pstring_load_16 _ - | Pstring_load_32 _ | Pstring_load_64 _ | Pstring_load_128 _ | Pbytes_load_16 _ - | Pbytes_load_32 _ | Pbytes_load_64 _ | Pbytes_load_128 _ | Pbytes_set_16 _ - | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ | Pbigstring_load_16 _ - | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_load_128 _ - | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ + | Pstring_load_32 _ | Pstring_load_f32 _ | Pstring_load_64 _ | Pstring_load_128 _ + | Pbytes_load_16 _ | Pbytes_load_32 _ | Pbytes_load_f32 _ | Pbytes_load_64 _ + | Pbytes_load_128 _ | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_f32 _ + | Pbytes_set_64 _ | Pbytes_set_128 _ | Pbigstring_load_16 _ + | Pbigstring_load_32 _ | Pbigstring_load_f32 _ | Pbigstring_load_64 _ + | Pbigstring_load_128 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pbigstring_set_f32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _ | Punboxed_float_array_load_128 _ | Punboxed_int32_array_load_128 _ | Punboxed_int64_array_load_128 _ | Punboxed_nativeint_array_load_128 _ diff --git a/ocaml/lambda/value_rec_compiler.ml b/ocaml/lambda/value_rec_compiler.ml index 721a568f97b..001c77b2b3b 100644 --- a/ocaml/lambda/value_rec_compiler.ml +++ b/ocaml/lambda/value_rec_compiler.ml @@ -213,9 +213,11 @@ let compute_static_size lam = | Pbigarrayset _ | Pbytes_set_16 _ | Pbytes_set_32 _ + | Pbytes_set_f32 _ | Pbytes_set_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pbigstring_set_f32 _ | Pbigstring_set_64 _ -> (* Unit-returning primitives. Most of these are only generated from external declarations and not special-cased by [Value_rec_check], @@ -320,12 +322,15 @@ let compute_static_size lam = | Pbigarraydim _ | Pstring_load_16 _ | Pstring_load_32 _ + | Pstring_load_f32 _ | Pstring_load_64 _ | Pbytes_load_16 _ | Pbytes_load_32 _ + | Pbytes_load_f32 _ | Pbytes_load_64 _ | Pbigstring_load_16 _ | Pbigstring_load_32 _ + | Pbigstring_load_f32 _ | Pbigstring_load_64 _ | Pbswap16 | Pbbswap _ diff --git a/ocaml/otherlibs/stdlib_beta/float32.ml b/ocaml/otherlibs/stdlib_beta/float32.ml index bfa26e8d864..33f069e9c37 100644 --- a/ocaml/otherlibs/stdlib_beta/float32.ml +++ b/ocaml/otherlibs/stdlib_beta/float32.ml @@ -300,3 +300,84 @@ external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash_exn" let seeded_hash seed x = seeded_hash_param 10 100 seed x let hash x = seeded_hash_param 10 100 0 x + +module Bytes = struct + external get : bytes -> pos:int -> float32 = "%caml_bytes_getf32" + external unsafe_get : bytes -> pos:int -> float32 = "%caml_bytes_getf32u" + external set : bytes -> pos:int -> float32 -> unit = "%caml_bytes_setf32" + + external unsafe_set : bytes -> pos:int -> float32 -> unit + = "%caml_bytes_setf32u" +end + +module String = struct + external get : string -> pos:int -> float32 = "%caml_string_getf32" + external unsafe_get : string -> pos:int -> float32 = "%caml_string_getf32u" +end + +module Bigstring = struct + open Bigarray + + type t = (char, int8_unsigned_elt, c_layout) Array1.t + + external get : t -> pos:int -> float32 = "%caml_bigstring_getf32" + external unsafe_get : t -> pos:int -> float32 = "%caml_bigstring_getf32u" + external set : t -> pos:int -> float32 -> unit = "%caml_bigstring_setf32" + + external unsafe_set : t -> pos:int -> float32 -> unit + = "%caml_bigstring_setf32u" +end + +module Bigarray = struct + open Bigarray + + module Array1 = struct + external get : ('a, float32_elt, 'c) Array1.t -> int -> float32 + = "%caml_ba_float32_ref_1" + + external set : ('a, float32_elt, 'c) Array1.t -> int -> float32 -> unit + = "%caml_ba_float32_set_1" + + external unsafe_get : ('a, float32_elt, 'c) Array1.t -> int -> float32 + = "%caml_ba_float32_unsafe_ref_1" + + external unsafe_set : + ('a, float32_elt, 'c) Array1.t -> int -> float32 -> unit + = "%caml_ba_float32_unsafe_set_1" + end + + module Array2 = struct + external get : ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 + = "%caml_ba_float32_ref_2" + + external set : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 -> unit + = "%caml_ba_float32_set_2" + + external unsafe_get : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 + = "%caml_ba_float32_unsafe_ref_2" + + external unsafe_set : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 -> unit + = "%caml_ba_float32_unsafe_set_2" + end + + module Array3 = struct + external get : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 + = "%caml_ba_float32_ref_3" + + external set : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 -> unit + = "%caml_ba_float32_set_3" + + external unsafe_get : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 + = "%caml_ba_float32_unsafe_ref_3" + + external unsafe_set : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 -> unit + = "%caml_ba_float32_unsafe_set_3" + end +end diff --git a/ocaml/otherlibs/stdlib_beta/float32.mli b/ocaml/otherlibs/stdlib_beta/float32.mli index 10fa57c795b..8c5078f48cd 100644 --- a/ocaml/otherlibs/stdlib_beta/float32.mli +++ b/ocaml/otherlibs/stdlib_beta/float32.mli @@ -531,3 +531,164 @@ val hash : t -> int (** An unseeded hash function for floats, with the same output value as {!Hashtbl.hash}. This function allows this module to be passed as argument to the functor {!Hashtbl.Make}. *) + +module Bytes : sig + external get : bytes -> pos:int -> float32 = "%caml_bytes_getf32" + (** [get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + external unsafe_get : bytes -> pos:int -> float32 = "%caml_bytes_getf32u" + (** [unsafe_get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) + + external set : bytes -> pos:int -> float32 -> unit = "%caml_bytes_setf32" + (** [set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + external unsafe_set : bytes -> pos:int -> float32 -> unit + = "%caml_bytes_setf32u" + (** [unsafe_set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) +end + +module String : sig + external get : string -> pos:int -> float32 = "%caml_string_getf32" + (** [get s ~pos] loads a float32 from [s] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length s - 4]. *) + + external unsafe_get : string -> pos:int -> float32 = "%caml_string_getf32u" + (** [unsafe_get s ~pos] loads a float32 from [s] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) +end + +module Bigstring : sig + open Bigarray + + type t = (char, int8_unsigned_elt, c_layout) Array1.t + + external get : t -> pos:int -> float32 = "%caml_bigstring_getf32" + (** [get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + external unsafe_get : t -> pos:int -> float32 = "%caml_bigstring_getf32u" + (** [unsafe_get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) + + external set : t -> pos:int -> float32 -> unit = "%caml_bigstring_setf32" + (** [set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + external unsafe_set : t -> pos:int -> float32 -> unit + = "%caml_bigstring_setf32u" + (** [unsafe_set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) +end + +module Bigarray : sig + open Bigarray + + module Array1 : sig + external get : ('a, float32_elt, 'c) Array1.t -> int -> float32 + = "%caml_ba_float32_ref_1" + (** [Array1.get a x], or alternatively [a.{x}], + returns the element of [a] at index [x]. + [x] must be greater or equal than [0] and strictly less than + [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, + [x] must be greater or equal than [1] and less or equal than + [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *) + + external set : ('a, float32_elt, 'c) Array1.t -> int -> float32 -> unit + = "%caml_ba_float32_set_1" + (** [Array1.set a x v], also written [a.{x} <- v], + stores the value [v] at index [x] in [a]. + [x] must be inside the bounds of [a] as described in + {!Bigarray.Array1.get}; + otherwise, [Invalid_argument] is raised. *) + + external unsafe_get : ('a, float32_elt, 'c) Array1.t -> int -> float32 + = "%caml_ba_float32_unsafe_ref_1" + (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed. + Use with caution and only when the program logic guarantees that + the access is within bounds. *) + + external unsafe_set : + ('a, float32_elt, 'c) Array1.t -> int -> float32 -> unit + = "%caml_ba_float32_unsafe_set_1" + (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed. + Use with caution and only when the program logic guarantees that + the access is within bounds. *) + end + + module Array2 : sig + external get : ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 + = "%caml_ba_float32_ref_2" + (** [Array2.get a x y], also written [a.{x,y}], + returns the element of [a] at coordinates ([x], [y]). + [x] and [y] must be within the bounds + of [a], as described for {!Bigarray.Genarray.get}; + otherwise, [Invalid_argument] is raised. *) + + external set : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 -> unit + = "%caml_ba_float32_set_2" + (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], + stores the value [v] at coordinates ([x], [y]) in [a]. + [x] and [y] must be within the bounds of [a], + as described for {!Bigarray.Genarray.set}; + otherwise, [Invalid_argument] is raised. *) + + external unsafe_get : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 + = "%caml_ba_float32_unsafe_ref_2" + (** Like {!Bigarray.Array2.get}, but bounds checking is not always + performed. *) + + external unsafe_set : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32 -> unit + = "%caml_ba_float32_unsafe_set_2" + (** Like {!Bigarray.Array2.set}, but bounds checking is not always + performed. *) + end + + module Array3 : sig + external get : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 + = "%caml_ba_float32_ref_3" + (** [Array3.get a x y z], also written [a.{x,y,z}], + returns the element of [a] at coordinates ([x], [y], [z]). + [x], [y] and [z] must be within the bounds of [a], + as described for {!Bigarray.Genarray.get}; + otherwise, [Invalid_argument] is raised. *) + + external set : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 -> unit + = "%caml_ba_float32_set_3" + (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v], + stores the value [v] at coordinates ([x], [y], [z]) in [a]. + [x], [y] and [z] must be within the bounds of [a], + as described for {!Bigarray.Genarray.set}; + otherwise, [Invalid_argument] is raised. *) + + external unsafe_get : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 + = "%caml_ba_float32_unsafe_ref_3" + (** Like {!Bigarray.Array3.get}, but bounds checking is not always + performed. *) + + external unsafe_set : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32 -> unit + = "%caml_ba_float32_unsafe_set_3" + (** Like {!Bigarray.Array3.set}, but bounds checking is not always + performed. *) + end +end diff --git a/ocaml/otherlibs/stdlib_beta/float32_u.ml b/ocaml/otherlibs/stdlib_beta/float32_u.ml index 8ae6fcea3d5..2c514a690ae 100644 --- a/ocaml/otherlibs/stdlib_beta/float32_u.ml +++ b/ocaml/otherlibs/stdlib_beta/float32_u.ml @@ -203,3 +203,49 @@ let round_down x = of_float32 (Float32.round_down (to_float32 x)) let round_up x = of_float32 (Float32.round_up (to_float32 x)) let round_towards_zero x = of_float32 (Float32.round_towards_zero (to_float32 x)) + +module Bytes = struct + let get bytes ~pos = of_float32 (Float32.Bytes.get bytes ~pos) + let unsafe_get bytes ~pos = of_float32 (Float32.Bytes.unsafe_get bytes ~pos) + let set bytes ~pos x = Float32.Bytes.set bytes ~pos (to_float32 x) + let unsafe_set bytes ~pos x = Float32.Bytes.unsafe_set bytes ~pos (to_float32 x) +end + +module String = struct + let get string ~pos = of_float32 (Float32.String.get string ~pos) + let unsafe_get string ~pos = of_float32 (Float32.String.unsafe_get string ~pos) +end + +module Bigstring = struct + open Bigarray + + type t = (char, int8_unsigned_elt, c_layout) Array1.t + + external get : t -> pos:int -> float32# = "%caml_bigstring_getf32#" + external unsafe_get : t -> pos:int -> float32# = "%caml_bigstring_getf32u#" + external set : t -> pos:int -> float32# -> unit = "%caml_bigstring_setf32#" + external unsafe_set : t -> pos:int -> float32# -> unit = "%caml_bigstring_setf32u#" +end + +module Bigarray = struct + module Array1 = struct + let get ba ix = of_float32 (Float32.Bigarray.Array1.get ba ix) + let set ba ix x = Float32.Bigarray.Array1.set ba ix (to_float32 x) + let unsafe_get ba ix = of_float32 (Float32.Bigarray.Array1.unsafe_get ba ix) + let unsafe_set ba ix x = Float32.Bigarray.Array1.unsafe_set ba ix (to_float32 x) + end + + module Array2 = struct + let get ba ix iy = of_float32 (Float32.Bigarray.Array2.get ba ix iy) + let set ba ix iy x = Float32.Bigarray.Array2.set ba ix iy (to_float32 x) + let unsafe_get ba ix iy = of_float32 (Float32.Bigarray.Array2.unsafe_get ba ix iy) + let unsafe_set ba ix iy x = Float32.Bigarray.Array2.unsafe_set ba ix iy (to_float32 x) + end + + module Array3 = struct + let get ba ix iy iz = of_float32 (Float32.Bigarray.Array3.get ba ix iy iz) + let set ba ix iy iz x = Float32.Bigarray.Array3.set ba ix iy iz (to_float32 x) + let unsafe_get ba ix iy iz = of_float32 (Float32.Bigarray.Array3.unsafe_get ba ix iy iz) + let unsafe_set ba ix iy iz x = Float32.Bigarray.Array3.unsafe_set ba ix iy iz (to_float32 x) + end +end diff --git a/ocaml/otherlibs/stdlib_beta/float32_u.mli b/ocaml/otherlibs/stdlib_beta/float32_u.mli index 0ce0538626f..69e40050944 100644 --- a/ocaml/otherlibs/stdlib_beta/float32_u.mli +++ b/ocaml/otherlibs/stdlib_beta/float32_u.mli @@ -416,3 +416,150 @@ val round_towards_zero : t -> t (* CR layouts v5: add back hash when we deal with the ad-hoc polymorphic functions. *) + +module Bytes : sig + val get : bytes -> pos:int -> float32# + (** [get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + val unsafe_get : bytes -> pos:int -> float32# + (** [unsafe_get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) + + val set : bytes -> pos:int -> float32# -> unit + (** [set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + val unsafe_set : bytes -> pos:int -> float32# -> unit + (** [unsafe_set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) +end + +module String : sig + val get : string -> pos:int -> float32# + (** [get s ~pos] loads a float32 from [s] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length s - 4]. *) + + val unsafe_get : string -> pos:int -> float32# + (** [unsafe_get s ~pos] loads a float32 from [s] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) +end + +module Bigstring : sig + open Bigarray + + type t = (char, int8_unsigned_elt, c_layout) Array1.t + + external get : t -> pos:int -> float32# = "%caml_bigstring_getf32#" + (** [get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + external unsafe_get : t -> pos:int -> float32# = "%caml_bigstring_getf32u#" + (** [unsafe_get b ~pos] loads a float32 from [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) + + external set : t -> pos:int -> float32# -> unit = "%caml_bigstring_setf32#" + (** [set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + + @raise Invalid_argument + if [pos] is outside the range 0 to [length b - 4]. *) + + external unsafe_set : t -> pos:int -> float32# -> unit = "%caml_bigstring_setf32u#" + (** [unsafe_set b ~pos f] stores a float32 to [b] at an offset of [pos] bytes. + Does not check that [pos] is a valid offset. *) +end + +module Bigarray : sig + open Bigarray + + module Array1 : sig + val get : ('a, float32_elt, 'c) Array1.t -> int -> float32# + (** [Array1.get a x], or alternatively [a.{x}], + returns the element of [a] at index [x]. + [x] must be greater or equal than [0] and strictly less than + [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, + [x] must be greater or equal than [1] and less or equal than + [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *) + + val set : ('a, float32_elt, 'c) Array1.t -> int -> float32# -> unit + (** [Array1.set a x v], also written [a.{x} <- v], + stores the value [v] at index [x] in [a]. + [x] must be inside the bounds of [a] as described in + {!Bigarray.Array1.get}; + otherwise, [Invalid_argument] is raised. *) + + val unsafe_get : ('a, float32_elt, 'c) Array1.t -> int -> float32# + (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed. + Use with caution and only when the program logic guarantees that + the access is within bounds. *) + + val unsafe_set : + ('a, float32_elt, 'c) Array1.t -> int -> float32# -> unit + (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed. + Use with caution and only when the program logic guarantees that + the access is within bounds. *) + end + + module Array2 : sig + val get : ('a, float32_elt, 'c) Array2.t -> int -> int -> float32# + (** [Array2.get a x y], also written [a.{x,y}], + returns the element of [a] at coordinates ([x], [y]). + [x] and [y] must be within the bounds + of [a], as described for {!Bigarray.Genarray.get}; + otherwise, [Invalid_argument] is raised. *) + + val set : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32# -> unit + (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], + stores the value [v] at coordinates ([x], [y]) in [a]. + [x] and [y] must be within the bounds of [a], + as described for {!Bigarray.Genarray.set}; + otherwise, [Invalid_argument] is raised. *) + + val unsafe_get : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32# + (** Like {!Bigarray.Array2.get}, but bounds checking is not always + performed. *) + + val unsafe_set : + ('a, float32_elt, 'c) Array2.t -> int -> int -> float32# -> unit + (** Like {!Bigarray.Array2.set}, but bounds checking is not always + performed. *) + end + + module Array3 : sig + val get : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32# + (** [Array3.get a x y z], also written [a.{x,y,z}], + returns the element of [a] at coordinates ([x], [y], [z]). + [x], [y] and [z] must be within the bounds of [a], + as described for {!Bigarray.Genarray.get}; + otherwise, [Invalid_argument] is raised. *) + + val set : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32# -> unit + (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v], + stores the value [v] at coordinates ([x], [y], [z]) in [a]. + [x], [y] and [z] must be within the bounds of [a], + as described for {!Bigarray.Genarray.set}; + otherwise, [Invalid_argument] is raised. *) + + val unsafe_get : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32# + (** Like {!Bigarray.Array3.get}, but bounds checking is not always + performed. *) + + val unsafe_set : + ('a, float32_elt, 'c) Array3.t -> int -> int -> int -> float32# -> unit + (** Like {!Bigarray.Array3.set}, but bounds checking is not always + performed. *) + end +end \ No newline at end of file diff --git a/ocaml/runtime/bigarray.c b/ocaml/runtime/bigarray.c index 4ccedd0c587..d36fbf94835 100644 --- a/ocaml/runtime/bigarray.c +++ b/ocaml/runtime/bigarray.c @@ -525,7 +525,7 @@ CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) are within the bounds and return the offset of the corresponding array element in the data part of the array. */ -static intnat caml_ba_offset(struct caml_ba_array * b, intnat * index) +intnat caml_ba_offset(struct caml_ba_array * b, intnat * index) { intnat offset; int i; diff --git a/ocaml/runtime/float32.c b/ocaml/runtime/float32.c index 6dd946a3ab5..0819327dd91 100644 --- a/ocaml/runtime/float32.c +++ b/ocaml/runtime/float32.c @@ -28,6 +28,7 @@ #include #include "caml/alloc.h" +#include "caml/bigarray.h" #include "caml/fail.h" #include "caml/custom.h" #include "caml/float32.h" @@ -419,6 +420,168 @@ CAMLprim value caml_modf_float32(value f) CAMLreturn (res); } +/* The functions on bytes, strings, and bigstrings (ba_uint8) are only used + in bytecode builds. Otherwise, the flambda-backend compiler translates + the corresponding primitives directly to load/store instructions. */ + +CAMLprim value caml_string_getf32(value str, value index) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(index); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); + float res = *(float*)&Byte_u(str, idx); + return caml_copy_float32(res); +#endif +} + +CAMLprim value caml_bytes_getf32(value str, value index) +{ + return caml_string_getf32(str, index); +} + +CAMLprim value caml_bytes_setf32(value str, value index, value newval) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(index); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); + *(float*)&Byte_u(str, idx) = Float32_val(newval); + return Val_unit; +#endif +} + +CAMLprim value caml_ba_uint8_getf32(value vb, value vind) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(vind); + struct caml_ba_array * b = Caml_ba_array_val(vb); + if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error(); + float res = *(float*)&Byte_u(b->data, idx); + return caml_copy_float32(res); +#endif +} + +CAMLprim value caml_ba_uint8_setf32(value vb, value vind, value newval) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(vind); + struct caml_ba_array * b = Caml_ba_array_val(vb); + if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error(); + *(float*)&Byte_u(b->data, idx) = Float32_val(newval); + return Val_unit; +#endif +} + +/* Defined in bigarray.c */ +CAMLextern intnat caml_ba_offset(struct caml_ba_array * b, intnat * index); + +static value caml_ba_float32_get_aux(value vb, volatile value * vind, int nind) +{ + struct caml_ba_array * b = Caml_ba_array_val(vb); + intnat index[CAML_BA_MAX_NUM_DIMS]; + int i; + intnat offset; + + /* Check number of indices = number of dimensions of array + (maybe not necessary if ML typing guarantees this) */ + if (nind != b->num_dims) + caml_invalid_argument("Float32.Bigarray.get: wrong number of indices"); + /* Compute offset and check bounds */ + for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); + offset = caml_ba_offset(b, index); + /* Perform read */ + switch ((b->flags) & CAML_BA_KIND_MASK) { + case CAML_BA_FLOAT32: + return caml_copy_float32(((float *) b->data)[offset]); + default: + caml_invalid_argument("Float32.Bigarray.get: wrong kind"); + } +} + +CAMLprim value caml_ba_float32_get_1(value vb, value vind1) +{ + return caml_ba_float32_get_aux(vb, &vind1, 1); +} + +CAMLprim value caml_ba_float32_get_2(value vb, value vind1, value vind2) +{ + value vind[2]; + vind[0] = vind1; + vind[1] = vind2; + return caml_ba_float32_get_aux(vb, vind, 2); +} + +CAMLprim value caml_ba_float32_get_3(value vb, value vind1, value vind2, + value vind3) +{ + value vind[3]; + vind[0] = vind1; + vind[1] = vind2; + vind[2] = vind3; + return caml_ba_float32_get_aux(vb, vind, 3); +} + +static value caml_ba_float32_set_aux(value vb, volatile value * vind, + intnat nind, value newval) +{ + struct caml_ba_array * b = Caml_ba_array_val(vb); + intnat index[CAML_BA_MAX_NUM_DIMS]; + int i; + intnat offset; + + /* Check number of indices = number of dimensions of array + (maybe not necessary if ML typing guarantees this) */ + if (nind != b->num_dims) + caml_invalid_argument("Float32.Bigarray.set: wrong number of indices"); + /* Compute offset and check bounds */ + for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); + offset = caml_ba_offset(b, index); + /* Perform write */ + switch (b->flags & CAML_BA_KIND_MASK) { + case CAML_BA_FLOAT32: + ((float *) b->data)[offset] = Float32_val(newval); + break; + default: + caml_invalid_argument("Float32.Bigarray.get: wrong kind"); + } + return Val_unit; +} + +CAMLprim value caml_ba_float32_set_1(value vb, value vind1, value newval) +{ + return caml_ba_float32_set_aux(vb, &vind1, 1, newval); +} + +CAMLprim value caml_ba_float32_set_2(value vb, value vind1, value vind2, + value newval) +{ + value vind[2]; + vind[0] = vind1; + vind[1] = vind2; + return caml_ba_float32_set_aux(vb, vind, 2, newval); +} + +CAMLprim value caml_ba_float32_set_3(value vb, value vind1, value vind2, + value vind3, value newval) +{ + value vind[3]; + vind[0] = vind1; + vind[1] = vind2; + vind[2] = vind3; + return caml_ba_float32_set_aux(vb, vind, 3, newval); +} + /* OCaml runtime itself doesn't call setlocale, i.e. it is using standard "C" locale by default, but it is possible that diff --git a/ocaml/runtime4/bigarray.c b/ocaml/runtime4/bigarray.c index ed4ff67d219..d5f4d88b5e3 100644 --- a/ocaml/runtime4/bigarray.c +++ b/ocaml/runtime4/bigarray.c @@ -524,7 +524,7 @@ CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) are within the bounds and return the offset of the corresponding array element in the data part of the array. */ -static intnat caml_ba_offset(struct caml_ba_array * b, intnat * index) +intnat caml_ba_offset(struct caml_ba_array * b, intnat * index) { intnat offset; int i; diff --git a/ocaml/runtime4/float32.c b/ocaml/runtime4/float32.c index 228492e2540..ed882976b55 100644 --- a/ocaml/runtime4/float32.c +++ b/ocaml/runtime4/float32.c @@ -28,6 +28,7 @@ #include #include "caml/alloc.h" +#include "caml/bigarray.h" #include "caml/fail.h" #include "caml/custom.h" #include "caml/float32.h" @@ -419,6 +420,168 @@ CAMLprim value caml_modf_float32(value f) CAMLreturn (res); } +/* The functions on bytes, strings, and bigstrings (ba_uint8) are only used + in bytecode builds. Otherwise, the flambda-backend compiler translates + the corresponding primitives directly to load/store instructions. */ + +CAMLprim value caml_string_getf32(value str, value index) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(index); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); + float res = *(float*)&Byte_u(str, idx); + return caml_copy_float32(res); +#endif +} + +CAMLprim value caml_bytes_getf32(value str, value index) +{ + return caml_string_getf32(str, index); +} + +CAMLprim value caml_bytes_setf32(value str, value index, value newval) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(index); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); + *(float*)&Byte_u(str, idx) = Float32_val(newval); + return Val_unit; +#endif +} + +CAMLprim value caml_ba_uint8_getf32(value vb, value vind) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(vind); + struct caml_ba_array * b = Caml_ba_array_val(vb); + if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error(); + float res = *(float*)&Byte_u(b->data, idx); + return caml_copy_float32(res); +#endif +} + +CAMLprim value caml_ba_uint8_setf32(value vb, value vind, value newval) +{ +#ifdef ARCH_BIG_ENDIAN + caml_failwith( + "Raw float32 load/store is not supported on big-endian architectures."); +#else + intnat idx = Long_val(vind); + struct caml_ba_array * b = Caml_ba_array_val(vb); + if (idx < 0 || idx >= b->dim[0] - 3) caml_array_bound_error(); + *(float*)&Byte_u(b->data, idx) = Float32_val(newval); + return Val_unit; +#endif +} + +/* Defined in bigarray.c */ +CAMLextern intnat caml_ba_offset(struct caml_ba_array * b, intnat * index); + +static value caml_ba_float32_get_aux(value vb, value * vind, int nind) +{ + struct caml_ba_array * b = Caml_ba_array_val(vb); + intnat index[CAML_BA_MAX_NUM_DIMS]; + int i; + intnat offset; + + /* Check number of indices = number of dimensions of array + (maybe not necessary if ML typing guarantees this) */ + if (nind != b->num_dims) + caml_invalid_argument("Float32.Bigarray.get: wrong number of indices"); + /* Compute offset and check bounds */ + for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); + offset = caml_ba_offset(b, index); + /* Perform read */ + switch ((b->flags) & CAML_BA_KIND_MASK) { + case CAML_BA_FLOAT32: + return caml_copy_float32(((float *) b->data)[offset]); + default: + caml_invalid_argument("Float32.Bigarray.get: wrong kind"); + } +} + +CAMLprim value caml_ba_float32_get_1(value vb, value vind1) +{ + return caml_ba_float32_get_aux(vb, &vind1, 1); +} + +CAMLprim value caml_ba_float32_get_2(value vb, value vind1, value vind2) +{ + value vind[2]; + vind[0] = vind1; + vind[1] = vind2; + return caml_ba_float32_get_aux(vb, vind, 2); +} + +CAMLprim value caml_ba_float32_get_3(value vb, value vind1, value vind2, + value vind3) +{ + value vind[3]; + vind[0] = vind1; + vind[1] = vind2; + vind[2] = vind3; + return caml_ba_float32_get_aux(vb, vind, 3); +} + +static value caml_ba_float32_set_aux(value vb, value * vind, intnat nind, + value newval) +{ + struct caml_ba_array * b = Caml_ba_array_val(vb); + intnat index[CAML_BA_MAX_NUM_DIMS]; + int i; + intnat offset; + + /* Check number of indices = number of dimensions of array + (maybe not necessary if ML typing guarantees this) */ + if (nind != b->num_dims) + caml_invalid_argument("Float32.Bigarray.set: wrong number of indices"); + /* Compute offset and check bounds */ + for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); + offset = caml_ba_offset(b, index); + /* Perform write */ + switch (b->flags & CAML_BA_KIND_MASK) { + case CAML_BA_FLOAT32: + ((float *) b->data)[offset] = Float32_val(newval); + break; + default: + caml_invalid_argument("Float32.Bigarray.get: wrong kind"); + } + return Val_unit; +} + +CAMLprim value caml_ba_float32_set_1(value vb, value vind1, value newval) +{ + return caml_ba_float32_set_aux(vb, &vind1, 1, newval); +} + +CAMLprim value caml_ba_float32_set_2(value vb, value vind1, value vind2, + value newval) +{ + value vind[2]; + vind[0] = vind1; + vind[1] = vind2; + return caml_ba_float32_set_aux(vb, vind, 2, newval); +} + +CAMLprim value caml_ba_float32_set_3(value vb, value vind1, value vind2, + value vind3, value newval) +{ + value vind[3]; + vind[0] = vind1; + vind[1] = vind2; + vind[2] = vind3; + return caml_ba_float32_set_aux(vb, vind, 3, newval); +} + /* OCaml runtime itself doesn't call setlocale, i.e. it is using standard "C" locale by default, but it is possible that diff --git a/ocaml/typing/primitive.ml b/ocaml/typing/primitive.ml index a01f1468852..c5f0aa6353f 100644 --- a/ocaml/typing/primitive.ml +++ b/ocaml/typing/primitive.ml @@ -621,11 +621,21 @@ let prim_has_valid_reprs ~loc prim = Same_as_ocaml_repr Value; Same_as_ocaml_repr Value; Same_as_ocaml_repr Bits32] + | "%caml_bigstring_getf32#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Float32] | "%caml_bigstring_get32u#" -> exactly [ Same_as_ocaml_repr Value; Same_as_ocaml_repr Value; Same_as_ocaml_repr Bits32] + | "%caml_bigstring_getf32u#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Float32] | "%caml_bigstring_get64#" -> exactly [ Same_as_ocaml_repr Value; @@ -649,12 +659,24 @@ let prim_has_valid_reprs ~loc prim = Same_as_ocaml_repr Value; Same_as_ocaml_repr Bits32; Same_as_ocaml_repr Value] + | "%caml_bigstring_setf32#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Float32; + Same_as_ocaml_repr Value] | "%caml_bigstring_set32u#" -> exactly [ Same_as_ocaml_repr Value; Same_as_ocaml_repr Value; Same_as_ocaml_repr Bits32; Same_as_ocaml_repr Value] + | "%caml_bigstring_setf32u#" -> + exactly [ + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Value; + Same_as_ocaml_repr Float32; + Same_as_ocaml_repr Value] | "%caml_bigstring_set64#" -> exactly [ Same_as_ocaml_repr Value; diff --git a/tests/small_numbers/dune b/tests/small_numbers/dune index 00f5b52b7ff..2fe032f2bbe 100644 --- a/tests/small_numbers/dune +++ b/tests/small_numbers/dune @@ -44,6 +44,74 @@ (diff empty.expected float32_lib.out) (diff empty.expected float32_u_lib.out)))) +; Bytecode tests + +(rule + (targets + stubs_bytecode.c + float32_builtin_bytecode.ml + float32_lib_bytecode.ml + float32_u_lib_bytecode.ml) + (deps stubs.c float32_builtin.ml float32_lib.ml float32_u_lib.ml) + (action + (progn + (copy stubs.c stubs_bytecode.c) + (copy float32_builtin.ml float32_builtin_bytecode.ml) + (copy float32_lib.ml float32_lib_bytecode.ml) + (copy float32_u_lib.ml float32_u_lib_bytecode.ml)))) + +(library + (name stubs_bytecode) + (modules) + (foreign_stubs + (language c) + (names stubs_bytecode))) + +(executables + (names float32_builtin_bytecode float32_lib_bytecode float32_u_lib_bytecode) + (modes + (byte exe)) + (modules + float32_builtin_bytecode + float32_lib_bytecode + float32_u_lib_bytecode) + (libraries stdlib_beta stubs_bytecode) + (ocamlc_flags + (:standard -extension-universe beta))) + +(rule + (enabled_if + (= %{context_name} "main")) + (targets + float32_builtin_bytecode.out + float32_lib_bytecode.out + float32_u_lib_bytecode.out) + (deps + float32_builtin_bytecode.exe + float32_lib_bytecode.exe + float32_u_lib_bytecode.exe) + (action + (progn + (with-outputs-to + float32_builtin_bytecode.out + (run ./float32_builtin_bytecode.exe)) + (with-outputs-to + float32_lib_bytecode.out + (run ./float32_lib_bytecode.exe)) + (with-outputs-to + float32_u_lib_bytecode.out + (run ./float32_u_lib_bytecode.exe))))) + +(rule + (alias runtest) + (enabled_if + (= %{context_name} "main")) + (action + (progn + (diff empty.expected float32_builtin_bytecode.out) + (diff empty.expected float32_lib_bytecode.out) + (diff empty.expected float32_u_lib_bytecode.out)))) + ; Tests with nodynlink (rule diff --git a/tests/small_numbers/float32_lib.ml b/tests/small_numbers/float32_lib.ml index 741fab1a45e..feb23c50035 100644 --- a/tests/small_numbers/float32_lib.ml +++ b/tests/small_numbers/float32_lib.ml @@ -1,5 +1,6 @@ [@@@ocaml.warning "-unused-value-declaration"] +[@@@ocaml.warning "-unused-module"] (* Tests for the float32 otherlib *) @@ -488,3 +489,461 @@ let () = (* Cast & sqrt-with-memory intrinsics (see selection.ml) *) bit_eq (F32.of_bits (CF32.to_bits f)) f; ) ;; + +module Bytes = struct + + let data = Bytes.of_string "\x00\x01\x02\x03\x04\x05\x06\x07" + + let low = F32.of_bits 0x03020100l + let high = F32.of_bits 0x07060504l + + (* Getters *) + + let () = + let v = F32.Bytes.get data ~pos:0 in + bit_eq low v; + let v = F32.Bytes.unsafe_get data ~pos:0 in + bit_eq low v; + let v = F32.Bytes.get data ~pos:4 in + bit_eq high v; + let v = F32.Bytes.unsafe_get data ~pos:4 in + bit_eq high v; + ;; + + let () = + for bad = -4 to -1 do + try + let _ = F32.Bytes.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bytes.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; + + (* Setters *) + + let set f pos = + F32.Bytes.set data f ~pos; + let v = F32.Bytes.get data ~pos in + bit_eq f v; + ;; + + let set_unsafe f pos = + F32.Bytes.unsafe_set data f ~pos; + let v = F32.Bytes.get data ~pos in + bit_eq f v; + ;; + + let () = + set (F32.of_bits 0x10101010l) 0; + set (F32.of_bits 0x20202020l) 4; + set_unsafe (F32.of_bits 0x10101010l) 0; + set_unsafe (F32.of_bits 0x20202020l) 4; + Random.init 1234; + for _ = 1 to 1000 do + set (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 5); + set_unsafe (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 5) + done; + ;; + + let () = + let set = F32.of_bits 0xFFFFFFFFl in + for bad = -4 to -1 do + try + let _ = F32.Bytes.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bytes.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; +end + +module String = struct + + let data = "\x00\x01\x02\x03\x04\x05\x06\x07" + + let low = F32.of_bits 0x03020100l + let high = F32.of_bits 0x07060504l + + (* Getters *) + + let () = + let v = F32.String.get data ~pos:0 in + bit_eq low v; + let v = F32.String.unsafe_get data ~pos:0 in + bit_eq low v; + let v = F32.String.get data ~pos:4 in + bit_eq high v; + let v = F32.String.unsafe_get data ~pos:4 in + bit_eq high v; + ;; + + let () = + for bad = -4 to -1 do + try + let _ = F32.String.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.String.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; +end + +module Bigstring = struct + open Bigarray + + let bigstring_of_string s = + let open Stdlib in + let a = Array1.create char c_layout (String.length s) in + for i = 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + + let data = bigstring_of_string "\x00\x01\x02\x03\x04\x05\x06\x07" + + let low = F32.of_bits 0x03020100l + let high = F32.of_bits 0x07060504l + + (* Getters *) + + let () = + let v = F32.Bigstring.get data ~pos:0 in + bit_eq low v; + let v = F32.Bigstring.unsafe_get data ~pos:0 in + bit_eq low v; + let v = F32.Bigstring.get data ~pos:4 in + bit_eq high v; + let v = F32.Bigstring.unsafe_get data ~pos:4 in + bit_eq high v; + ;; + + let () = + for bad = -4 to -1 do + try + let _ = F32.Bigstring.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bigstring.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; + + (* Setters *) + + let set f pos = + F32.Bigstring.set data f ~pos; + let v = F32.Bigstring.get data ~pos in + bit_eq f v; + ;; + + let set_unsafe f pos = + F32.Bigstring.unsafe_set data f ~pos; + let v = F32.Bigstring.get data ~pos in + bit_eq f v; + ;; + + let () = + set (F32.of_bits 0x10101010l) 0; + set (F32.of_bits 0x20202020l) 4; + set_unsafe (F32.of_bits 0x10101010l) 0; + set_unsafe (F32.of_bits 0x20202020l) 4; + Random.init 1234; + for _ = 1 to 1000 do + set (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 5); + set_unsafe (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 5) + done; + ;; + + let () = + let set = F32.of_bits 0xFFFFFFFFl in + for bad = -4 to -1 do + try + let _ = F32.Bigstring.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bigstring.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; +end + +module Bigarray = struct + open Stdlib.Bigarray + + module A1 = struct + let c_array = Array1.init Float32 C_layout 4 Float.of_int + + let f_array = Array1.init Float32 Fortran_layout 4 Float.of_int + + let () = + let v = F32.Bigarray.Array1.get c_array 0 in + bit_eq 0.0s v; + let v = F32.Bigarray.Array1.unsafe_get c_array 0 in + bit_eq 0.0s v; + let v = F32.Bigarray.Array1.get c_array 3 in + bit_eq 3.0s v; + let v = F32.Bigarray.Array1.unsafe_get c_array 3 in + bit_eq 3.0s v; + ;; + + let () = + let v = F32.Bigarray.Array1.get f_array 1 in + bit_eq 1.0s v; + let v = F32.Bigarray.Array1.unsafe_get f_array 1 in + bit_eq 1.0s v; + let v = F32.Bigarray.Array1.get f_array 4 in + bit_eq 4.0s v; + let v = F32.Bigarray.Array1.unsafe_get f_array 4 in + bit_eq 4.0s v; + ;; + + let set array f pos = + F32.Bigarray.Array1.set array pos f; + let v = F32.Bigarray.Array1.get array pos in + bit_eq f v; + ;; + + let set_unsafe array f pos = + F32.Bigarray.Array1.unsafe_set array pos f; + let v = F32.Bigarray.Array1.get array pos in + bit_eq f v; + ;; + + let () = + set c_array (F32.of_bits 0x10101010l) 0; + set c_array (F32.of_bits 0x20202020l) 1; + set_unsafe c_array (F32.of_bits 0x10101010l) 2; + set_unsafe c_array (F32.of_bits 0x20202020l) 3; + Random.init 1234; + for _ = 1 to 1000 do + set c_array (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 4); + set_unsafe c_array (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 4) + done; + set f_array (F32.of_bits 0x10101010l) 1; + set f_array (F32.of_bits 0x20202020l) 2; + set_unsafe f_array (F32.of_bits 0x10101010l) 3; + set_unsafe f_array (F32.of_bits 0x20202020l) 4; + Random.init 1234; + for _ = 1 to 1000 do + set f_array (Random.int32 Int32.max_int |> F32.of_bits) (1 + Random.int 4); + set_unsafe f_array (Random.int32 Int32.max_int |> F32.of_bits) (1 + Random.int 4) + done; + ;; + + let () = + let check f = + try f () |> ignore; assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + check (fun () -> F32.Bigarray.Array1.get c_array (-1)); + check (fun () -> F32.Bigarray.Array1.set c_array (-1) 0.0s); + check (fun () -> F32.Bigarray.Array1.get c_array 4); + check (fun () -> F32.Bigarray.Array1.set c_array 4 0.0s); + check (fun () -> F32.Bigarray.Array1.get f_array 0); + check (fun () -> F32.Bigarray.Array1.set f_array 0 0.0s); + check (fun () -> F32.Bigarray.Array1.get f_array 5); + check (fun () -> F32.Bigarray.Array1.set f_array 5 0.0s); + ;; + end + + module A2 = struct + let c_array = Array2.init Float32 C_layout 4 4 (fun i j -> Float.of_int (i * 4 + j)) + + let f_array = Array2.init Float32 Fortran_layout 4 4 (fun i j -> Float.of_int (i * 4 + j)) + + let () = + let v = F32.Bigarray.Array2.get c_array 0 1 in + bit_eq 1.0s v; + let v = F32.Bigarray.Array2.unsafe_get c_array 0 1 in + bit_eq 1.0s v; + let v = F32.Bigarray.Array2.get c_array 3 2 in + bit_eq 14.0s v; + let v = F32.Bigarray.Array2.unsafe_get c_array 3 2 in + bit_eq 14.0s v; + ;; + + let () = + let v = F32.Bigarray.Array2.get f_array 1 2 in + bit_eq 6.0s v; + let v = F32.Bigarray.Array2.unsafe_get f_array 1 2 in + bit_eq 6.0s v; + let v = F32.Bigarray.Array2.get f_array 4 3 in + bit_eq 19.0s v; + let v = F32.Bigarray.Array2.unsafe_get f_array 4 3 in + bit_eq 19.0s v; + ;; + + let set array f i j = + F32.Bigarray.Array2.set array i j f; + let v = F32.Bigarray.Array2.get array i j in + bit_eq f v; + ;; + + let set_unsafe array f i j = + F32.Bigarray.Array2.unsafe_set array i j f; + let v = F32.Bigarray.Array2.get array i j in + bit_eq f v; + ;; + + let () = + set c_array (F32.of_bits 0x10101010l) 0 1; + set c_array (F32.of_bits 0x20202020l) 1 0; + set_unsafe c_array (F32.of_bits 0x10101010l) 2 3; + set_unsafe c_array (F32.of_bits 0x20202020l) 3 2; + Random.init 1234; + for _ = 1 to 1000 do + set c_array (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 4) (Random.int 4); + set_unsafe c_array (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 4) (Random.int 4) + done; + set f_array (F32.of_bits 0x10101010l) 1 2; + set f_array (F32.of_bits 0x20202020l) 2 1; + set_unsafe f_array (F32.of_bits 0x10101010l) 3 4; + set_unsafe f_array (F32.of_bits 0x20202020l) 4 3; + Random.init 1234; + for _ = 1 to 1000 do + set f_array (Random.int32 Int32.max_int |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4); + set_unsafe f_array (Random.int32 Int32.max_int |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4) + done; + ;; + + let () = + let check f = + try f () |> ignore; assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + check (fun () -> F32.Bigarray.Array2.get c_array (-1) 0); + check (fun () -> F32.Bigarray.Array2.set c_array (-1) 0 0.0s); + check (fun () -> F32.Bigarray.Array2.get c_array 4 0); + check (fun () -> F32.Bigarray.Array2.set c_array 4 0 0.0s); + check (fun () -> F32.Bigarray.Array2.get c_array 0 (-1)); + check (fun () -> F32.Bigarray.Array2.set c_array 0 (-1) 0.0s); + check (fun () -> F32.Bigarray.Array2.get c_array 0 4); + check (fun () -> F32.Bigarray.Array2.set c_array 0 4 0.0s); + check (fun () -> F32.Bigarray.Array2.get f_array 0 1); + check (fun () -> F32.Bigarray.Array2.set f_array 0 1 0.0s); + check (fun () -> F32.Bigarray.Array2.get f_array 5 1); + check (fun () -> F32.Bigarray.Array2.set f_array 5 1 0.0s); + check (fun () -> F32.Bigarray.Array2.get f_array 1 0); + check (fun () -> F32.Bigarray.Array2.set f_array 1 0 0.0s); + check (fun () -> F32.Bigarray.Array2.get f_array 1 5); + check (fun () -> F32.Bigarray.Array2.set f_array 1 5 0.0s); + ;; + end + + module A3 = struct + let c_array = Array3.init Float32 C_layout 4 4 4 (fun i j k -> Float.of_int (i * 16 + j * 4 + k)) + + let f_array = Array3.init Float32 Fortran_layout 4 4 4 (fun i j k -> Float.of_int (i * 16 + j * 4 + k)) + + let () = + let v = F32.Bigarray.Array3.get c_array 0 1 2 in + bit_eq 6.0s v; + let v = F32.Bigarray.Array3.unsafe_get c_array 0 1 2 in + bit_eq 6.0s v; + let v = F32.Bigarray.Array3.get c_array 3 2 1 in + bit_eq 57.0s v; + let v = F32.Bigarray.Array3.unsafe_get c_array 3 2 1 in + bit_eq 57.0s v; + ;; + + let () = + let v = F32.Bigarray.Array3.get f_array 1 2 3 in + bit_eq 27.0s v; + let v = F32.Bigarray.Array3.unsafe_get f_array 1 2 3 in + bit_eq 27.0s v; + let v = F32.Bigarray.Array3.get f_array 4 3 2 in + bit_eq 78.0s v; + let v = F32.Bigarray.Array3.unsafe_get f_array 4 3 2 in + bit_eq 78.0s v; + ;; + + let set array f i j k = + F32.Bigarray.Array3.set array i j k f; + let v = F32.Bigarray.Array3.get array i j k in + bit_eq f v; + ;; + + let set_unsafe array f i j k = + F32.Bigarray.Array3.unsafe_set array i j k f; + let v = F32.Bigarray.Array3.get array i j k in + bit_eq f v; + ;; + + let () = + set c_array (F32.of_bits 0x10101010l) 0 1 2; + set c_array (F32.of_bits 0x20202020l) 2 1 0; + set_unsafe c_array (F32.of_bits 0x10101010l) 1 2 3; + set_unsafe c_array (F32.of_bits 0x20202020l) 3 2 1; + Random.init 1234; + for _ = 1 to 1000 do + set c_array (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 4) (Random.int 4) (Random.int 4); + set_unsafe c_array (Random.int32 Int32.max_int |> F32.of_bits) (Random.int 4) (Random.int 4) (Random.int 4) + done; + set f_array (F32.of_bits 0x10101010l) 1 2 3; + set f_array (F32.of_bits 0x20202020l) 3 2 1; + set_unsafe f_array (F32.of_bits 0x10101010l) 2 3 4; + set_unsafe f_array (F32.of_bits 0x20202020l) 4 3 2; + Random.init 1234; + for _ = 1 to 1000 do + set f_array (Random.int32 Int32.max_int |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4) (1 + Random.int 4); + set_unsafe f_array (Random.int32 Int32.max_int |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4) (1 + Random.int 4) + done; + ;; + + let () = + let check f = + try f () |> ignore; assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + check (fun () -> F32.Bigarray.Array3.get c_array (-1) 0 0); + check (fun () -> F32.Bigarray.Array3.set c_array (-1) 0 0 0.0s); + check (fun () -> F32.Bigarray.Array3.get c_array 4 0 0); + check (fun () -> F32.Bigarray.Array3.set c_array 4 0 0 0.0s); + check (fun () -> F32.Bigarray.Array3.get c_array 0 (-1) 0); + check (fun () -> F32.Bigarray.Array3.set c_array 0 (-1) 0 0.0s); + check (fun () -> F32.Bigarray.Array3.get c_array 0 4 0); + check (fun () -> F32.Bigarray.Array3.set c_array 0 4 0 0.0s); + check (fun () -> F32.Bigarray.Array3.get c_array 0 0 (-1)); + check (fun () -> F32.Bigarray.Array3.set c_array 0 0 (-1) 0.0s); + check (fun () -> F32.Bigarray.Array3.get c_array 0 0 4); + check (fun () -> F32.Bigarray.Array3.set c_array 0 0 4 0.0s); + check (fun () -> F32.Bigarray.Array3.get f_array 0 1 1); + check (fun () -> F32.Bigarray.Array3.set f_array 0 1 1 0.0s); + check (fun () -> F32.Bigarray.Array3.get f_array 5 1 1); + check (fun () -> F32.Bigarray.Array3.set f_array 5 1 1 0.0s); + check (fun () -> F32.Bigarray.Array3.get f_array 1 0 1); + check (fun () -> F32.Bigarray.Array3.set f_array 1 0 1 0.0s); + check (fun () -> F32.Bigarray.Array3.get f_array 1 5 1); + check (fun () -> F32.Bigarray.Array3.set f_array 1 5 1 0.0s); + check (fun () -> F32.Bigarray.Array3.get f_array 1 1 0); + check (fun () -> F32.Bigarray.Array3.set f_array 1 1 0 0.0s); + check (fun () -> F32.Bigarray.Array3.get f_array 1 1 5); + check (fun () -> F32.Bigarray.Array3.set f_array 1 1 5 0.0s); + ;; + end +end + diff --git a/tests/small_numbers/float32_u_lib.ml b/tests/small_numbers/float32_u_lib.ml index c0ffcac54a1..fa993773c60 100644 --- a/tests/small_numbers/float32_u_lib.ml +++ b/tests/small_numbers/float32_u_lib.ml @@ -1,5 +1,6 @@ [@@@ocaml.warning "-unused-value-declaration"] +[@@@ocaml.warning "-unused-module"] (* Tests for the float32 otherlib *) @@ -370,3 +371,473 @@ let () = check "0x1.00000200000000000001p+0" #0x1.00000200000000000001p+0s; check "0x1.000003p+0" #0x1.000003p+0s; ;; + +module Bytes = struct + + let data = Bytes.of_string "\x00\x01\x02\x03\x04\x05\x06\x07" + + let low = F32.of_bits #0x03020100l |> F32.to_float32 + let high = F32.of_bits #0x07060504l |> F32.to_float32 + + (* Getters *) + + let () = + let v = F32.Bytes.get data ~pos:0 in + bit_eq v low; + let v = F32.Bytes.unsafe_get data ~pos:0 in + bit_eq v low; + let v = F32.Bytes.get data ~pos:4 in + bit_eq v high; + let v = F32.Bytes.unsafe_get data ~pos:4 in + bit_eq v high; + ;; + + let () = + for bad = -4 to -1 do + try + let _ = F32.Bytes.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bytes.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; + + (* Setters *) + + let set f pos = + F32.Bytes.set data f ~pos; + let v = F32.Bytes.get data ~pos in + bit_eq v (F32.to_float32 f); + ;; + + let set_unsafe f pos = + F32.Bytes.unsafe_set data f ~pos; + let v = F32.Bytes.get data ~pos in + bit_eq v (F32.to_float32 f); + ;; + + let () = + set (F32.of_bits #0x10101010l) 0; + set (F32.of_bits #0x20202020l) 4; + set_unsafe (F32.of_bits #0x10101010l) 0; + set_unsafe (F32.of_bits #0x20202020l) 4; + Random.init 1234; + for _ = 1 to 1000 do + set (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 5); + set_unsafe (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 5) + done; + ;; + + let () = + let set = F32.of_bits #0xFFFFFFFFl in + for bad = -4 to -1 do + try + let _ = F32.Bytes.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bytes.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; +end + +module String = struct + + let data = "\x00\x01\x02\x03\x04\x05\x06\x07" + + let low = F32.of_bits #0x03020100l |> F32.to_float32 + let high = F32.of_bits #0x07060504l |> F32.to_float32 + + (* Getters *) + + let () = + let v = F32.String.get data ~pos:0 in + bit_eq v low; + let v = F32.String.unsafe_get data ~pos:0 in + bit_eq v low; + let v = F32.String.get data ~pos:4 in + bit_eq v high; + let v = F32.String.unsafe_get data ~pos:4 in + bit_eq v high; + ;; + + let () = + for bad = -4 to -1 do + try + let _ = F32.String.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.String.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; +end + +module Bigstring = struct + open Bigarray + + let bigstring_of_string s = + let open Stdlib in + let a = Array1.create char c_layout (String.length s) in + for i = 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + + let data = bigstring_of_string "\x00\x01\x02\x03\x04\x05\x06\x07" + + let low = F32.of_bits #0x03020100l |> F32.to_float32 + let high = F32.of_bits #0x07060504l |> F32.to_float32 + + (* Getters *) + + let () = + let v = F32.Bigstring.get data ~pos:0 in + bit_eq v low; + let v = F32.Bigstring.unsafe_get data ~pos:0 in + bit_eq v low; + let v = F32.Bigstring.get data ~pos:4 in + bit_eq v high; + let v = F32.Bigstring.unsafe_get data ~pos:4 in + bit_eq v high; + ;; + + let () = + for bad = -4 to -1 do + try + let _ = F32.Bigstring.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bigstring.get data ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; + + (* Setters *) + + let set f pos = + F32.Bigstring.set data f ~pos; + let v = F32.Bigstring.get data ~pos in + bit_eq v (F32.to_float32 f); + ;; + + let set_unsafe f pos = + F32.Bigstring.unsafe_set data f ~pos; + let v = F32.Bigstring.get data ~pos in + bit_eq v (F32.to_float32 f); + ;; + + let () = + set (F32.of_bits #0x10101010l) 0; + set (F32.of_bits #0x20202020l) 4; + set_unsafe (F32.of_bits #0x10101010l) 0; + set_unsafe (F32.of_bits #0x20202020l) 4; + Random.init 1234; + for _ = 1 to 1000 do + set (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 5); + set_unsafe (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 5) + done; + ;; + + let () = + let set = F32.of_bits #0xFFFFFFFFl in + for bad = -4 to -1 do + try + let _ = F32.Bigstring.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + for bad = 5 to 9 do + try + let _ = F32.Bigstring.set data set ~pos:bad in + assert false + with | Invalid_argument s when s = "index out of bounds" -> () + done; + ;; +end + +module Bigarray = struct + open Stdlib.Bigarray + + module A1 = struct + let c_array = Array1.init Float32 C_layout 4 Float.of_int + + let f_array = Array1.init Float32 Fortran_layout 4 Float.of_int + + let () = + let v = F32.Bigarray.Array1.get c_array 0 in + bit_eq v 0.0s; + let v = F32.Bigarray.Array1.unsafe_get c_array 0 in + bit_eq v 0.0s; + let v = F32.Bigarray.Array1.get c_array 3 in + bit_eq v 3.0s; + let v = F32.Bigarray.Array1.unsafe_get c_array 3 in + bit_eq v 3.0s; + ;; + + let () = + let v = F32.Bigarray.Array1.get f_array 1 in + bit_eq v 1.0s; + let v = F32.Bigarray.Array1.unsafe_get f_array 1 in + bit_eq v 1.0s; + let v = F32.Bigarray.Array1.get f_array 4 in + bit_eq v 4.0s; + let v = F32.Bigarray.Array1.unsafe_get f_array 4 in + bit_eq v 4.0s; + ;; + + let set array f pos = + F32.Bigarray.Array1.set array pos f; + let v = F32.Bigarray.Array1.get array pos in + bit_eq v (F32.to_float32 f); + ;; + + let set_unsafe array f pos = + F32.Bigarray.Array1.unsafe_set array pos f; + let v = F32.Bigarray.Array1.get array pos in + bit_eq v (F32.to_float32 f); + ;; + + let () = + set c_array (F32.of_bits #0x10101010l) 0; + set c_array (F32.of_bits #0x20202020l) 1; + set_unsafe c_array (F32.of_bits #0x10101010l) 2; + set_unsafe c_array (F32.of_bits #0x20202020l) 3; + Random.init 1234; + for _ = 1 to 1000 do + set c_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 4); + set_unsafe c_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 4) + done; + set f_array (F32.of_bits #0x10101010l) 1; + set f_array (F32.of_bits #0x20202020l) 2; + set_unsafe f_array (F32.of_bits #0x10101010l) 3; + set_unsafe f_array (F32.of_bits #0x20202020l) 4; + Random.init 1234; + for _ = 1 to 1000 do + set f_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (1 + Random.int 4); + set_unsafe f_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (1 + Random.int 4) + done; + ;; + + let () = + let checks f = + try f (); assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + let checkg f = + try f () |> F32.to_float32 |> ignore; assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + checkg (fun () -> F32.Bigarray.Array1.get c_array (-1)); + checks (fun () -> F32.Bigarray.Array1.set c_array (-1) #0.0s); + checkg (fun () -> F32.Bigarray.Array1.get c_array 4); + checks (fun () -> F32.Bigarray.Array1.set c_array 4 #0.0s); + checkg (fun () -> F32.Bigarray.Array1.get f_array 0); + checks (fun () -> F32.Bigarray.Array1.set f_array 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array1.get f_array 5); + checks (fun () -> F32.Bigarray.Array1.set f_array 5 #0.0s); + ;; + end + + module A2 = struct + let c_array = Array2.init Float32 C_layout 4 4 (fun i j -> Float.of_int (i * 4 + j)) + + let f_array = Array2.init Float32 Fortran_layout 4 4 (fun i j -> Float.of_int (i * 4 + j)) + + let () = + let v = F32.Bigarray.Array2.get c_array 0 1 in + bit_eq v 1.0s; + let v = F32.Bigarray.Array2.unsafe_get c_array 0 1 in + bit_eq v 1.0s; + let v = F32.Bigarray.Array2.get c_array 3 2 in + bit_eq v 14.0s; + let v = F32.Bigarray.Array2.unsafe_get c_array 3 2 in + bit_eq v 14.0s; + ;; + + let () = + let v = F32.Bigarray.Array2.get f_array 1 2 in + bit_eq v 6.0s; + let v = F32.Bigarray.Array2.unsafe_get f_array 1 2 in + bit_eq v 6.0s; + let v = F32.Bigarray.Array2.get f_array 4 3 in + bit_eq v 19.0s; + let v = F32.Bigarray.Array2.unsafe_get f_array 4 3 in + bit_eq v 19.0s; + ;; + + let set array f i j = + F32.Bigarray.Array2.set array i j f; + let v = F32.Bigarray.Array2.get array i j in + bit_eq v (F32.to_float32 f); + ;; + + let set_unsafe array f i j = + F32.Bigarray.Array2.unsafe_set array i j f; + let v = F32.Bigarray.Array2.get array i j in + bit_eq v (F32.to_float32 f); + ;; + + let () = + set c_array (F32.of_bits #0x10101010l) 0 1; + set c_array (F32.of_bits #0x20202020l) 1 0; + set_unsafe c_array (F32.of_bits #0x10101010l) 2 3; + set_unsafe c_array (F32.of_bits #0x20202020l) 3 2; + Random.init 1234; + for _ = 1 to 1000 do + set c_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 4) (Random.int 4); + set_unsafe c_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 4) (Random.int 4) + done; + set f_array (F32.of_bits #0x10101010l) 1 2; + set f_array (F32.of_bits #0x20202020l) 2 1; + set_unsafe f_array (F32.of_bits #0x10101010l) 3 4; + set_unsafe f_array (F32.of_bits #0x20202020l) 4 3; + Random.init 1234; + for _ = 1 to 1000 do + set f_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4); + set_unsafe f_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4) + done; + ;; + + let () = + let checks f = + try f (); assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + let checkg f = + try f () |> F32.to_float32 |> ignore; assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + checkg (fun () -> F32.Bigarray.Array2.get c_array (-1) 0); + checks (fun () -> F32.Bigarray.Array2.set c_array (-1) 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get c_array 4 0); + checks (fun () -> F32.Bigarray.Array2.set c_array 4 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get c_array 0 (-1)); + checks (fun () -> F32.Bigarray.Array2.set c_array 0 (-1) #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get c_array 0 4); + checks (fun () -> F32.Bigarray.Array2.set c_array 0 4 #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get f_array 0 1); + checks (fun () -> F32.Bigarray.Array2.set f_array 0 1 #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get f_array 5 1); + checks (fun () -> F32.Bigarray.Array2.set f_array 5 1 #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get f_array 1 0); + checks (fun () -> F32.Bigarray.Array2.set f_array 1 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array2.get f_array 1 5); + checks (fun () -> F32.Bigarray.Array2.set f_array 1 5 #0.0s); + ;; + end + + module A3 = struct + let c_array = Array3.init Float32 C_layout 4 4 4 (fun i j k -> Float.of_int (i * 16 + j * 4 + k)) + + let f_array = Array3.init Float32 Fortran_layout 4 4 4 (fun i j k -> Float.of_int (i * 16 + j * 4 + k)) + + let () = + let v = F32.Bigarray.Array3.get c_array 0 1 2 in + bit_eq v 6.0s; + let v = F32.Bigarray.Array3.unsafe_get c_array 0 1 2 in + bit_eq v 6.0s; + let v = F32.Bigarray.Array3.get c_array 3 2 1 in + bit_eq v 57.0s; + let v = F32.Bigarray.Array3.unsafe_get c_array 3 2 1 in + bit_eq v 57.0s; + ;; + + let () = + let v = F32.Bigarray.Array3.get f_array 1 2 3 in + bit_eq v 27.0s; + let v = F32.Bigarray.Array3.unsafe_get f_array 1 2 3 in + bit_eq v 27.0s; + let v = F32.Bigarray.Array3.get f_array 4 3 2 in + bit_eq v 78.0s; + let v = F32.Bigarray.Array3.unsafe_get f_array 4 3 2 in + bit_eq v 78.0s; + ;; + + let set array f i j k = + F32.Bigarray.Array3.set array i j k f; + let v = F32.Bigarray.Array3.get array i j k in + bit_eq v (F32.to_float32 f); + ;; + + let set_unsafe array f i j k = + F32.Bigarray.Array3.unsafe_set array i j k f; + let v = F32.Bigarray.Array3.get array i j k in + bit_eq v (F32.to_float32 f); + ;; + + let () = + set c_array (F32.of_bits #0x10101010l) 0 1 2; + set c_array (F32.of_bits #0x20202020l) 2 1 0; + set_unsafe c_array (F32.of_bits #0x10101010l) 1 2 3; + set_unsafe c_array (F32.of_bits #0x20202020l) 3 2 1; + Random.init 1234; + for _ = 1 to 1000 do + set c_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 4) (Random.int 4) (Random.int 4); + set_unsafe c_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (Random.int 4) (Random.int 4) (Random.int 4) + done; + set f_array (F32.of_bits #0x10101010l) 1 2 3; + set f_array (F32.of_bits #0x20202020l) 3 2 1; + set_unsafe f_array (F32.of_bits #0x10101010l) 2 3 4; + set_unsafe f_array (F32.of_bits #0x20202020l) 4 3 2; + Random.init 1234; + for _ = 1 to 1000 do + set f_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4) (1 + Random.int 4); + set_unsafe f_array (Random.int32 Int32.max_int |> unbox_int32 |> F32.of_bits) (1 + Random.int 4) (1 + Random.int 4) (1 + Random.int 4) + done; + ;; + + let () = + let checks f = + try f (); assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + let checkg f = + try f () |> F32.to_float32 |> ignore; assert false + with | Invalid_argument s when s = "index out of bounds" -> () + in + checkg (fun () -> F32.Bigarray.Array3.get c_array (-1) 0 0); + checks (fun () -> F32.Bigarray.Array3.set c_array (-1) 0 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get c_array 4 0 0); + checks (fun () -> F32.Bigarray.Array3.set c_array 4 0 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get c_array 0 (-1) 0); + checks (fun () -> F32.Bigarray.Array3.set c_array 0 (-1) 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get c_array 0 4 0); + checks (fun () -> F32.Bigarray.Array3.set c_array 0 4 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get c_array 0 0 (-1)); + checks (fun () -> F32.Bigarray.Array3.set c_array 0 0 (-1) #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get c_array 0 0 4); + checks (fun () -> F32.Bigarray.Array3.set c_array 0 0 4 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get f_array 0 1 1); + checks (fun () -> F32.Bigarray.Array3.set f_array 0 1 1 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get f_array 5 1 1); + checks (fun () -> F32.Bigarray.Array3.set f_array 5 1 1 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get f_array 1 0 1); + checks (fun () -> F32.Bigarray.Array3.set f_array 1 0 1 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get f_array 1 5 1); + checks (fun () -> F32.Bigarray.Array3.set f_array 1 5 1 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get f_array 1 1 0); + checks (fun () -> F32.Bigarray.Array3.set f_array 1 1 0 #0.0s); + checkg (fun () -> F32.Bigarray.Array3.get f_array 1 1 5); + checks (fun () -> F32.Bigarray.Array3.set f_array 1 1 5 #0.0s); + ;; + end +end + diff --git a/tests/small_numbers/stubs.c b/tests/small_numbers/stubs.c index 17c2db69709..561d1c9559c 100644 --- a/tests/small_numbers/stubs.c +++ b/tests/small_numbers/stubs.c @@ -86,8 +86,10 @@ value float32_sign_bit(float f) { return Val_bool(signbit(f)); } value float32_bits_to_int_boxed(value f) { return caml_copy_int32(*(int32_t *)&Float32_val(f)); } value float32_of_int_boxed(value i) { return caml_copy_float32((float)Long_val(i)); } +value float32_of_int64_boxed(value i) { return caml_copy_float32((float)Int64_val(i)); } value float32_of_float_boxed(value d) { return caml_copy_float32((float)Double_val(d)); } value float32_to_int_boxed(value f) { return Val_int((intnat)Float32_val(f)); } +value float32_to_int64_boxed(value f) { return caml_copy_int64((int64_t)Float32_val(f)); } value float32_to_float_boxed(value f) { return caml_copy_double((double)Float32_val(f)); } value float32_zero_boxed(value unit) { return caml_copy_float32(0.0f); } value float32_neg_zero_boxed(value unit) { return caml_copy_float32(-0.0f); }