diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 664d3f972b0..31b38eda6bc 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -580,13 +580,13 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbytes_set_32 false | Pbytes_set_64 false | Pbytes_set_128 { unsafe = false; _ } - | Pbigstring_load_16 false - | Pbigstring_load_32 (false, _) - | Pbigstring_load_64 (false, _) + | Pbigstring_load_16 { unsafe = false } + | Pbigstring_load_32 { unsafe = false; mode = _; boxed = _ } + | Pbigstring_load_64 { unsafe = false; mode = _; boxed = _ } | Pbigstring_load_128 { unsafe = false; _ } - | Pbigstring_set_16 false - | Pbigstring_set_32 false - | Pbigstring_set_64 false + | Pbigstring_set_16 { unsafe = false } + | Pbigstring_set_32 { unsafe = false; boxed = _ } + | Pbigstring_set_64 { unsafe = false; boxed = _ } | Pbigstring_set_128 { unsafe = false; _ } | Pdivbint { is_safe = Safe; _ } | Pmodbint { is_safe = Safe; _ } @@ -645,13 +645,13 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbytes_set_32 true | Pbytes_set_64 true | Pbytes_set_128 { unsafe = true; _ } - | Pbigstring_load_16 true - | Pbigstring_load_32 (true, _) - | Pbigstring_load_64 (true, _) + | Pbigstring_load_16 { unsafe = true } + | Pbigstring_load_32 { unsafe = true; mode = _; boxed = _ } + | Pbigstring_load_64 { unsafe = true; mode = _; boxed = _ } | Pbigstring_load_128 { unsafe = true; _ } - | Pbigstring_set_16 true - | Pbigstring_set_32 true - | Pbigstring_set_64 true + | Pbigstring_set_16 { unsafe = true } + | Pbigstring_set_32 { unsafe = true; boxed = _ } + | Pbigstring_set_64 { unsafe = true; boxed = _ } | Pbigstring_set_128 { unsafe = true; _ } | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ | Popaque _ | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic _ | Pbox_float _ | Punbox_float 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 430253a1b35..e657de0ecc3 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -479,14 +479,19 @@ let checked_bigstring_access ~dbg ~size_int ~access_size ~primitive arg1 arg2 = [bigstring_access_validity_condition ~size_int arg1 access_size arg2] (* String-like loads *) -let string_like_load_unsafe ~access_size kind mode string index ~current_region - = +let string_like_load_unsafe ~access_size kind mode ~boxed string index + ~current_region = let wrap = match (access_size : Flambda_primitive.string_accessor_width), mode with - | (Eight | Sixteen), None -> tag_int - | Thirty_two, Some mode -> box_bint Pint32 mode ~current_region - | Sixty_four, Some mode -> box_bint Pint64 mode ~current_region - | One_twenty_eight _, Some mode -> box_vec128 mode ~current_region + | (Eight | Sixteen), None -> + assert (not boxed); + tag_int + | Thirty_two, Some mode -> + if boxed then box_bint Pint32 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 -> Misc.fatal_error "Inconsistent alloc_mode for string or bytes load" @@ -497,51 +502,55 @@ let get_header obj mode ~current_region = let wrap hd = box_bint Pnativeint mode hd ~current_region in wrap (Unary (Get_header, obj)) -let string_like_load_safe ~dbg ~size_int ~access_size kind mode str index +let string_like_load_safe ~dbg ~size_int ~access_size kind mode ~boxed str index ~current_region = match (kind : P.string_like_value) with | String -> checked_string_or_bytes_access ~dbg ~size_int ~access_size String ~primitive: - (string_like_load_unsafe ~access_size String mode str index + (string_like_load_unsafe ~access_size String mode ~boxed str index ~current_region) str index | Bytes -> checked_string_or_bytes_access ~dbg ~size_int ~access_size Bytes ~primitive: - (string_like_load_unsafe ~access_size Bytes mode str index + (string_like_load_unsafe ~access_size Bytes mode ~boxed str index ~current_region) str index | Bigstring -> checked_bigstring_access ~dbg ~size_int ~access_size ~primitive: - (string_like_load_unsafe ~access_size Bigstring mode str index + (string_like_load_unsafe ~access_size Bigstring mode ~boxed str index ~current_region) str index (* Bytes-like set *) -let bytes_like_set_unsafe ~access_size kind bytes index new_value = +let bytes_like_set_unsafe ~access_size kind ~boxed bytes index new_value = let wrap = match (access_size : Flambda_primitive.string_accessor_width) with - | Eight | Sixteen -> untag_int - | Thirty_two -> unbox_bint Pint32 - | Sixty_four -> unbox_bint Pint64 - | One_twenty_eight _ -> unbox_vec128 + | Eight | Sixteen -> + assert (not boxed); + untag_int + | Thirty_two -> if boxed then unbox_bint Pint32 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 H.Ternary (Bytes_or_bigstring_set (kind, access_size), bytes, index, wrap new_value) -let bytes_like_set_safe ~dbg ~size_int ~access_size kind bytes index new_value = +let bytes_like_set_safe ~dbg ~size_int ~access_size kind ~boxed bytes index + new_value = match (kind : P.bytes_like_value) with | Bytes -> checked_string_or_bytes_access ~dbg ~size_int ~access_size Bytes ~primitive: - (bytes_like_set_unsafe ~access_size Bytes bytes index new_value) + (bytes_like_set_unsafe ~access_size Bytes ~boxed bytes index new_value) bytes index | Bigstring -> checked_bigstring_access ~dbg ~size_int ~access_size ~primitive: - (bytes_like_set_unsafe ~access_size Bigstring bytes index new_value) + (bytes_like_set_unsafe ~access_size Bigstring ~boxed bytes index + new_value) bytes index (* Bigarray accesses *) @@ -1041,92 +1050,95 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pstringlength, [[arg]] -> [tag_int (Unary (String_length String, arg))] | Pbyteslength, [[arg]] -> [tag_int (Unary (String_length Bytes, arg))] | Pstringrefu, [[str]; [index]] -> - [ string_like_load_unsafe ~access_size:Eight String None str index - ~current_region ] + [ string_like_load_unsafe ~access_size:Eight String None ~boxed:false str + index ~current_region ] | Pbytesrefu, [[bytes]; [index]] -> - [ string_like_load_unsafe ~access_size:Eight Bytes None bytes index - ~current_region ] - | Pstringrefs, [[str]; [index]] -> - [ string_like_load_safe ~dbg ~size_int ~access_size:Eight String None str + [ string_like_load_unsafe ~access_size:Eight Bytes None ~boxed:false bytes index ~current_region ] + | Pstringrefs, [[str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Eight String + ~boxed:false None str index ~current_region ] | Pbytesrefs, [[bytes]; [index]] -> - [ string_like_load_safe ~dbg ~size_int ~access_size:Eight Bytes None bytes - index ~current_region ] + [ string_like_load_safe ~dbg ~size_int ~access_size:Eight Bytes ~boxed:false + None bytes index ~current_region ] | Pstring_load_16 true (* unsafe *), [[str]; [index]] -> - [ string_like_load_unsafe ~access_size:Sixteen String None str index - ~current_region ] + [ string_like_load_unsafe ~access_size:Sixteen String ~boxed:false None str + index ~current_region ] | Pbytes_load_16 true (* unsafe *), [[bytes]; [index]] -> - [ string_like_load_unsafe ~access_size:Sixteen Bytes None bytes index - ~current_region ] - | Pstring_load_32 (true (* unsafe *), mode), [[str]; [index]] -> - [ string_like_load_unsafe ~access_size:Thirty_two String (Some mode) str + [ string_like_load_unsafe ~access_size:Sixteen Bytes ~boxed:false None bytes index ~current_region ] + | 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 ] | Pbytes_load_32 (true (* unsafe *), mode), [[bytes]; [index]] -> - [ string_like_load_unsafe ~access_size:Thirty_two Bytes (Some mode) bytes - index ~current_region ] + [ string_like_load_unsafe ~access_size:Thirty_two 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 (Some mode) str - index ~current_region ] + [ string_like_load_unsafe ~access_size:Sixty_four String ~boxed:true + (Some mode) str index ~current_region ] | Pbytes_load_64 (true (* unsafe *), mode), [[bytes]; [index]] -> - [ string_like_load_unsafe ~access_size:Sixty_four Bytes (Some mode) bytes - index ~current_region ] + [ string_like_load_unsafe ~access_size:Sixty_four Bytes ~boxed:true + (Some mode) bytes index ~current_region ] | Pstring_load_128 { unsafe = true; mode }, [[str]; [index]] -> [ string_like_load_unsafe ~access_size:(One_twenty_eight { aligned = false }) - String (Some mode) str index ~current_region ] + String ~boxed:true (Some mode) str index ~current_region ] | Pbytes_load_128 { unsafe = true; mode }, [[str]; [index]] -> [ string_like_load_unsafe ~access_size:(One_twenty_eight { aligned = false }) - Bytes (Some mode) str index ~current_region ] + Bytes ~boxed:true (Some mode) str index ~current_region ] | Pstring_load_16 false (* safe *), [[str]; [index]] -> - [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen String None str - index ~current_region ] + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen String + ~boxed:false None str index ~current_region ] | Pstring_load_32 (false (* safe *), mode), [[str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two String - (Some mode) str index ~current_region ] + (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) str index ~current_region ] + (Some mode) ~boxed:true str index ~current_region ] | Pstring_load_128 { unsafe = false; mode }, [[str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:(One_twenty_eight { aligned = false }) - String (Some mode) str index ~current_region ] + String (Some mode) ~boxed:true str index ~current_region ] | Pbytes_load_16 false (* safe *), [[bytes]; [index]] -> - [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bytes None bytes - index ~current_region ] + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bytes + ~boxed:false None bytes index ~current_region ] | Pbytes_load_32 (false (* safe *), mode), [[bytes]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bytes - (Some mode) bytes index ~current_region ] + ~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 - (Some mode) bytes index ~current_region ] + ~boxed:true (Some mode) bytes index ~current_region ] | Pbytes_load_128 { unsafe = false; mode }, [[bytes]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:(One_twenty_eight { aligned = false }) - Bytes (Some mode) bytes index ~current_region ] + Bytes ~boxed:true (Some mode) bytes index ~current_region ] | Pbytes_set_16 true (* unsafe *), [[bytes]; [index]; [new_value]] -> - [bytes_like_set_unsafe ~access_size:Sixteen Bytes bytes index new_value] + [ bytes_like_set_unsafe ~access_size:Sixteen Bytes ~boxed:false bytes index + new_value ] | Pbytes_set_32 true (* unsafe *), [[bytes]; [index]; [new_value]] -> - [bytes_like_set_unsafe ~access_size:Thirty_two Bytes bytes index new_value] + [ bytes_like_set_unsafe ~access_size:Thirty_two 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 bytes index new_value] + [ bytes_like_set_unsafe ~access_size:Sixty_four Bytes ~boxed:true bytes + index new_value ] | Pbytes_set_128 { unsafe = true }, [[bytes]; [index]; [new_value]] -> [ bytes_like_set_unsafe ~access_size:(One_twenty_eight { aligned = false }) - Bytes bytes index new_value ] + Bytes ~boxed:true bytes index new_value ] | Pbytes_set_16 false (* safe *), [[bytes]; [index]; [new_value]] -> - [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bytes bytes index - new_value ] + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bytes ~boxed:false + bytes index new_value ] | Pbytes_set_32 false (* safe *), [[bytes]; [index]; [new_value]] -> - [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bytes bytes - index new_value ] + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two 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 bytes - index new_value ] + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixty_four Bytes + ~boxed:true bytes index new_value ] | Pbytes_set_128 { unsafe = false }, [[bytes]; [index]; [new_value]] -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:(One_twenty_eight { aligned = false }) - Bytes bytes index new_value ] + Bytes ~boxed:true bytes index new_value ] | Pisint { variant_only }, [[arg]] -> [tag_int (Unary (Is_int { variant_only }, arg))] | Pisout, [[arg1]; [arg2]] -> @@ -1288,10 +1300,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) (match_on_array_set_kind ~array array_set_kind (array_set_unsafe ~array ~index ~new_value)) ] | Pbytessetu (* unsafe *), [[bytes]; [index]; [new_value]] -> - [bytes_like_set_unsafe ~access_size:Eight Bytes bytes index new_value] - | Pbytessets, [[bytes]; [index]; [new_value]] -> - [ bytes_like_set_safe ~dbg ~size_int ~access_size:Eight Bytes bytes index + [ bytes_like_set_unsafe ~access_size:Eight Bytes ~boxed:false bytes index new_value ] + | Pbytessets, [[bytes]; [index]; [new_value]] -> + [ bytes_like_set_safe ~dbg ~size_int ~access_size:Eight Bytes ~boxed:false + bytes index new_value ] | Poffsetref n, [[block]] -> let block_access : P.Block_access_kind.t = Values @@ -1422,62 +1435,66 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) with an unknown layout should have been removed by Lambda_to_flambda.") | Pbigarraydim dimension, [[arg]] -> [tag_int (Unary (Bigarray_length { dimension }, arg))] - | Pbigstring_load_16 true (* unsafe *), [[big_str]; [index]] -> - [ string_like_load_unsafe ~access_size:Sixteen Bigstring None big_str index - ~current_region ] - | Pbigstring_load_32 (true (* unsafe *), mode), [[big_str]; [index]] -> - [ string_like_load_unsafe ~access_size:Thirty_two Bigstring (Some mode) + | Pbigstring_load_16 { unsafe = true }, [[big_str]; [index]] -> + [ string_like_load_unsafe ~access_size:Sixteen Bigstring ~boxed:false None big_str index ~current_region ] - | Pbigstring_load_64 (true (* unsafe *), mode), [[big_str]; [index]] -> + | 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_64 { unsafe = true; mode; boxed }, [[big_str]; [index]] -> [ string_like_load_unsafe ~access_size:Sixty_four Bigstring (Some mode) - big_str index ~current_region ] - | Pbigstring_load_128 { unsafe = true; aligned; mode }, [[big_str]; [index]] - -> + ~boxed big_str index ~current_region ] + | ( Pbigstring_load_128 { unsafe = true; aligned; mode; boxed }, + [[big_str]; [index]] ) -> [ string_like_load_unsafe ~access_size:(One_twenty_eight { aligned }) - Bigstring (Some mode) big_str index ~current_region ] - | Pbigstring_load_16 false (* safe *), [[big_str]; [index]] -> - [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bigstring None - big_str index ~current_region ] - | Pbigstring_load_32 (false (* safe *), mode), [[big_str]; [index]] -> + Bigstring (Some mode) ~boxed big_str index ~current_region ] + | Pbigstring_load_16 { unsafe = false }, [[big_str]; [index]] -> + [ string_like_load_safe ~dbg ~size_int ~access_size:Sixteen Bigstring + ~boxed:false None big_str index ~current_region ] + | Pbigstring_load_32 { unsafe = false; mode; boxed }, [[big_str]; [index]] -> [ string_like_load_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring - (Some mode) big_str index ~current_region ] - | Pbigstring_load_64 (false (* safe *), mode), [[big_str]; [index]] -> + (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) big_str index ~current_region ] - | Pbigstring_load_128 { unsafe = false; aligned; mode }, [[big_str]; [index]] - -> + (Some mode) ~boxed big_str index ~current_region ] + | ( Pbigstring_load_128 { unsafe = false; aligned; mode; boxed }, + [[big_str]; [index]] ) -> [ string_like_load_safe ~dbg ~size_int ~access_size:(One_twenty_eight { aligned }) - Bigstring (Some mode) big_str index ~current_region ] - | Pbigstring_set_16 true (* unsafe *), [[bigstring]; [index]; [new_value]] -> - [ bytes_like_set_unsafe ~access_size:Sixteen Bigstring bigstring index - new_value ] - | Pbigstring_set_32 true (* unsafe *), [[bigstring]; [index]; [new_value]] -> - [ bytes_like_set_unsafe ~access_size:Thirty_two Bigstring bigstring index - new_value ] - | Pbigstring_set_64 true (* unsafe *), [[bigstring]; [index]; [new_value]] -> - [ bytes_like_set_unsafe ~access_size:Sixty_four Bigstring bigstring index - new_value ] - | ( Pbigstring_set_128 { unsafe = true; aligned }, + Bigstring (Some mode) ~boxed big_str index ~current_region ] + | Pbigstring_set_16 { unsafe = true }, [[bigstring]; [index]; [new_value]] -> + [ bytes_like_set_unsafe ~access_size:Sixteen Bigstring ~boxed:false + bigstring index new_value ] + | ( Pbigstring_set_32 { unsafe = true; boxed }, + [[bigstring]; [index]; [new_value]] ) -> + [ bytes_like_set_unsafe ~access_size:Thirty_two 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 + index new_value ] + | ( Pbigstring_set_128 { unsafe = true; aligned; boxed }, [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_unsafe ~access_size:(One_twenty_eight { aligned }) - Bigstring bigstring index new_value ] - | Pbigstring_set_16 false (* safe *), [[bigstring]; [index]; [new_value]] -> + Bigstring ~boxed bigstring index new_value ] + | Pbigstring_set_16 { unsafe = false }, [[bigstring]; [index]; [new_value]] -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:Sixteen Bigstring - bigstring index new_value ] - | Pbigstring_set_32 false (* safe *), [[bigstring]; [index]; [new_value]] -> + ~boxed:false bigstring index new_value ] + | ( Pbigstring_set_32 { unsafe = false; boxed }, + [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:Thirty_two Bigstring - bigstring index new_value ] - | Pbigstring_set_64 false (* safe *), [[bigstring]; [index]; [new_value]] -> + ~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 - bigstring index new_value ] - | ( Pbigstring_set_128 { unsafe = false; aligned }, + ~boxed bigstring index new_value ] + | ( Pbigstring_set_128 { unsafe = false; aligned; boxed }, [[bigstring]; [index]; [new_value]] ) -> [ bytes_like_set_safe ~dbg ~size_int ~access_size:(One_twenty_eight { aligned }) - Bigstring bigstring index new_value ] + Bigstring ~boxed bigstring index new_value ] | Pcompare_ints, [[i1]; [i2]] -> [ tag_int (Binary diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 13db7d21382..d517c4e73c4 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -238,14 +238,15 @@ type primitive = | 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 bool - | Pbigstring_load_32 of bool * alloc_mode - | Pbigstring_load_64 of bool * alloc_mode - | Pbigstring_load_128 of { aligned : bool; unsafe : bool; mode: alloc_mode } - | Pbigstring_set_16 of bool - | Pbigstring_set_32 of bool - | Pbigstring_set_64 of bool - | Pbigstring_set_128 of { aligned : bool; unsafe : bool } + | Pbigstring_load_16 of { unsafe : bool } + | Pbigstring_load_32 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_64 of { unsafe : bool; boxed : bool } + | Pbigstring_set_128 of { aligned : bool; unsafe : bool; boxed : bool } (* Compile time constants *) | Pctconst of compile_time_constant (* byte swap *) @@ -745,8 +746,18 @@ let layout_unboxed_nativeint = Punboxed_int Pnativeint let layout_unboxed_int32 = Punboxed_int Pint32 let layout_unboxed_int64 = Punboxed_int Pint64 let layout_string = Pvalue Pgenval +let layout_unboxed_int ubi = Punboxed_int ubi let layout_boxedint bi = Pvalue (Pboxedintval bi) +let layout_unboxed_vector (v : Primitive.boxed_vector) = + match v with + | Pvec128 Int8x16 -> Punboxed_vector (Pvec128 Int8x16) + | Pvec128 Int16x8 -> Punboxed_vector (Pvec128 Int16x8) + | Pvec128 Int32x4 -> Punboxed_vector (Pvec128 Int32x4) + | Pvec128 Int64x2 -> Punboxed_vector (Pvec128 Int64x2) + | Pvec128 Float32x4 -> Punboxed_vector (Pvec128 Float32x4) + | Pvec128 Float64x2 -> Punboxed_vector (Pvec128 Float64x2) + let layout_boxed_vector : Primitive.boxed_vector -> layout = function | Pvec128 Int8x16 -> Pvalue (Pboxedvectorval (Pvec128 Int8x16)) | Pvec128 Int16x8 -> Pvalue (Pboxedvectorval (Pvec128 Int16x8)) @@ -1557,8 +1568,12 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pget_header m -> Some m | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbytes_set_128 _ -> None | Pbigstring_load_16 _ -> None - | Pbigstring_load_32 (_,m) | Pbigstring_load_64 (_,m) - | Pbigstring_load_128 { mode = m; _ } -> Some m + | Pbigstring_load_32 { 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_64 { boxed = false; _ } + | Pbigstring_load_128 { boxed = false; _ } -> None | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ | Pbigstring_set_128 _ -> None | Pctconst _ -> None @@ -1669,12 +1684,19 @@ let primitive_result_layout (p : primitive) = | Pbbswap (bi, _) | Pbox_int (bi, _) -> layout_boxedint bi | Punbox_int bi -> Punboxed_int bi - | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 _ -> + | Pstring_load_32 _ | Pbytes_load_32 _ + | Pbigstring_load_32 { boxed = true; _ } -> layout_boxedint Pint32 - | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 _ -> + | Pstring_load_64 _ | Pbytes_load_64 _ + | Pbigstring_load_64 { boxed = true; _ } -> layout_boxedint Pint64 - | Pstring_load_128 _ | Pbytes_load_128 _ | Pbigstring_load_128 _ -> + | Pstring_load_128 _ | Pbytes_load_128 _ + | Pbigstring_load_128 { boxed = true; _ } -> layout_boxed_vector (Pvec128 Int8x16) + | Pbigstring_load_32 { boxed = false; _ } -> layout_unboxed_int Pint32 + | Pbigstring_load_64 { boxed = false; _ } -> layout_unboxed_int Pint64 + | Pbigstring_load_128 { boxed = false; _ } -> + layout_unboxed_vector (Pvec128 Int8x16) | Pbigarrayref (_, _, kind, _) -> begin match kind with | Pbigarray_unknown -> layout_any_value diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 16e63492c8f..04abe07df9e 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -200,14 +200,15 @@ type primitive = | 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 bool - | Pbigstring_load_32 of bool * alloc_mode - | Pbigstring_load_64 of bool * alloc_mode - | Pbigstring_load_128 of { aligned : bool; unsafe : bool; mode: alloc_mode } - | Pbigstring_set_16 of bool - | Pbigstring_set_32 of bool - | Pbigstring_set_64 of bool - | Pbigstring_set_128 of { aligned : bool; unsafe : bool } + | Pbigstring_load_16 of { unsafe : bool } + | Pbigstring_load_32 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_64 of { unsafe : bool; boxed : bool } + | Pbigstring_set_128 of { aligned : bool; unsafe : bool; boxed : bool } (* Compile time constants *) | Pctconst of compile_time_constant (* byte swap *) diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index a820284a176..3d860a53a22 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/lambda/printlambda.ml @@ -550,13 +550,13 @@ let primitive ppf = function fprintf ppf "bytes.unsafe_unaligned_set128" | Pbytes_set_128 {unsafe = false} -> fprintf ppf "bytes.unaligned_set128" - | Pbigstring_load_16(unsafe) -> + | Pbigstring_load_16 { unsafe } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_get16" else fprintf ppf "bigarray.array1.get16" - | Pbigstring_load_32(unsafe,m) -> + | 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_64(unsafe,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) | Pbigstring_load_128 {unsafe = true; aligned = false; mode} -> @@ -567,13 +567,13 @@ let primitive ppf = function fprintf ppf "bigarray.array1.unsafe_aligned_get128%s" (alloc_kind mode) | Pbigstring_load_128 {unsafe = false; aligned = true; mode} -> fprintf ppf "bigarray.array1.aligned_get128%s" (alloc_kind mode) - | Pbigstring_set_16(unsafe) -> + | Pbigstring_set_16 { unsafe } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_set16" else fprintf ppf "bigarray.array1.set16" - | Pbigstring_set_32(unsafe) -> + | Pbigstring_set_32 { unsafe } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" else fprintf ppf "bigarray.array1.set32" - | Pbigstring_set_64(unsafe) -> + | Pbigstring_set_64 { unsafe } -> if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" else fprintf ppf "bigarray.array1.set64" | Pbigstring_set_128 {unsafe = true; aligned = false} -> diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index 81863a604db..4561cb34c60 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -399,34 +399,97 @@ let lookup_primitive loc poly pos p = Primitive ((Pbytes_set_128 {unsafe = false}), 3) | "%caml_bytes_setu128u" -> Primitive ((Pbytes_set_128 {unsafe = true}), 3) - | "%caml_bigstring_get16" -> Primitive ((Pbigstring_load_16(false)), 2) - | "%caml_bigstring_get16u" -> Primitive ((Pbigstring_load_16(true)), 2) - | "%caml_bigstring_get32" -> Primitive ((Pbigstring_load_32(false, mode)), 2) - | "%caml_bigstring_get32u" -> Primitive ((Pbigstring_load_32(true, mode)), 2) - | "%caml_bigstring_get64" -> Primitive ((Pbigstring_load_64(false, mode)), 2) - | "%caml_bigstring_get64u" -> Primitive ((Pbigstring_load_64(true, mode)), 2) + | "%caml_bigstring_get16" -> + Primitive ((Pbigstring_load_16 { unsafe = false }), 2) + | "%caml_bigstring_get16u" -> + Primitive ((Pbigstring_load_16 { unsafe = true }), 2) + | "%caml_bigstring_get32" -> + 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_get64" -> + Primitive ((Pbigstring_load_64 { unsafe = false; mode; boxed = true }), 2) + | "%caml_bigstring_get64u" -> + Primitive ((Pbigstring_load_64 { unsafe = true; mode; boxed = true }), 2) | "%caml_bigstring_getu128" -> - Primitive ((Pbigstring_load_128 {aligned = false; unsafe = false; mode}), 2) + Primitive ((Pbigstring_load_128 {aligned = false; unsafe = false; mode; + boxed = true }), 2) | "%caml_bigstring_getu128u" -> - Primitive ((Pbigstring_load_128 {aligned = false; unsafe = true; mode}), 2) + Primitive ((Pbigstring_load_128 {aligned = false; unsafe = true; mode; + boxed = true }), 2) | "%caml_bigstring_geta128" -> - Primitive ((Pbigstring_load_128 {aligned = true; unsafe = false; mode}), 2) + Primitive ((Pbigstring_load_128 {aligned = true; unsafe = false; mode; + boxed = true }), 2) | "%caml_bigstring_geta128u" -> - Primitive ((Pbigstring_load_128 {aligned = true; unsafe = true; mode}), 2) - | "%caml_bigstring_set16" -> Primitive ((Pbigstring_set_16(false)), 3) - | "%caml_bigstring_set16u" -> Primitive ((Pbigstring_set_16(true)), 3) - | "%caml_bigstring_set32" -> Primitive ((Pbigstring_set_32(false)), 3) - | "%caml_bigstring_set32u" -> Primitive ((Pbigstring_set_32(true)), 3) - | "%caml_bigstring_set64" -> Primitive ((Pbigstring_set_64(false)), 3) - | "%caml_bigstring_set64u" -> Primitive ((Pbigstring_set_64(true)), 3) + Primitive ((Pbigstring_load_128 {aligned = true; unsafe = true; mode; + boxed = true }), 2) + | "%caml_bigstring_set16" -> + Primitive ((Pbigstring_set_16 { unsafe = false }), 3) + | "%caml_bigstring_set16u" -> + Primitive ((Pbigstring_set_16 { unsafe = true }), 3) + | "%caml_bigstring_set32" -> + Primitive ((Pbigstring_set_32 { unsafe = false; boxed = true }), 3) + | "%caml_bigstring_set32u" -> + Primitive ((Pbigstring_set_32 { unsafe = true; boxed = true }), 3) + | "%caml_bigstring_set64" -> + Primitive ((Pbigstring_set_64 { unsafe = false; boxed = true }), 3) + | "%caml_bigstring_set64u" -> + Primitive ((Pbigstring_set_64 { unsafe = true; boxed = true }), 3) | "%caml_bigstring_setu128" -> - Primitive ((Pbigstring_set_128 {aligned = false; unsafe = false}), 3) + Primitive ((Pbigstring_set_128 {aligned = false; unsafe = false; + boxed = true}), 3) | "%caml_bigstring_setu128u" -> - Primitive ((Pbigstring_set_128 {aligned = false; unsafe = true}), 3) + Primitive ((Pbigstring_set_128 {aligned = false; unsafe = true; + boxed = true}), 3) | "%caml_bigstring_seta128" -> - Primitive ((Pbigstring_set_128 {aligned = true; unsafe = false}), 3) + Primitive ((Pbigstring_set_128 {aligned = true; unsafe = false; + boxed = true}), 3) | "%caml_bigstring_seta128u" -> - Primitive ((Pbigstring_set_128 {aligned = true; unsafe = true}), 3) + Primitive ((Pbigstring_set_128 {aligned = true; unsafe = true; + boxed = true}), 3) + | "%caml_bigstring_get32#" -> + Primitive ((Pbigstring_load_32 { unsafe = false; mode; boxed = false }), + 2) + | "%caml_bigstring_get32u#" -> + Primitive ((Pbigstring_load_32 { 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) + | "%caml_bigstring_getu128#" -> + Primitive ((Pbigstring_load_128 {aligned = false; unsafe = false; mode; + boxed = false }), 2) + | "%caml_bigstring_getu128u#" -> + Primitive ((Pbigstring_load_128 {aligned = false; unsafe = true; mode; + boxed = false }), 2) + | "%caml_bigstring_geta128#" -> + Primitive ((Pbigstring_load_128 {aligned = true; unsafe = false; mode; + boxed = false }), 2) + | "%caml_bigstring_geta128u#" -> + Primitive ((Pbigstring_load_128 {aligned = true; unsafe = true; mode; + boxed = false }), 2) + | "%caml_bigstring_set32#" -> + Primitive ((Pbigstring_set_32 { unsafe = false; boxed = false }), 3) + | "%caml_bigstring_set32u#" -> + Primitive ((Pbigstring_set_32 { unsafe = true; boxed = false }), 3) + | "%caml_bigstring_set64#" -> + Primitive ((Pbigstring_set_64 { unsafe = false; boxed = false }), 3) + | "%caml_bigstring_set64u#" -> + Primitive ((Pbigstring_set_64 { unsafe = true; boxed = false }), 3) + | "%caml_bigstring_setu128#" -> + Primitive ((Pbigstring_set_128 {aligned = false; unsafe = false; + boxed = false}), 3) + | "%caml_bigstring_setu128u#" -> + Primitive ((Pbigstring_set_128 {aligned = false; unsafe = true; + boxed = false}), 3) + | "%caml_bigstring_seta128#" -> + Primitive ((Pbigstring_set_128 {aligned = true; unsafe = false; + boxed = false}), 3) + | "%caml_bigstring_seta128u#" -> + Primitive ((Pbigstring_set_128 {aligned = true; unsafe = true; + boxed = false}), 3) | "%bswap16" -> Primitive (Pbswap16, 1) | "%bswap_int32" -> Primitive ((Pbbswap(Pint32, mode)), 1) | "%bswap_int64" -> Primitive ((Pbbswap(Pint64, mode)), 1) diff --git a/ocaml/middle_end/convert_primitives.ml b/ocaml/middle_end/convert_primitives.ml index d186ebb8a0f..531669181de 100644 --- a/ocaml/middle_end/convert_primitives.ml +++ b/ocaml/middle_end/convert_primitives.ml @@ -145,17 +145,17 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = Pbytes_set (Thirty_two, convert_unsafety is_unsafe) | Pbytes_set_64 is_unsafe -> Pbytes_set (Sixty_four, convert_unsafety is_unsafe) - | Pbigstring_load_16 is_unsafe -> + | Pbigstring_load_16 { unsafe = is_unsafe } -> Pbigstring_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) - | Pbigstring_load_32 (is_unsafe, m) -> + | Pbigstring_load_32 { unsafe = is_unsafe; mode = m; boxed = true } -> Pbigstring_load (Thirty_two, convert_unsafety is_unsafe, m) - | Pbigstring_load_64 (is_unsafe, m) -> + | Pbigstring_load_64 { unsafe = is_unsafe; mode = m; boxed = true } -> Pbigstring_load (Sixty_four, convert_unsafety is_unsafe, m) - | Pbigstring_set_16 is_unsafe -> + | Pbigstring_set_16 { unsafe = is_unsafe } -> Pbigstring_set (Sixteen, convert_unsafety is_unsafe) - | Pbigstring_set_32 is_unsafe -> + | Pbigstring_set_32 { unsafe = is_unsafe; boxed = true } -> Pbigstring_set (Thirty_two, convert_unsafety is_unsafe) - | Pbigstring_set_64 is_unsafe -> + | Pbigstring_set_64 { unsafe = is_unsafe; boxed = true } -> Pbigstring_set (Sixty_four, convert_unsafety is_unsafe) | Pbigarraydim dim -> Pbigarraydim dim | Pbswap16 -> Pbswap16 @@ -194,6 +194,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pgetpredef _ | Parray_to_iarray | Parray_of_iarray + | Pbigstring_load_32 _ + | Pbigstring_set_32 _ + | Pbigstring_load_64 _ + | Pbigstring_set_64 _ | Pbigstring_load_128 _ | Pbigstring_set_128 _ | Pstring_load_128 _