From 09aef50dcc021e77d09c38c2d4c090cced3e367a Mon Sep 17 00:00:00 2001 From: Jacob Van Buren Date: Tue, 10 Dec 2024 11:58:45 -0500 Subject: [PATCH] merged with origin/break-type-eq-between-boxed-and-unboxed --- .github/workflows/build.yml | 46 +-- backend/cmm_builtins.ml | 42 ++- backend/cmm_helpers.ml | 63 ++-- backend/cmm_helpers.mli | 4 +- bytecomp/bytegen.ml | 98 ++--- lambda/lambda.ml | 172 +++++---- lambda/lambda.mli | 52 +-- lambda/matching.ml | 32 +- lambda/printlambda.ml | 159 ++++---- lambda/transl_array_comprehension.ml | 26 +- lambda/translprim.ml | 354 +++++++++--------- .../from_lambda/closure_conversion.ml | 20 +- .../flambda2/from_lambda/lambda_to_flambda.ml | 16 +- .../lambda_to_flambda_primitives.ml | 270 ++++++------- middle_end/flambda2/kinds/flambda_arity.ml | 12 +- middle_end/flambda2/kinds/flambda_kind.ml | 54 +-- .../flambda2/term_basics/empty_array_kind.ml | 12 +- .../flambda2/to_cmm/to_cmm_primitive.ml | 18 +- middle_end/flambda2/types/env/typing_env.ml | 65 ++-- middle_end/flambda2/types/env/typing_env.mli | 11 +- .../flambda2/types/meet_and_join_new.ml | 58 ++- .../flambda2/types/meet_and_join_new.mli | 2 +- testsuite/tests/typing-unique/unique.ml | 76 +++- typing/primitive.ml | 75 ++-- typing/primitive.mli | 21 +- typing/typedecl.ml | 22 +- typing/typedtree.mli | 29 +- typing/typeopt.ml | 64 ++-- typing/uniqueness_analysis.ml | 331 +++++++++------- 29 files changed, 1196 insertions(+), 1008 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 642675b0048..2f40789cb02 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -10,7 +10,7 @@ on: jobs: build: name: ${{ matrix.name }} - runs-on: ${{ matrix.os }} + runs-on: "${{ matrix.runs-on }}" strategy: fail-fast: false @@ -18,104 +18,104 @@ jobs: include: - name: flambda2_runtime5 config: --enable-middle-end=flambda2 --enable-runtime5 - os: ubuntu-latest + runs-on: linux-x64-1 - name: flambda2_dev config: --enable-middle-end=flambda2 --enable-dev - os: ubuntu-latest + runs-on: linux-x64-1 - name: flambda2_dev_runtime5 config: --enable-middle-end=flambda2 --enable-dev --enable-runtime5 - os: ubuntu-latest + runs-on: linux-x64-1 - name: flambda2_debug_runtime5 config: --enable-middle-end=flambda2 --enable-runtime5 - os: ubuntu-latest + runs-on: linux-x64-2 build_ocamlparam: '' use_runtime: d ocamlrunparam: "v=0,V=1" - name: flambda2_debug_runtime config: --enable-middle-end=flambda2 - os: ubuntu-latest + runs-on: linux-x64-2 build_ocamlparam: '' use_runtime: d ocamlrunparam: "v=0,V=1" - name: flambda2_o3 config: --enable-middle-end=flambda2 - os: ubuntu-latest + runs-on: linux-x64-2 build_ocamlparam: '' ocamlparam: '_,O3=1' - name: flambda2_o3_heap config: --enable-middle-end=flambda2 --disable-stack-allocation - os: ubuntu-latest + runs-on: linux-x64-3 build_ocamlparam: '' ocamlparam: '_,O3=1' - name: flambda2_o3_advanced_meet_frame_pointers_runtime5_polling config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5 --enable-poll-insertion --enable-flambda-invariants - os: ubuntu-latest + runs-on: linux-x64-3 build_ocamlparam: '' ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced,flambda2-expert-cont-lifting-budget=200' - name: flambda2_o3_advanced_meet_frame_pointers_runtime5_debug config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5 - os: ubuntu-latest + runs-on: linux-x64-3 build_ocamlparam: '' use_runtime: d ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced,flambda2-expert-cont-lifting-budget=200' - name: flambda2_frame_pointers_oclassic_polling config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion --enable-flambda-invariants - os: ubuntu-latest + runs-on: linux-x64-4 build_ocamlparam: '' ocamlparam: '_,Oclassic=1' disable_testcases: 'testsuite/tests/typing-local/regression_cmm_unboxing.ml testsuite/tests/int64-unboxing/test.ml' - name: flambda2_macos_arm64 config: --enable-middle-end=flambda2 --disable-warn-error - os: macos-latest + runs-on: macos-latest-xlarge - name: irc config: --enable-middle-end=flambda2 - os: ubuntu-latest + runs-on: linux-x64-4 build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' check_arch: true - name: irc_polling config: --enable-middle-end=flambda2 --enable-poll-insertion - os: ubuntu-latest + runs-on: linux-x64-4 build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' check_arch: true - name: irc_frame_pointers config: --enable-middle-end=flambda2 --enable-frame-pointers - os: ubuntu-latest + runs-on: linux-x64-5 build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1' check_arch: true - name: ls config: --enable-middle-end=flambda2 - os: ubuntu-latest + runs-on: linux-x64-5 build_ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1' ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1' check_arch: true - name: gi config: --enable-middle-end=flambda2 - os: ubuntu-latest + runs-on: linux-x64-5 build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1' ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1' check_arch: true - name: cfg-selection config: --enable-middle-end=flambda2 - os: ubuntu-latest + runs-on: linux-x64-5 build_ocamlparam: '_,w=-46,regalloc=cfg,cfg-cse-optimize=1,cfg-selection=1,cfg-zero-alloc-checker=1' ocamlparam: '_,w=-46,regalloc=cfg,cfg-cse-optimize=1,cfg-selection=1,cfg-zero-alloc-checker=1' check_arch: true @@ -132,17 +132,17 @@ jobs: path: 'flambda_backend' - name: Install AFL (for Linux workers) - if: matrix.os == 'ubuntu-latest' + if: matrix.runs-on != 'macos-latest-xlarge' run: sudo apt-get install afl++ - name: Install AFL (for macOS workers) # The "afl-fuzz" package is deprecated (2023-10) and can no longer be installed - if: matrix.os == 'macos-latest' + if: matrix.runs-on == 'macos-latest-xlarge' run: true # run: HOMEBREW_NO_INSTALL_CLEANUP=TRUE brew install afl-fuzz - name: Install autoconf (for macOS workers) - if: matrix.os == 'macos-latest' + if: matrix.runs-on == 'macos-latest-xlarge' run: HOMEBREW_NO_INSTALL_CLEANUP=TRUE brew install autoconf - name: Cache OCaml 4.14, dune and menhir @@ -150,7 +150,7 @@ jobs: id: cache with: path: ${{ github.workspace }}/ocaml-414/_install - key: ${{ matrix.os }}-cache-ocaml-414-dune-3152-menhir-20231231 + key: ${{ matrix.runs-on }}-cache-ocaml-414-dune-3152-menhir-20231231 - name: Checkout OCaml 4.14 uses: actions/checkout@master @@ -209,7 +209,7 @@ jobs: cat $SOURCE_DIR/menhirLib.ml > $TARGET_DIR/menhirLib.ml - name: Install GNU parallel - if: matrix.os == 'macos-latest' + if: matrix.runs-on == 'macos-latest-xlarge' run: HOMEBREW_NO_INSTALL_CLEANUP=TRUE brew install parallel - name: Disable any testcases diff --git a/backend/cmm_builtins.ml b/backend/cmm_builtins.ml index 63ec6cd658e..954948e2f85 100644 --- a/backend/cmm_builtins.ml +++ b/backend/cmm_builtins.ml @@ -52,7 +52,7 @@ let if_operation_supported op ~f = match Proc.operation_supported op with true -> Some (f ()) | false -> None let if_operation_supported_bi bi op ~f = - if bi = Primitive.Pint64 && size_int = 4 + if bi = Primitive.Unboxed_int64 && size_int = 4 then None else if_operation_supported op ~f @@ -72,13 +72,13 @@ let clz ~arg_is_non_zero bi arg dbg = let op = Cclz { arg_is_non_zero } in if_operation_supported_bi bi op ~f:(fun () -> let res = Cop (op, [make_unsigned_int bi arg dbg], dbg) in - if bi = Primitive.Pint32 && size_int = 8 + if bi = Primitive.Unboxed_int32 && size_int = 8 then Cop (Caddi, [res; Cconst_int (-32, dbg)], dbg) else res) let ctz ~arg_is_non_zero bi arg dbg = let arg = make_unsigned_int bi arg dbg in - if bi = Primitive.Pint32 && size_int = 8 + if bi = Primitive.Unboxed_int32 && size_int = 8 then (* regardless of the value of the argument [arg_is_non_zero], always set the corresponding field to [true], because we make it non-zero below by @@ -439,17 +439,17 @@ let transl_builtin name args dbg typ_res = let arg = clear_sign_bit (one_arg name args) dbg in Cop (Caddi, [Cop (op, [arg], dbg); Cconst_int (-1, dbg)], dbg)) | "caml_int64_clz_unboxed_to_untagged" -> - clz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg + clz ~arg_is_non_zero:false Unboxed_int64 (one_arg name args) dbg | "caml_int32_clz_unboxed_to_untagged" -> - clz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg + clz ~arg_is_non_zero:false Unboxed_int32 (one_arg name args) dbg | "caml_nativeint_clz_unboxed_to_untagged" -> - clz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg + clz ~arg_is_non_zero:false Unboxed_nativeint (one_arg name args) dbg | "caml_int64_clz_nonzero_unboxed_to_untagged" -> - clz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg + clz ~arg_is_non_zero:true Unboxed_int64 (one_arg name args) dbg | "caml_int32_clz_nonzero_unboxed_to_untagged" -> - clz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg + clz ~arg_is_non_zero:true Unboxed_int32 (one_arg name args) dbg | "caml_nativeint_clz_nonzero_unboxed_to_untagged" -> - clz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg + clz ~arg_is_non_zero:true Unboxed_nativeint (one_arg name args) dbg | "caml_int_popcnt_tagged_to_untagged" -> if_operation_supported Cpopcnt ~f:(fun () -> (* Having the argument tagged saves a shift, but there is one extra @@ -462,11 +462,11 @@ let transl_builtin name args dbg typ_res = let arg = clear_sign_bit (one_arg name args) dbg in Cop (Cpopcnt, [arg], dbg)) | "caml_int64_popcnt_unboxed_to_untagged" -> - popcnt Pint64 (one_arg name args) dbg + popcnt Unboxed_int64 (one_arg name args) dbg | "caml_int32_popcnt_unboxed_to_untagged" -> - popcnt Pint32 (one_arg name args) dbg + popcnt Unboxed_int32 (one_arg name args) dbg | "caml_nativeint_popcnt_unboxed_to_untagged" -> - popcnt Pnativeint (one_arg name args) dbg + popcnt Unboxed_nativeint (one_arg name args) dbg | "caml_int_ctz_untagged_to_untagged" -> (* Assuming a 64-bit x86-64 target: @@ -496,19 +496,21 @@ let transl_builtin name args dbg typ_res = in Cop (op, [Cop (Cor, [one_arg name args; c], dbg)], dbg)) | "caml_int32_ctz_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg + ctz ~arg_is_non_zero:false Unboxed_int32 (one_arg name args) dbg | "caml_int64_ctz_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg + ctz ~arg_is_non_zero:false Unboxed_int64 (one_arg name args) dbg | "caml_nativeint_ctz_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg + ctz ~arg_is_non_zero:false Unboxed_nativeint (one_arg name args) dbg | "caml_int32_ctz_nonzero_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg + ctz ~arg_is_non_zero:true Unboxed_int32 (one_arg name args) dbg | "caml_int64_ctz_nonzero_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg + ctz ~arg_is_non_zero:true Unboxed_int64 (one_arg name args) dbg | "caml_nativeint_ctz_nonzero_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg - | "caml_signed_int64_mulh_unboxed" -> mulhi ~signed:true Pint64 args dbg - | "caml_unsigned_int64_mulh_unboxed" -> mulhi ~signed:false Pint64 args dbg + ctz ~arg_is_non_zero:true Unboxed_nativeint (one_arg name args) dbg + | "caml_signed_int64_mulh_unboxed" -> + mulhi ~signed:true Unboxed_int64 args dbg + | "caml_unsigned_int64_mulh_unboxed" -> + mulhi ~signed:false Unboxed_int64 args dbg | "caml_int32_unsigned_to_int_trunc_unboxed_to_untagged" -> Some (zero_extend_32 dbg (one_arg name args)) | "caml_csel_value" | "caml_csel_int_untagged" | "caml_csel_int64_unboxed" diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 9b8dcd3e91f..e7ca7bb2526 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -758,7 +758,8 @@ let safe_divmod_bi mkop kind is_safe mkm1 c1 c2 bi dbg = bind "divisor" c2 (fun c2 -> bind "dividend" c1 (fun c1 -> let c = mkop c1 c2 is_safe dbg in - if Arch.division_crashes_on_overflow && bi <> Primitive.Pint32 + if Arch.division_crashes_on_overflow + && bi <> Primitive.Boxed_int32 && not (is_different_from (-1) c2) then Cifthenelse @@ -1627,9 +1628,9 @@ module Extended_machtype = struct | Ptop -> Misc.fatal_error "No Extended_machtype for layout [Ptop]" | Pbottom -> Misc.fatal_error "No unique Extended_machtype for layout [Pbottom]" - | Punboxed_float Pfloat64 -> typ_float - | Punboxed_float Pfloat32 -> typ_float32 - | Punboxed_vector Pvec128 -> typ_vec128 + | Punboxed_float Unboxed_float64 -> typ_float + | Punboxed_float Unboxed_float32 -> typ_float32 + | Punboxed_vector Unboxed_vec128 -> typ_vec128 | Punboxed_int _ -> (* Only 64-bit architectures, so this is always [typ_int] *) typ_any_int @@ -2029,21 +2030,21 @@ let xor_int e1 e2 dbg = Cop (Cxor, [e1; e2], dbg) let operations_boxed_int (bi : Primitive.boxed_integer) = let sym_name = match bi with - | Pnativeint -> caml_nativeint_ops - | Pint32 -> caml_int32_ops - | Pint64 -> caml_int64_ops + | Boxed_nativeint -> caml_nativeint_ops + | Boxed_int32 -> caml_int32_ops + | Boxed_int64 -> caml_int64_ops in global_symbol sym_name let alloc_header_boxed_int (bi : Primitive.boxed_integer) mode dbg = match bi with - | Pnativeint -> alloc_boxedintnat_header mode dbg - | Pint32 -> alloc_boxedint32_header mode dbg - | Pint64 -> alloc_boxedint64_header mode dbg + | Boxed_nativeint -> alloc_boxedintnat_header mode dbg + | Boxed_int32 -> alloc_boxedint32_header mode dbg + | Boxed_int64 -> alloc_boxedint64_header mode dbg let box_int_gen dbg (bi : Primitive.boxed_integer) mode arg = let arg' = - if bi = Primitive.Pint32 + if bi = Primitive.Boxed_int32 then if big_endian then Cop (Clsl, [arg; Cconst_int (32, dbg)], dbg) @@ -2059,24 +2060,24 @@ let box_int_gen dbg (bi : Primitive.boxed_integer) mode arg = let alloc_matches_boxed_int bi ~hdr ~ops = match (bi : Primitive.boxed_integer), hdr, ops with - | Pnativeint, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> + | Boxed_nativeint, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> (Nativeint.equal hdr boxedintnat_header || Nativeint.equal hdr boxedintnat_local_header) && String.equal sym.sym_name caml_nativeint_ops - | Pint32, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> + | Boxed_int32, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> (Nativeint.equal hdr boxedint32_header || Nativeint.equal hdr boxedint32_local_header) && String.equal sym.sym_name caml_int32_ops - | Pint64, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> + | Boxed_int64, Cconst_natint (hdr, _dbg), Cconst_symbol (sym, _) -> (Nativeint.equal hdr boxedint64_header || Nativeint.equal hdr boxedint64_local_header) && String.equal sym.sym_name caml_int64_ops - | (Pnativeint | Pint32 | Pint64), _, _ -> false + | (Boxed_nativeint | Boxed_int32 | Boxed_int64), _, _ -> false let unbox_int dbg bi = let default arg = let memory_chunk = - if bi = Primitive.Pint32 then Thirtytwo_signed else Word_int + if bi = Primitive.Boxed_int32 then Thirtytwo_signed else Word_int in Cop ( mk_load_immut memory_chunk, @@ -2088,12 +2089,12 @@ let unbox_int dbg bi = ( Calloc _, [hdr; ops; Cop (Clsl, [contents; Cconst_int (32, _)], _dbg')], _dbg ) - when bi = Primitive.Pint32 && big_endian + when bi = Primitive.Boxed_int32 && big_endian && alloc_matches_boxed_int bi ~hdr ~ops -> (* Force sign-extension of low 32 bits *) sign_extend_32 dbg contents | Cop (Calloc _, [hdr; ops; contents], _dbg) - when bi = Primitive.Pint32 && (not big_endian) + when bi = Primitive.Boxed_int32 && (not big_endian) && alloc_matches_boxed_int bi ~hdr ~ops -> (* Force sign-extension of low 32 bits *) sign_extend_32 dbg contents @@ -2102,17 +2103,17 @@ let unbox_int dbg bi = contents | Cconst_symbol (s, _dbg) as cmm -> ( match Cmmgen_state.structured_constant_of_sym s.sym_name, bi with - | Some (Const_nativeint n), Primitive.Pnativeint -> + | Some (Const_nativeint n), Primitive.Boxed_nativeint -> natint_const_untagged dbg n - | Some (Const_int32 n), Primitive.Pint32 -> + | Some (Const_int32 n), Primitive.Boxed_int32 -> natint_const_untagged dbg (Nativeint.of_int32 n) - | Some (Const_int64 n), Primitive.Pint64 -> + | Some (Const_int64 n), Primitive.Boxed_int64 -> natint_const_untagged dbg (Int64.to_nativeint n) | _ -> default cmm) | cmm -> default cmm) let make_unsigned_int bi arg dbg = - if bi = Primitive.Pint32 then zero_extend_32 dbg arg else arg + if bi = Primitive.Unboxed_int32 then zero_extend_32 dbg arg else arg let unaligned_load_16 ptr idx dbg = if Arch.allow_unaligned_access @@ -3342,20 +3343,20 @@ let addr_array_length arg dbg = let bbswap bi arg dbg = let bitwidth : Cmm.bswap_bitwidth = - match (bi : Primitive.boxed_integer) with - | Pnativeint -> if size_int = 4 then Thirtytwo else Sixtyfour - | Pint32 -> Thirtytwo - | Pint64 -> Sixtyfour + match (bi : Primitive.unboxed_integer) with + | Unboxed_nativeint -> if size_int = 4 then Thirtytwo else Sixtyfour + | Unboxed_int32 -> Thirtytwo + | Unboxed_int64 -> Sixtyfour in let op = Cbswap { bitwidth } in - if (bi = Primitive.Pint64 && size_int = 4) + if (bi = Primitive.Unboxed_int64 && size_int = 4) || not (Proc.operation_supported op) then let prim, tyarg = - match (bi : Primitive.boxed_integer) with - | Pnativeint -> "nativeint", XInt - | Pint32 -> "int32", XInt32 - | Pint64 -> "int64", XInt64 + match (bi : Primitive.unboxed_integer) with + | Unboxed_nativeint -> "nativeint", XInt + | Unboxed_int32 -> "int32", XInt32 + | Unboxed_int64 -> "int64", XInt64 in Cop ( Cextcall diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index 61bc39581a7..2f5d81a1175 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -418,7 +418,7 @@ val unbox_int : (** Used to prepare 32-bit integers on 64-bit platforms for a lsr operation *) val make_unsigned_int : - Primitive.boxed_integer -> expression -> Debuginfo.t -> expression + Primitive.unboxed_integer -> expression -> Debuginfo.t -> expression val unaligned_load_16 : expression -> expression -> Debuginfo.t -> expression @@ -467,7 +467,7 @@ val negint : unary_primitive val addr_array_length : unary_primitive (** Byte swap primitive Operates on Cmm integers (unboxed values) *) -val bbswap : Primitive.boxed_integer -> unary_primitive +val bbswap : Primitive.unboxed_integer -> unary_primitive (** 16-bit byte swap primitive Operates on Cmm integers (untagged integers) *) val bswap16 : unary_primitive diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 69c6631a996..6fa48e5e285 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -386,18 +386,18 @@ let check_stack stack_info sz = let comp_bint_primitive bi suff args = let pref = - match bi with Pnativeint -> "caml_nativeint_" - | Pint32 -> "caml_int32_" - | Pint64 -> "caml_int64_" in + match bi with Boxed_nativeint -> "caml_nativeint_" + | Boxed_int32 -> "caml_int32_" + | Boxed_int64 -> "caml_int64_" in Kccall(pref ^ suff, List.length args) let indexing_primitive (index_kind : Lambda.array_index_kind) prefix = let suffix = match index_kind with | Ptagged_int_index -> "" - | Punboxed_int_index Pint64 -> "_indexed_by_int64" - | Punboxed_int_index Pint32 -> "_indexed_by_int32" - | Punboxed_int_index Pnativeint -> "_indexed_by_nativeint" + | Punboxed_int_index Unboxed_int64 -> "_indexed_by_int64" + | Punboxed_int_index Unboxed_int32 -> "_indexed_by_int32" + | Punboxed_int_index Unboxed_nativeint -> "_indexed_by_nativeint" in prefix ^ suffix @@ -409,8 +409,8 @@ let comp_primitive stack_info p sz args = | Pgetpredef id -> Kgetpredef id | Pintcomp cmp -> Kintcomp cmp | Pcompare_ints -> Kccall("caml_int_compare", 2) - | Pcompare_floats Pfloat64 -> Kccall("caml_float_compare", 2) - | Pcompare_floats Pfloat32 -> Kccall("caml_float32_compare", 2) + | Pcompare_floats Boxed_float64 -> Kccall("caml_float_compare", 2) + | Pcompare_floats Boxed_float32 -> Kccall("caml_float32_compare", 2) | Pcompare_bints bi -> comp_bint_primitive bi "compare" args | Pfield (n, _ptr, _sem) -> Kgetfield n | Punboxed_product_field (n, _layouts) -> Kgetfield n @@ -453,24 +453,24 @@ let comp_primitive stack_info p sz args = | Pasrint -> Kasrint | Poffsetint n -> Koffsetint n | Poffsetref n -> Koffsetref n - | Pintoffloat Pfloat64 -> Kccall("caml_int_of_float", 1) - | Pfloatofint (Pfloat64, _) -> Kccall("caml_float_of_int", 1) + | Pintoffloat Boxed_float64 -> Kccall("caml_int_of_float", 1) + | Pfloatofint (Boxed_float64, _) -> Kccall("caml_float_of_int", 1) | Pfloatoffloat32 _ -> Kccall("caml_float_of_float32", 1) | Pfloat32offloat _ -> Kccall("caml_float32_of_float", 1) - | Pnegfloat (Pfloat64, _) -> Kccall("caml_neg_float", 1) - | Pabsfloat (Pfloat64, _) -> Kccall("caml_abs_float", 1) - | Paddfloat (Pfloat64, _) -> Kccall("caml_add_float", 2) - | Psubfloat (Pfloat64, _) -> Kccall("caml_sub_float", 2) - | Pmulfloat (Pfloat64, _) -> Kccall("caml_mul_float", 2) - | Pdivfloat (Pfloat64, _) -> Kccall("caml_div_float", 2) - | Pintoffloat Pfloat32 -> Kccall("caml_int_of_float32", 1) - | Pfloatofint (Pfloat32, _) -> Kccall("caml_float32_of_int", 1) - | Pnegfloat (Pfloat32, _) -> Kccall("caml_neg_float32", 1) - | Pabsfloat (Pfloat32, _) -> Kccall("caml_abs_float32", 1) - | Paddfloat (Pfloat32, _) -> Kccall("caml_add_float32", 2) - | Psubfloat (Pfloat32, _) -> Kccall("caml_sub_float32", 2) - | Pmulfloat (Pfloat32, _) -> Kccall("caml_mul_float32", 2) - | Pdivfloat (Pfloat32, _) -> Kccall("caml_div_float32", 2) + | Pnegfloat (Boxed_float64, _) -> Kccall("caml_neg_float", 1) + | Pabsfloat (Boxed_float64, _) -> Kccall("caml_abs_float", 1) + | Paddfloat (Boxed_float64, _) -> Kccall("caml_add_float", 2) + | Psubfloat (Boxed_float64, _) -> Kccall("caml_sub_float", 2) + | Pmulfloat (Boxed_float64, _) -> Kccall("caml_mul_float", 2) + | Pdivfloat (Boxed_float64, _) -> Kccall("caml_div_float", 2) + | Pintoffloat Boxed_float32 -> Kccall("caml_int_of_float32", 1) + | Pfloatofint (Boxed_float32, _) -> Kccall("caml_float32_of_int", 1) + | Pnegfloat (Boxed_float32, _) -> Kccall("caml_neg_float32", 1) + | Pabsfloat (Boxed_float32, _) -> Kccall("caml_abs_float32", 1) + | Paddfloat (Boxed_float32, _) -> Kccall("caml_add_float32", 2) + | Psubfloat (Boxed_float32, _) -> Kccall("caml_sub_float32", 2) + | Pmulfloat (Boxed_float32, _) -> Kccall("caml_mul_float32", 2) + | Pdivfloat (Boxed_float32, _) -> Kccall("caml_div_float32", 2) | Pstringlength -> Kccall("caml_ml_string_length", 1) | Pbyteslength -> Kccall("caml_ml_bytes_length", 1) | Pstringrefs -> Kccall("caml_string_get", 2) @@ -509,16 +509,16 @@ let comp_primitive stack_info p sz args = [Parrayset{s,u}]). *) | Parrayrefs (Pgenarray_ref _, index_kind, _) | Parrayrefs ((Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ - | Punboxedfloatarray_ref (Pfloat64 | Pfloat32) + | Punboxedfloatarray_ref (Unboxed_float64 | Unboxed_float32) | Punboxedintarray_ref _ | Pgcscannableproductarray_ref _ | Pgcignorableproductarray_ref _), (Punboxed_int_index _ as index_kind), _) -> Kccall(indexing_primitive index_kind "caml_array_get", 2) - | Parrayrefs ((Punboxedfloatarray_ref Pfloat64 | Pfloatarray_ref _), Ptagged_int_index, _) -> + | Parrayrefs ((Punboxedfloatarray_ref Unboxed_float64 | Pfloatarray_ref _), Ptagged_int_index, _) -> Kccall("caml_floatarray_get", 2) - | Parrayrefs ((Punboxedfloatarray_ref Pfloat32 | Punboxedintarray_ref _ + | Parrayrefs ((Punboxedfloatarray_ref Unboxed_float32 | Punboxedintarray_ref _ | Paddrarray_ref | Pintarray_ref | Pgcscannableproductarray_ref _ | Pgcignorableproductarray_ref _), @@ -527,16 +527,16 @@ let comp_primitive stack_info p sz args = Kccall("caml_array_get_addr", 2) | Parraysets (Pgenarray_set _, index_kind) | Parraysets ((Paddrarray_set _ | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set (Pfloat64 | Pfloat32) + | Punboxedfloatarray_set (Unboxed_float64 | Unboxed_float32) | Punboxedintarray_set _ | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _), (Punboxed_int_index _ as index_kind)) -> Kccall(indexing_primitive index_kind "caml_array_set", 3) - | Parraysets ((Punboxedfloatarray_set Pfloat64 | Pfloatarray_set), + | Parraysets ((Punboxedfloatarray_set Unboxed_float64 | Pfloatarray_set), Ptagged_int_index) -> Kccall("caml_floatarray_set", 3) - | Parraysets ((Punboxedfloatarray_set Pfloat32 | Punboxedintarray_set _ + | Parraysets ((Punboxedfloatarray_set Unboxed_float32 | Punboxedintarray_set _ | Paddrarray_set _ | Pintarray_set | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _), @@ -544,30 +544,30 @@ let comp_primitive stack_info p sz args = Kccall("caml_array_set_addr", 3) | Parrayrefu (Pgenarray_ref _, index_kind, _) | Parrayrefu ((Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ - | Punboxedfloatarray_ref (Pfloat64 | Pfloat32) + | Punboxedfloatarray_ref (Unboxed_float64 | Unboxed_float32) | Punboxedintarray_ref _ | Pgcscannableproductarray_ref _ | Pgcignorableproductarray_ref _), (Punboxed_int_index _ as index_kind), _) -> Kccall(indexing_primitive index_kind "caml_array_unsafe_get", 2) - | Parrayrefu ((Punboxedfloatarray_ref Pfloat64 | Pfloatarray_ref _), Ptagged_int_index, _) -> + | Parrayrefu ((Punboxedfloatarray_ref Unboxed_float64 | Pfloatarray_ref _), Ptagged_int_index, _) -> Kccall("caml_floatarray_unsafe_get", 2) - | Parrayrefu ((Punboxedfloatarray_ref Pfloat32 | Punboxedintarray_ref _ + | Parrayrefu ((Punboxedfloatarray_ref Unboxed_float32 | Punboxedintarray_ref _ | Paddrarray_ref | Pintarray_ref | Pgcscannableproductarray_ref _ | Pgcignorableproductarray_ref _), Ptagged_int_index, _) -> Kgetvectitem | Parraysetu (Pgenarray_set _, index_kind) | Parraysetu ((Paddrarray_set _ | Pintarray_set | Pfloatarray_set - | Punboxedfloatarray_set (Pfloat64 | Pfloat32) + | Punboxedfloatarray_set (Unboxed_float64 | Unboxed_float32) | Punboxedintarray_set _ | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _), (Punboxed_int_index _ as index_kind)) -> Kccall(indexing_primitive index_kind "caml_array_unsafe_set", 3) - | Parraysetu ((Punboxedfloatarray_set Pfloat64 | Pfloatarray_set), Ptagged_int_index) -> + | Parraysetu ((Punboxedfloatarray_set Unboxed_float64 | Pfloatarray_set), Ptagged_int_index) -> Kccall("caml_floatarray_unsafe_set", 3) - | Parraysetu ((Punboxedfloatarray_set Pfloat32 | Punboxedintarray_set _ + | Parraysetu ((Punboxedfloatarray_set Unboxed_float32 | Punboxedintarray_set _ | Paddrarray_set _ | Pintarray_set | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _), @@ -594,13 +594,13 @@ let comp_primitive stack_info p sz args = | Pintofbint bi -> comp_bint_primitive bi "to_int" args | Pcvtbint(src, dst, _) -> begin match (src, dst) with - | (Pint32, Pnativeint) -> Kccall("caml_nativeint_of_int32", 1) - | (Pnativeint, Pint32) -> Kccall("caml_nativeint_to_int32", 1) - | (Pint32, Pint64) -> Kccall("caml_int64_of_int32", 1) - | (Pint64, Pint32) -> Kccall("caml_int64_to_int32", 1) - | (Pnativeint, Pint64) -> Kccall("caml_int64_of_nativeint", 1) - | (Pint64, Pnativeint) -> Kccall("caml_int64_to_nativeint", 1) - | ((Pint32 | Pint64 | Pnativeint), _) -> + | (Boxed_int32, Boxed_nativeint) -> Kccall("caml_nativeint_of_int32", 1) + | (Boxed_nativeint, Boxed_int32) -> Kccall("caml_nativeint_to_int32", 1) + | (Boxed_int32, Boxed_int64) -> Kccall("caml_int64_of_int32", 1) + | (Boxed_int64, Boxed_int32) -> Kccall("caml_int64_to_int32", 1) + | (Boxed_nativeint, Boxed_int64) -> Kccall("caml_int64_of_nativeint", 1) + | (Boxed_int64, Boxed_nativeint) -> Kccall("caml_int64_to_nativeint", 1) + | ((Boxed_int32 | Boxed_int64 | Boxed_nativeint), _) -> fatal_error "Bytegen.comp_primitive: invalid Pcvtbint cast" end | Pnegbint (bi,_) -> comp_bint_primitive bi "neg" args @@ -853,8 +853,8 @@ let rec comp_expr stack_info env exp sz cont = (add_pop ndecl cont))) | Lprim((Popaque _ | Pobj_magic _), [arg], _) -> comp_expr stack_info env arg sz cont - | Lprim((Pbox_float ((Pfloat64 | Pfloat32), _) - | Punbox_float (Pfloat64 | Pfloat32)), [arg], _) -> + | Lprim((Pbox_float ((Boxed_float64 | Boxed_float32), _) + | Punbox_float (Boxed_float64 | Boxed_float32)), [arg], _) -> comp_expr stack_info env arg sz cont | Lprim((Pbox_int _ | Punbox_int _), [arg], _) -> comp_expr stack_info env arg sz cont @@ -931,11 +931,11 @@ let rec comp_expr stack_info env exp sz cont = (* arrays of unboxed types have the same representation as the boxed ones on bytecode *) | Pintarray | Paddrarray | Punboxedintarray _ - | Punboxedfloatarray Pfloat32 + | Punboxedfloatarray Unboxed_float32 | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> comp_args stack_info env args sz (Kmakeblock(List.length args, 0) :: cont) - | Pfloatarray | Punboxedfloatarray Pfloat64 -> + | Pfloatarray | Punboxedfloatarray Unboxed_float64 -> comp_args stack_info env args sz (Kmakefloatblock(List.length args) :: cont) | Punboxedvectorarray _ -> @@ -1003,7 +1003,7 @@ let rec comp_expr stack_info env exp sz cont = let nargs = List.length args - 1 in comp_args stack_info env args sz (comp_primitive stack_info p (sz + nargs - 1) args :: cont) - | Lprim (Pfloatcomp (Pfloat64, cmp), args, _) | Lprim (Punboxed_float_comp (Pfloat64, cmp), args, _) -> + | Lprim (Pfloatcomp (Boxed_float64, cmp), args, _) | Lprim (Punboxed_float_comp (Unboxed_float64, cmp), args, _) -> let cont = match cmp with | CFeq -> Kccall("caml_eq_float", 2) :: cont @@ -1018,7 +1018,7 @@ let rec comp_expr stack_info env exp sz cont = | CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont in comp_args stack_info env args sz cont - | Lprim (Pfloatcomp (Pfloat32, cmp), args, _) | Lprim (Punboxed_float_comp (Pfloat32, cmp), args, _) -> + | Lprim (Pfloatcomp (Boxed_float32, cmp), args, _) | Lprim (Punboxed_float_comp (Unboxed_float32, cmp), args, _) -> let cont = match cmp with | CFeq -> Kccall("caml_eq_float32", 2) :: cont diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 39d944d0db7..b16e0f78d75 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -183,7 +183,7 @@ type primitive = | Pmulfloat of boxed_float * locality_mode | Pdivfloat of boxed_float * locality_mode | Pfloatcomp of boxed_float * float_comparison - | Punboxed_float_comp of boxed_float * float_comparison + | Punboxed_float_comp of unboxed_float * float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -333,8 +333,8 @@ type primitive = and extern_repr = | Same_as_ocaml_repr of Jkind.Sort.Const.t | Unboxed_float of boxed_float - | Unboxed_vector of Primitive.boxed_vector - | Unboxed_integer of Primitive.boxed_integer + | Unboxed_vector of boxed_vector + | Unboxed_integer of boxed_integer | Untagged_int and external_call_description = extern_repr Primitive.description_gen @@ -370,9 +370,9 @@ and value_kind_non_null = and layout = | Ptop | Pvalue of value_kind - | Punboxed_float of boxed_float - | Punboxed_int of boxed_integer - | Punboxed_vector of boxed_vector + | Punboxed_float of unboxed_float + | Punboxed_int of unboxed_integer + | Punboxed_vector of unboxed_vector | Punboxed_product of layout list | Pbottom @@ -457,21 +457,29 @@ and array_index_kind = | Ptagged_int_index | Punboxed_int_index of unboxed_integer -and boxed_float = Primitive.boxed_float = - | Pfloat64 - | Pfloat32 +and unboxed_float = Primitive.unboxed_float = + | Unboxed_float64 + | Unboxed_float32 -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 +and unboxed_integer = Primitive.unboxed_integer = + | Unboxed_int64 + | Unboxed_nativeint + | Unboxed_int32 -and boxed_vector = Primitive.boxed_vector = - | Pvec128 +and unboxed_vector = Primitive.unboxed_vector = + | Unboxed_vec128 -and unboxed_float = boxed_float +and boxed_float = Primitive.boxed_float = + | Boxed_float64 + | Boxed_float32 -and unboxed_integer = boxed_integer +and boxed_integer = Primitive.boxed_integer = + | Boxed_int64 + | Boxed_nativeint + | Boxed_int32 -and unboxed_vector = boxed_vector +and boxed_vector = Primitive.boxed_vector = + | Boxed_vec128 and bigarray_kind = Pbigarray_unknown @@ -499,17 +507,9 @@ let generic_value = nullable = Nullable; } -let equal_boxed_integer = Primitive.equal_boxed_integer - -let equal_boxed_float = Primitive.equal_boxed_float - -let equal_boxed_vector = Primitive.equal_boxed_vector - -let compare_boxed_vector = Stdlib.compare - let print_boxed_vector ppf t = match t with - | Pvec128 -> Format.pp_print_string ppf "Vec128" + | Boxed_vec128 -> Format.pp_print_string ppf "Vec128" let equal_nullable x y = match x, y with @@ -521,9 +521,9 @@ let equal_nullable x y = let rec equal_value_kind_non_null x y = match x, y with | Pgenval, Pgenval -> true - | Pboxedfloatval f1, Pboxedfloatval f2 -> equal_boxed_float f1 f2 - | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2 - | Pboxedvectorval bv1, Pboxedvectorval bv2 -> equal_boxed_vector bv1 bv2 + | Pboxedfloatval f1, Pboxedfloatval f2 -> Primitive.equal_boxed_float f1 f2 + | Pboxedintval bi1, Pboxedintval bi2 -> Primitive.equal_boxed_integer bi1 bi2 + | Pboxedvectorval v1, Pboxedvectorval v2 -> Primitive.equal_boxed_vector v1 v2 | Pintval, Pintval -> true | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2 | Pvariant { consts = consts1; non_consts = non_consts1; }, @@ -570,9 +570,9 @@ let rec compatible_layout x y = | Pbottom, _ | _, Pbottom -> true | Pvalue _, Pvalue _ -> true - | Punboxed_float f1, Punboxed_float f2 -> equal_boxed_float f1 f2 - | Punboxed_int bi1, Punboxed_int bi2 -> equal_boxed_integer bi1 bi2 - | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector bi1 bi2 + | Punboxed_float f1, Punboxed_float f2 -> Primitive.equal_unboxed_float f1 f2 + | Punboxed_int bi1, Punboxed_int bi2 -> Primitive.equal_unboxed_integer bi1 bi2 + | Punboxed_vector bi1, Punboxed_vector bi2 -> Primitive.equal_unboxed_vector bi1 bi2 | Punboxed_product layouts1, Punboxed_product layouts2 -> List.compare_lengths layouts1 layouts2 = 0 && List.for_all2 compatible_layout layouts1 layouts2 @@ -586,9 +586,9 @@ let rec equal_ignorable_product_element_kind k1 k2 = match k1, k2 with | Pint_ignorable, Pint_ignorable -> true | Punboxedfloat_ignorable f1, Punboxedfloat_ignorable f2 -> - equal_boxed_float f1 f2 + Primitive.equal_unboxed_float f1 f2 | Punboxedint_ignorable i1, Punboxedint_ignorable i2 -> - equal_boxed_integer i1 i2 + Primitive.equal_unboxed_integer i1 i2 | Pproduct_ignorable p1, Pproduct_ignorable p2 -> List.equal equal_ignorable_product_element_kind p1 p2 | ( Pint_ignorable | Punboxedfloat_ignorable _ @@ -976,18 +976,14 @@ let layout_module_field = nullable_value Pgenval let layout_functor = non_null_value Pgenval let layout_boxed_float f = non_null_value (Pboxedfloatval f) let layout_unboxed_float f = Punboxed_float f -let layout_unboxed_nativeint = Punboxed_int Pnativeint -let layout_unboxed_int32 = Punboxed_int Pint32 -let layout_unboxed_int64 = Punboxed_int Pint64 +let layout_unboxed_nativeint = Punboxed_int Unboxed_nativeint +let layout_unboxed_int32 = Punboxed_int Unboxed_int32 +let layout_unboxed_int64 = Punboxed_int Unboxed_int64 let layout_string = non_null_value Pgenval let layout_unboxed_int ubi = Punboxed_int ubi -let layout_boxedint bi = non_null_value (Pboxedintval bi) - -let layout_unboxed_vector = function - | Pvec128 -> Punboxed_vector Pvec128 - -let layout_boxed_vector = function - | Pvec128 -> non_null_value (Pboxedvectorval Pvec128) +let layout_boxed_int bi = non_null_value (Pboxedintval bi) +let layout_unboxed_vector v = Punboxed_vector v +let layout_boxed_vector v = non_null_value (Pboxedvectorval v) let layout_lazy = nullable_value Pgenval let layout_lazy_contents = nullable_value Pgenval @@ -2100,16 +2096,16 @@ let primitive_can_raise prim = let constant_layout: constant -> layout = function | Const_int _ | Const_char _ -> non_null_value Pintval | Const_string _ -> non_null_value Pgenval - | Const_int32 _ -> non_null_value (Pboxedintval Pint32) - | Const_int64 _ -> non_null_value (Pboxedintval Pint64) - | Const_nativeint _ -> non_null_value (Pboxedintval Pnativeint) - | Const_unboxed_int32 _ -> Punboxed_int Pint32 - | Const_unboxed_int64 _ -> Punboxed_int Pint64 - | Const_unboxed_nativeint _ -> Punboxed_int Pnativeint - | Const_float _ -> non_null_value (Pboxedfloatval Pfloat64) - | Const_float32 _ -> non_null_value (Pboxedfloatval Pfloat32) - | Const_unboxed_float _ -> Punboxed_float Pfloat64 - | Const_unboxed_float32 _ -> Punboxed_float Pfloat32 + | Const_int32 _ -> non_null_value (Pboxedintval Boxed_int32) + | Const_int64 _ -> non_null_value (Pboxedintval Boxed_int64) + | Const_nativeint _ -> non_null_value (Pboxedintval Boxed_nativeint) + | Const_unboxed_int32 _ -> Punboxed_int Unboxed_int32 + | Const_unboxed_int64 _ -> Punboxed_int Unboxed_int64 + | Const_unboxed_nativeint _ -> Punboxed_int Unboxed_nativeint + | Const_float _ -> non_null_value (Pboxedfloatval Boxed_float64) + | Const_float32 _ -> non_null_value (Pboxedfloatval Boxed_float32) + | Const_unboxed_float _ -> Punboxed_float Unboxed_float64 + | Const_unboxed_float32 _ -> Punboxed_float Unboxed_float32 let structured_constant_layout = function | Const_base const -> constant_layout const @@ -2122,12 +2118,12 @@ let structured_constant_layout = function let rec layout_of_const_sort (c : Jkind.Sort.Const.t) : layout = match c with | Base Value -> layout_any_value - | Base Float64 -> layout_unboxed_float Pfloat64 - | Base Float32 -> layout_unboxed_float Pfloat32 + | Base Float64 -> layout_unboxed_float Unboxed_float64 + | Base Float32 -> layout_unboxed_float Unboxed_float32 | Base Word -> layout_unboxed_nativeint | Base Bits32 -> layout_unboxed_int32 | Base Bits64 -> layout_unboxed_int64 - | Base Vec128 -> layout_unboxed_vector Pvec128 + | Base Vec128 -> layout_unboxed_vector Unboxed_vec128 | Base Void -> assert false | Product sorts -> layout_unboxed_product (List.map layout_of_const_sort sorts) @@ -2136,7 +2132,7 @@ let layout_of_extern_repr : extern_repr -> _ = function | Untagged_int -> layout_int | Unboxed_vector v -> layout_boxed_vector v | Unboxed_float bf -> layout_boxed_float bf - | Unboxed_integer bi -> layout_boxedint bi + | Unboxed_integer bi -> layout_boxed_int bi | Same_as_ocaml_repr s -> layout_of_const_sort s let rec layout_of_scannable_kinds kinds = @@ -2158,7 +2154,7 @@ and layout_of_ignorable_kind = function let array_ref_kind_result_layout = function | Pintarray_ref -> layout_int - | Pfloatarray_ref _ -> layout_boxed_float Pfloat64 + | Pfloatarray_ref _ -> layout_boxed_float Boxed_float64 | Punboxedfloatarray_ref bf -> layout_unboxed_float bf | Pgenarray_ref _ | Paddrarray_ref -> layout_value_field | Punboxedintarray_ref i -> layout_unboxed_int i @@ -2170,17 +2166,17 @@ let layout_of_mixed_field (kind : mixed_block_read) = match kind with | Mread_value_prefix _ -> layout_value_field | Mread_flat_suffix (Flat_read_float_boxed (_ : locality_mode)) -> - layout_boxed_float Pfloat64 + layout_boxed_float Boxed_float64 | Mread_flat_suffix (Flat_read proj) -> match proj with | Imm -> layout_int - | Float64 -> layout_unboxed_float Pfloat64 - | Float32 -> layout_unboxed_float Pfloat32 + | Float64 -> layout_unboxed_float Unboxed_float64 + | Float32 -> layout_unboxed_float Unboxed_float32 | Bits32 -> layout_unboxed_int32 | Bits64 -> layout_unboxed_int64 - | Vec128 -> layout_unboxed_vector Pvec128 + | Vec128 -> layout_unboxed_vector Unboxed_vec128 | Word -> layout_unboxed_nativeint - | Float_boxed -> layout_boxed_float Pfloat64 + | Float_boxed -> layout_boxed_float Boxed_float64 let primitive_result_layout (p : primitive) = assert !Clflags.native_code; @@ -2206,16 +2202,16 @@ let primitive_result_layout (p : primitive) = | Pfield _ | Pfield_computed _ -> layout_value_field | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field) | Pmake_unboxed_product layouts -> layout_unboxed_product layouts - | Pfloatfield _ -> layout_boxed_float Pfloat64 - | Pfloatoffloat32 _ -> layout_boxed_float Pfloat64 - | Pfloat32offloat _ -> layout_boxed_float Pfloat32 + | Pfloatfield _ -> layout_boxed_float Boxed_float64 + | Pfloatoffloat32 _ -> layout_boxed_float Boxed_float64 + | Pfloat32offloat _ -> layout_boxed_float Boxed_float32 | Pfloatofint (f, _) | Pnegfloat (f, _) | Pabsfloat (f, _) | Paddfloat (f, _) | Psubfloat (f, _) | Pmulfloat (f, _) | Pdivfloat (f, _) | Pbox_float (f, _) -> layout_boxed_float f - | Pufloatfield _ -> Punboxed_float Pfloat64 - | Punbox_float float_kind -> Punboxed_float float_kind + | Pufloatfield _ -> Punboxed_float Unboxed_float64 + | Punbox_float f -> layout_unboxed_float (Primitive.unbox_float f) | Pbox_vector (v, _) -> layout_boxed_vector v - | Punbox_vector v -> Punboxed_vector v + | Punbox_vector v -> layout_unboxed_vector (Primitive.unbox_vector v) | Pmixedfield (_, kind, _, _) -> layout_of_mixed_field kind | Pccall { prim_native_repr_res = _, repr_res } -> layout_of_extern_repr repr_res | Praise _ -> layout_bottom @@ -2243,32 +2239,32 @@ let primitive_result_layout (p : primitive) = | Pandbint (bi, _) | Porbint (bi, _) | Pxorbint (bi, _) | Plslbint (bi, _) | Plsrbint (bi, _) | Pasrbint (bi, _) | Pbbswap (bi, _) | Pbox_int (bi, _) -> - layout_boxedint bi - | Punbox_int bi -> Punboxed_int bi + layout_boxed_int bi + | Punbox_int bi -> Punboxed_int (Primitive.unbox_integer bi) | Pstring_load_32 { boxed = true; _ } | Pbytes_load_32 { boxed = true; _ } | Pbigstring_load_32 { boxed = true; _ } -> - layout_boxedint Pint32 + layout_boxed_int Boxed_int32 | Pstring_load_f32 { boxed = true; _ } | Pbytes_load_f32 { boxed = true; _ } | Pbigstring_load_f32 { boxed = true; _ } -> - layout_boxed_float Pfloat32 + layout_boxed_float Boxed_float32 | Pstring_load_64 { boxed = true; _ } | Pbytes_load_64 { boxed = true; _ } | Pbigstring_load_64 { boxed = true; _ } -> - layout_boxedint Pint64 + layout_boxed_int Boxed_int64 | Pstring_load_128 { boxed = true; _ } | Pbytes_load_128 { boxed = true; _ } | Pbigstring_load_128 { boxed = true; _ } -> - layout_boxed_vector Pvec128 + layout_boxed_vector Boxed_vec128 | Pbigstring_load_32 { boxed = false; _ } | Pstring_load_32 { boxed = false; _ } - | Pbytes_load_32 { boxed = false; _ } -> layout_unboxed_int Pint32 + | Pbytes_load_32 { boxed = false; _ } -> layout_unboxed_int Unboxed_int32 | Pbigstring_load_f32 { boxed = false; _ } | Pstring_load_f32 { boxed = false; _ } - | Pbytes_load_f32 { boxed = false; _ } -> layout_unboxed_float Pfloat32 + | Pbytes_load_f32 { boxed = false; _ } -> layout_unboxed_float Unboxed_float32 | Pbigstring_load_64 { boxed = false; _ } | Pstring_load_64 { boxed = false; _ } - | Pbytes_load_64 { boxed = false; _ } -> layout_unboxed_int Pint64 + | Pbytes_load_64 { boxed = false; _ } -> layout_unboxed_int Unboxed_int64 | Pstring_load_128 { boxed = false; _ } | Pbytes_load_128 { boxed = false; _ } | Pbigstring_load_128 { boxed = false; _ } -> - layout_unboxed_vector Pvec128 + layout_unboxed_vector Unboxed_vec128 | Pfloatarray_load_128 { boxed = true; _ } | Pfloat_array_load_128 { boxed = true; _ } | Punboxed_float_array_load_128 { boxed = true; _ } @@ -2277,7 +2273,7 @@ let primitive_result_layout (p : primitive) = | Punboxed_int64_array_load_128 { boxed = true; _ } | Punboxed_nativeint_array_load_128 { boxed = true; _ } | Punboxed_int32_array_load_128 { boxed = true; _ } -> - layout_boxed_vector Pvec128 + layout_boxed_vector Boxed_vec128 | Pfloatarray_load_128 { boxed = false; _ } | Pfloat_array_load_128 { boxed = false; _ } | Punboxed_float_array_load_128 { boxed = false; _ } @@ -2286,22 +2282,22 @@ let primitive_result_layout (p : primitive) = | Punboxed_int64_array_load_128 { boxed = false; _ } | Punboxed_nativeint_array_load_128 { boxed = false; _ } | Punboxed_int32_array_load_128 { boxed = false; _ } -> - layout_unboxed_vector Pvec128 + layout_unboxed_vector Unboxed_vec128 | Pbigarrayref (_, _, kind, _) -> begin match kind with | Pbigarray_unknown -> layout_any_value | Pbigarray_float16 | Pbigarray_float32 -> (* float32 bigarrays return 64-bit floats for backward compatibility. Likewise for float16. *) - layout_boxed_float Pfloat64 - | Pbigarray_float32_t -> layout_boxed_float Pfloat32 - | Pbigarray_float64 -> layout_boxed_float Pfloat64 + layout_boxed_float Boxed_float64 + | Pbigarray_float32_t -> layout_boxed_float Boxed_float32 + | Pbigarray_float64 -> layout_boxed_float Boxed_float64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_caml_int -> layout_int - | Pbigarray_int32 -> layout_boxedint Pint32 - | Pbigarray_int64 -> layout_boxedint Pint64 - | Pbigarray_native_int -> layout_boxedint Pnativeint + | Pbigarray_int32 -> layout_boxed_int Boxed_int32 + | Pbigarray_int64 -> layout_boxed_int Boxed_int64 + | Pbigarray_native_int -> layout_boxed_int Boxed_nativeint | Pbigarray_complex32 | Pbigarray_complex64 -> layout_block end @@ -2316,7 +2312,7 @@ let primitive_result_layout (p : primitive) = (* CR ncourant: use an unboxed int64 here when it exists *) layout_any_value | (Parray_to_iarray | Parray_of_iarray) -> layout_any_value - | Pget_header _ -> layout_boxedint Pnativeint + | Pget_header _ -> layout_boxed_int Boxed_nativeint | Prunstack | Presume | Pperform | Preperform -> layout_any_value | Patomic_load { immediate_or_pointer = Immediate } -> layout_int | Patomic_load { immediate_or_pointer = Pointer } -> layout_any_value diff --git a/lambda/lambda.mli b/lambda/lambda.mli index c7735b851ca..c0ca0cebcdc 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -172,7 +172,7 @@ type primitive = | Pmulfloat of boxed_float * locality_mode | Pdivfloat of boxed_float * locality_mode | Pfloatcomp of boxed_float * float_comparison - | Punboxed_float_comp of boxed_float * float_comparison + | Punboxed_float_comp of unboxed_float * float_comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -347,8 +347,8 @@ type primitive = and extern_repr = | Same_as_ocaml_repr of Jkind.Sort.Const.t | Unboxed_float of boxed_float - | Unboxed_vector of Primitive.boxed_vector - | Unboxed_integer of Primitive.boxed_integer + | Unboxed_vector of boxed_vector + | Unboxed_integer of boxed_integer | Untagged_int and external_call_description = extern_repr Primitive.description_gen @@ -446,9 +446,9 @@ and value_kind_non_null = and layout = | Ptop | Pvalue of value_kind - | Punboxed_float of boxed_float - | Punboxed_int of boxed_integer - | Punboxed_vector of boxed_vector + | Punboxed_float of unboxed_float + | Punboxed_int of unboxed_integer + | Punboxed_vector of unboxed_vector | Punboxed_product of layout list | Pbottom @@ -488,21 +488,29 @@ and constructor_shape = flat_suffix : flat_element list; } -and boxed_float = Primitive.boxed_float = - | Pfloat64 - | Pfloat32 +and unboxed_float = Primitive.unboxed_float = + | Unboxed_float64 + | Unboxed_float32 -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 +and unboxed_integer = Primitive.unboxed_integer = + | Unboxed_int64 + | Unboxed_nativeint + | Unboxed_int32 -and boxed_vector = Primitive.boxed_vector = - | Pvec128 +and unboxed_vector = Primitive.unboxed_vector = + | Unboxed_vec128 -and unboxed_float = boxed_float +and boxed_float = Primitive.boxed_float = + | Boxed_float64 + | Boxed_float32 -and unboxed_integer = boxed_integer +and boxed_integer = Primitive.boxed_integer = + | Boxed_int64 + | Boxed_nativeint + | Boxed_int32 -and unboxed_vector = boxed_vector +and boxed_vector = Primitive.boxed_vector = + | Boxed_vec128 and bigarray_kind = Pbigarray_unknown @@ -531,14 +539,6 @@ val equal_layout : layout -> layout -> bool val compatible_layout : layout -> layout -> bool -val equal_boxed_float : boxed_float -> boxed_float -> bool - -val equal_boxed_integer : boxed_integer -> boxed_integer -> bool - -val equal_boxed_vector : boxed_vector -> boxed_vector -> bool - -val compare_boxed_vector : boxed_vector -> boxed_vector -> int - val print_boxed_vector : Format.formatter -> boxed_vector -> unit val equal_ignorable_product_element_kind : @@ -927,8 +927,8 @@ val layout_functor : layout val layout_module_field : layout val layout_string : layout val layout_boxed_float : boxed_float -> layout -val layout_unboxed_float : boxed_float -> layout -val layout_boxedint : boxed_integer -> layout +val layout_unboxed_float : unboxed_float -> layout +val layout_boxed_int : boxed_integer -> layout val layout_boxed_vector : boxed_vector -> layout (* A layout that is Pgenval because it is the field of a tuple *) val layout_tuple_element : layout diff --git a/lambda/matching.ml b/lambda/matching.ml index 4e5efe20040..d796fec46be 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -3150,46 +3150,46 @@ let combine_constant value_kind loc arg cst partial ctx def let hs, sw, fail = share_actions_tree value_kind sw fail in hs (Lstringswitch (arg, sw, fail, loc, value_kind)) | Const_float _ -> - make_test_sequence value_kind loc fail (Pfloatcomp (Pfloat64, CFneq)) - (Pfloatcomp (Pfloat64, CFlt)) arg + make_test_sequence value_kind loc fail (Pfloatcomp (Boxed_float64, CFneq)) + (Pfloatcomp (Boxed_float64, CFlt)) arg const_lambda_list | Const_float32 _ | Const_unboxed_float32 _ -> (* Should be caught in do_compile_matching. *) Misc.fatal_error "Found unexpected float32 literal pattern." | Const_unboxed_float _ -> make_test_sequence value_kind loc fail - (Punboxed_float_comp (Pfloat64, CFneq)) - (Punboxed_float_comp (Pfloat64, CFlt)) + (Punboxed_float_comp (Unboxed_float64, CFneq)) + (Punboxed_float_comp (Unboxed_float64, CFlt)) arg const_lambda_list | Const_int32 _ -> make_test_sequence value_kind loc fail - (Pbintcomp (Pint32, Cne)) - (Pbintcomp (Pint32, Clt)) + (Pbintcomp (Boxed_int32, Cne)) + (Pbintcomp (Boxed_int32, Clt)) arg const_lambda_list | Const_int64 _ -> make_test_sequence value_kind loc fail - (Pbintcomp (Pint64, Cne)) - (Pbintcomp (Pint64, Clt)) + (Pbintcomp (Boxed_int64, Cne)) + (Pbintcomp (Boxed_int64, Clt)) arg const_lambda_list | Const_nativeint _ -> make_test_sequence value_kind loc fail - (Pbintcomp (Pnativeint, Cne)) - (Pbintcomp (Pnativeint, Clt)) + (Pbintcomp (Boxed_nativeint, Cne)) + (Pbintcomp (Boxed_nativeint, Clt)) arg const_lambda_list | Const_unboxed_int32 _ -> make_test_sequence value_kind loc fail - (Punboxed_int_comp (Pint32, Cne)) - (Punboxed_int_comp (Pint32, Clt)) + (Punboxed_int_comp (Unboxed_int32, Cne)) + (Punboxed_int_comp (Unboxed_int32, Clt)) arg const_lambda_list | Const_unboxed_int64 _ -> make_test_sequence value_kind loc fail - (Punboxed_int_comp (Pint64, Cne)) - (Punboxed_int_comp (Pint64, Clt)) + (Punboxed_int_comp (Unboxed_int64, Cne)) + (Punboxed_int_comp (Unboxed_int64, Clt)) arg const_lambda_list | Const_unboxed_nativeint _ -> make_test_sequence value_kind loc fail - (Punboxed_int_comp (Pnativeint, Cne)) - (Punboxed_int_comp (Pnativeint, Clt)) + (Punboxed_int_comp (Unboxed_nativeint, Cne)) + (Punboxed_int_comp (Unboxed_nativeint, Clt)) arg const_lambda_list in (lambda1, Jumps.union local_jumps total) diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 0f2bf907a40..671d54dbcc7 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -19,6 +19,30 @@ open Primitive open Types open Lambda +let unboxed_integer = function + | Unboxed_nativeint -> "unboxed_nativeint" + | Unboxed_int32 -> "unboxed_int32" + | Unboxed_int64 -> "unboxed_int64" + +let unboxed_float = function + | Unboxed_float64 -> "unboxed_float" + | Unboxed_float32 -> "unboxed_float32" + +let unboxed_vector = function + | Unboxed_vec128 -> "unboxed_vec128" + +let boxed_integer = function + | Boxed_nativeint -> "nativeint" + | Boxed_int32 -> "int32" + | Boxed_int64 -> "int64" + +let boxed_float = function + | Boxed_float64 -> "float" + | Boxed_float32 -> "float32" + +let boxed_vector = function + | Boxed_vec128 -> "vec128" + let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n | Const_base(Const_char c) -> fprintf ppf "%C" c @@ -67,15 +91,6 @@ and struct_consts ppf (hd, tl) = in fprintf ppf "%a%a" struct_const hd sconsts tl -let unboxed_float = function - | Pfloat64 -> "unboxed_float" - | Pfloat32 -> "unboxed_float32" - -let unboxed_integer = function - | Pint32 -> "unboxed_int32" - | Pint64 -> "unboxed_int64" - | Pnativeint -> "unboxed_nativeint" - let rec scannable_product_element_kinds kinds = "[" ^ String.concat "; " (List.map scannable_product_element_kind kinds) ^ "]" @@ -100,7 +115,7 @@ let array_kind = function | Pfloatarray -> "float" | Punboxedfloatarray f -> unboxed_float f | Punboxedintarray i -> unboxed_integer i - | Punboxedvectorarray Pvec128 -> "unboxed_vec128" + | Punboxedvectorarray v -> unboxed_vector v | Pgcscannableproductarray kinds -> "scannableproduct " ^ scannable_product_element_kinds kinds | Pgcignorableproductarray kinds -> @@ -120,12 +135,12 @@ let array_ref_kind ppf k = | Paddrarray_ref -> fprintf ppf "addr" | Pintarray_ref -> fprintf ppf "int" | Pfloatarray_ref mode -> fprintf ppf "float%a" pp_mode mode - | Punboxedfloatarray_ref Pfloat64 -> fprintf ppf "unboxed_float" - | Punboxedfloatarray_ref Pfloat32 -> fprintf ppf "unboxed_float32" - | Punboxedintarray_ref Pint32 -> fprintf ppf "unboxed_int32" - | Punboxedintarray_ref Pint64 -> fprintf ppf "unboxed_int64" - | Punboxedintarray_ref Pnativeint -> fprintf ppf "unboxed_nativeint" - | Punboxedvectorarray_ref Pvec128 -> fprintf ppf "unboxed_vec128" + | Punboxedfloatarray_ref Unboxed_float64 -> fprintf ppf "unboxed_float" + | Punboxedfloatarray_ref Unboxed_float32 -> fprintf ppf "unboxed_float32" + | Punboxedintarray_ref Unboxed_int32 -> fprintf ppf "unboxed_int32" + | Punboxedintarray_ref Unboxed_int64 -> fprintf ppf "unboxed_int64" + | Punboxedintarray_ref Unboxed_nativeint -> fprintf ppf "unboxed_nativeint" + | Punboxedvectorarray_ref Unboxed_vec128 -> fprintf ppf "unboxed_vec128" | Pgcscannableproductarray_ref kinds -> fprintf ppf "scannableproduct %s" (scannable_product_element_kinds kinds) | Pgcignorableproductarray_ref kinds -> @@ -134,9 +149,9 @@ let array_ref_kind ppf k = let array_index_kind ppf k = match k with | Ptagged_int_index -> fprintf ppf "int" - | Punboxed_int_index Pint32 -> fprintf ppf "unboxed_int32" - | Punboxed_int_index Pint64 -> fprintf ppf "unboxed_int64" - | Punboxed_int_index Pnativeint -> fprintf ppf "unboxed_nativeint" + | Punboxed_int_index Unboxed_int32 -> fprintf ppf "unboxed_int32" + | Punboxed_int_index Unboxed_int64 -> fprintf ppf "unboxed_int64" + | Punboxed_int_index Unboxed_nativeint -> fprintf ppf "unboxed_nativeint" let array_set_kind ppf k = let pp_mode ppf = function @@ -148,12 +163,12 @@ let array_set_kind ppf k = | Paddrarray_set mode -> fprintf ppf "addr%a" pp_mode mode | Pintarray_set -> fprintf ppf "int" | Pfloatarray_set -> fprintf ppf "float" - | Punboxedfloatarray_set Pfloat64 -> fprintf ppf "unboxed_float" - | Punboxedfloatarray_set Pfloat32 -> fprintf ppf "unboxed_float32" - | Punboxedintarray_set Pint32 -> fprintf ppf "unboxed_int32" - | Punboxedintarray_set Pint64 -> fprintf ppf "unboxed_int64" - | Punboxedintarray_set Pnativeint -> fprintf ppf "unboxed_nativeint" - | Punboxedvectorarray_set Pvec128 -> fprintf ppf "unboxed_vec128" + | Punboxedfloatarray_set Unboxed_float64 -> fprintf ppf "unboxed_float" + | Punboxedfloatarray_set Unboxed_float32 -> fprintf ppf "unboxed_float32" + | Punboxedintarray_set Unboxed_int32 -> fprintf ppf "unboxed_int32" + | Punboxedintarray_set Unboxed_int64 -> fprintf ppf "unboxed_int64" + | Punboxedintarray_set Unboxed_nativeint -> fprintf ppf "unboxed_nativeint" + | Punboxedvectorarray_set Unboxed_vec128 -> fprintf ppf "unboxed_vec128" | Pgcscannableproductarray_set (mode, kinds) -> fprintf ppf "scannableproduct%a %s" pp_mode mode (scannable_product_element_kinds kinds) @@ -168,18 +183,6 @@ let locality_mode ppf = function | Alloc_heap -> fprintf ppf "heap" | Alloc_local -> fprintf ppf "local" -let boxed_integer_name = function - | Pnativeint -> "nativeint" - | Pint32 -> "int32" - | Pint64 -> "int64" - -let boxed_float_name = function - | Pfloat64 -> "float" - | Pfloat32 -> "float32" - -let boxed_vector_name = function - | Pvec128 -> "vec128" - let constructor_shape print_value_kind ppf shape = let value_fields, flat_fields = match shape with @@ -229,13 +232,13 @@ let rec value_kind_non_null or_null_suffix ppf = function | Pgenval -> () | Pintval -> fprintf ppf "[int%s]" or_null_suffix | Pboxedfloatval bf -> - fprintf ppf "[%s%s]" (boxed_float_name bf) or_null_suffix + fprintf ppf "[%s%s]" (boxed_float bf) or_null_suffix | Parrayval elt_kind -> fprintf ppf "[%sarray%s]" (array_kind elt_kind) or_null_suffix | Pboxedintval bi -> - fprintf ppf "[%s%s]" (boxed_integer_name bi) or_null_suffix + fprintf ppf "[%s%s]" (boxed_integer bi) or_null_suffix | Pboxedvectorval bv -> - fprintf ppf "[%s%s]" (boxed_vector_name bv) or_null_suffix + fprintf ppf "[%s%s]" (boxed_vector bv) or_null_suffix | Pvariant { consts; non_consts; } -> variant_kind or_null_suffix (value_kind value_kind_non_null') ppf ~consts ~non_consts @@ -244,13 +247,13 @@ and value_kind_non_null' or_null_suffix ppf = function | Pgenval -> fprintf ppf "*" | Pintval -> fprintf ppf "[int%s]" or_null_suffix | Pboxedfloatval bf -> - fprintf ppf "[%s%s]" (boxed_float_name bf) or_null_suffix + fprintf ppf "[%s%s]" (boxed_float bf) or_null_suffix | Parrayval elt_kind -> fprintf ppf "[%sarray%s]" (array_kind elt_kind) or_null_suffix | Pboxedintval bi -> - fprintf ppf "[%s%s]" (boxed_integer_name bi) or_null_suffix + fprintf ppf "[%s%s]" (boxed_integer bi) or_null_suffix | Pboxedvectorval bv -> - fprintf ppf "[%s%s]" (boxed_vector_name bv) or_null_suffix + fprintf ppf "[%s%s]" (boxed_vector bv) or_null_suffix | Pvariant { consts; non_consts; } -> variant_kind or_null_suffix (value_kind value_kind_non_null') ppf ~consts ~non_consts @@ -263,9 +266,9 @@ let rec layout' is_top ppf layout_ = ppf k | Ptop -> fprintf ppf "[top]" | Pbottom -> fprintf ppf "[bottom]" - | Punboxed_float bf -> fprintf ppf "[unboxed_%s]" (boxed_float_name bf) - | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi) - | Punboxed_vector bv -> fprintf ppf "[unboxed_%s]" (boxed_vector_name bv) + | Punboxed_float bf -> fprintf ppf "[%s]" (unboxed_float bf) + | Punboxed_int bi -> fprintf ppf "[%s]" (unboxed_integer bi) + | Punboxed_vector bv -> fprintf ppf "[%s]" (unboxed_vector bv) | Punboxed_product layouts -> fprintf ppf "@[#(%a)@]" (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") (layout' false)) @@ -287,20 +290,20 @@ let return_kind ppf (mode, kind) = | Pgenval -> fprintf ppf ": %s@ " smode | Pintval -> fprintf ppf ": int@ " | Pboxedfloatval bf -> - fprintf ppf ": %s%s%s@ " smode (boxed_float_name bf) or_null_suffix + fprintf ppf ": %s%s%s@ " smode (boxed_float bf) or_null_suffix | Parrayval elt_kind -> fprintf ppf ": %s%sarray%s@ " smode (array_kind elt_kind) or_null_suffix | Pboxedintval bi -> - fprintf ppf ": %s%s%s@ " smode (boxed_integer_name bi) or_null_suffix + fprintf ppf ": %s%s%s@ " smode (boxed_integer bi) or_null_suffix | Pboxedvectorval bv -> - fprintf ppf ": %s%s%s@ " smode (boxed_vector_name bv) or_null_suffix + fprintf ppf ": %s%s%s@ " smode (boxed_vector bv) or_null_suffix | Pvariant { consts; non_consts; } -> variant_kind or_null_suffix (value_kind value_kind_non_null') ppf ~consts ~non_consts end - | Punboxed_float bf -> fprintf ppf ": unboxed_%s@ " (boxed_float_name bf) - | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi) - | Punboxed_vector bv -> fprintf ppf ": unboxed_%s@ " (boxed_vector_name bv) + | Punboxed_float bf -> fprintf ppf ": %s@ " (unboxed_float bf) + | Punboxed_int bi -> fprintf ppf ": %s@ " (unboxed_integer bi) + | Punboxed_vector bv -> fprintf ppf ": %s@ " (unboxed_vector bv) | Punboxed_product _ -> fprintf ppf ": %a" layout kind | Ptop -> fprintf ppf ": top@ " | Pbottom -> fprintf ppf ": bottom@ " @@ -309,13 +312,13 @@ let field_kind_non_null or_null_suffix ppf = function | Pgenval -> pp_print_string ppf "*" | Pintval -> fprintf ppf "int%s" or_null_suffix | Pboxedfloatval bf -> - fprintf ppf "%s%s" (boxed_float_name bf) or_null_suffix + fprintf ppf "%s%s" (boxed_float bf) or_null_suffix | Parrayval elt_kind -> fprintf ppf "%s-array%s" (array_kind elt_kind) or_null_suffix | Pboxedintval bi -> - fprintf ppf "%s%s" (boxed_integer_name bi) or_null_suffix + fprintf ppf "%s%s" (boxed_integer bi) or_null_suffix | Pboxedvectorval bv -> - fprintf ppf "%s%s" (boxed_vector_name bv) or_null_suffix + fprintf ppf "%s%s" (boxed_vector bv) or_null_suffix | Pvariant { consts; non_consts; } -> fprintf ppf "@[[(consts (%a))@ (non_consts (%a))%s]@]" (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int) @@ -332,39 +335,39 @@ let locality_kind = function | Alloc_local -> "[L]" let print_boxed_integer_conversion ppf bi1 bi2 m = - fprintf ppf "%s_of_%s%s" (boxed_integer_name bi2) (boxed_integer_name bi1) + fprintf ppf "%s_of_%s%s" (boxed_integer bi2) (boxed_integer bi1) (locality_kind m) let boxed_integer_mark name bi m = match bi with - | Pnativeint -> Printf.sprintf "Nativeint.%s%s" name (locality_kind m) - | Pint32 -> Printf.sprintf "Int32.%s%s" name (locality_kind m) - | Pint64 -> Printf.sprintf "Int64.%s%s" name (locality_kind m) + | Boxed_nativeint -> Printf.sprintf "Nativeint.%s%s" name (locality_kind m) + | Boxed_int32 -> Printf.sprintf "Int32.%s%s" name (locality_kind m) + | Boxed_int64 -> Printf.sprintf "Int64.%s%s" name (locality_kind m) let print_boxed_integer name ppf bi m = fprintf ppf "%s" (boxed_integer_mark name bi m);; let unboxed_integer_mark name bi m = match bi with - | Pnativeint -> Printf.sprintf "Nativeint_u.%s%s" name (locality_kind m) - | Pint32 -> Printf.sprintf "Int32_u.%s%s" name (locality_kind m) - | Pint64 -> Printf.sprintf "Int64_u.%s%s" name (locality_kind m) + | Unboxed_nativeint -> Printf.sprintf "Nativeint_u.%s%s" name (locality_kind m) + | Unboxed_int32 -> Printf.sprintf "Int32_u.%s%s" name (locality_kind m) + | Unboxed_int64 -> Printf.sprintf "Int64_u.%s%s" name (locality_kind m) let print_unboxed_integer name ppf bi m = fprintf ppf "%s" (unboxed_integer_mark name bi m);; let boxed_float_mark name bf m = match bf with - | Pfloat64 -> Printf.sprintf "Float.%s%s" name (locality_kind m) - | Pfloat32 -> Printf.sprintf "Float32.%s%s" name (locality_kind m) + | Boxed_float64 -> Printf.sprintf "Float.%s%s" name (locality_kind m) + | Boxed_float32 -> Printf.sprintf "Float32.%s%s" name (locality_kind m) let print_boxed_float name ppf bf m = fprintf ppf "%s" (boxed_float_mark name bf m);; let unboxed_float_mark name bf m = match bf with - | Pfloat64 -> Printf.sprintf "Float_u.%s%s" name (locality_kind m) - | Pfloat32 -> Printf.sprintf "Float32_u.%s%s" name (locality_kind m) + | Unboxed_float64 -> Printf.sprintf "Float_u.%s%s" name (locality_kind m) + | Unboxed_float32 -> Printf.sprintf "Float32_u.%s%s" name (locality_kind m) let print_unboxed_float name ppf bf m = fprintf ppf "%s" (unboxed_float_mark name bf m);; @@ -627,15 +630,15 @@ let primitive ppf = function | Pasrint -> fprintf ppf "asr" | Pintcomp(cmp) -> integer_comparison ppf cmp | Pcompare_ints -> fprintf ppf "compare_ints" - | Pcompare_floats bf -> fprintf ppf "compare_floats %s" (boxed_float_name bf) - | Pcompare_bints bi -> fprintf ppf "compare_bints %s" (boxed_integer_name bi) + | Pcompare_floats bf -> fprintf ppf "compare_floats %s" (boxed_float bf) + | Pcompare_bints bi -> fprintf ppf "compare_bints %s" (boxed_integer bi) | Poffsetint n -> fprintf ppf "%i+" n | Poffsetref n -> fprintf ppf "+:=%i"n - | Pfloatoffloat32 m -> print_boxed_float "float_of_float32" ppf Pfloat32 m - | Pfloat32offloat m -> print_boxed_float "float32_of_float" ppf Pfloat64 m - | Pintoffloat bf -> fprintf ppf "int_of_%s" (boxed_float_name bf) + | Pfloatoffloat32 m -> print_boxed_float "float_of_float32" ppf Boxed_float32 m + | Pfloat32offloat m -> print_boxed_float "float32_of_float" ppf Boxed_float64 m + | Pintoffloat bf -> fprintf ppf "int_of_%s" (boxed_float bf) | Pfloatofint (bf,m) -> - fprintf ppf "%s_of_int%s" (boxed_float_name bf) (locality_kind m) + fprintf ppf "%s_of_int%s" (boxed_float bf) (locality_kind m) | Pabsfloat (bf,m) -> print_boxed_float "abs" ppf bf m | Pnegfloat (bf,m) -> print_boxed_float "neg" ppf bf m | Paddfloat (bf,m) -> print_boxed_float "add" ppf bf m @@ -900,15 +903,15 @@ let primitive ppf = function | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name | Pobj_dup -> fprintf ppf "obj_dup" | Pobj_magic _ -> fprintf ppf "obj_magic" - | Punbox_float bf -> fprintf ppf "unbox_%s" (boxed_float_name bf) + | Punbox_float bf -> fprintf ppf "unbox_%s" (boxed_float bf) | Pbox_float (bf,m) -> - fprintf ppf "box_%s%s" (boxed_float_name bf) (locality_kind m) - | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi) + fprintf ppf "box_%s%s" (boxed_float bf) (locality_kind m) + | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer bi) | Pbox_int (bi, m) -> - fprintf ppf "box_%s%s" (boxed_integer_name bi) (locality_kind m) - | Punbox_vector bi -> fprintf ppf "unbox_%s" (boxed_vector_name bi) + fprintf ppf "box_%s%s" (boxed_integer bi) (locality_kind m) + | Punbox_vector bi -> fprintf ppf "unbox_%s" (boxed_vector bi) | Pbox_vector (bi, m) -> - fprintf ppf "box_%s%s" (boxed_vector_name bi) (locality_kind m) + fprintf ppf "box_%s%s" (boxed_vector bi) (locality_kind m) | Parray_to_iarray -> fprintf ppf "array_to_iarray" | Parray_of_iarray -> fprintf ppf "array_of_iarray" | Pget_header m -> fprintf ppf "get_header%s" (locality_kind m) diff --git a/lambda/transl_array_comprehension.ml b/lambda/transl_array_comprehension.ml index 61c4b65b784..f8ac4fea29d 100644 --- a/lambda/transl_array_comprehension.ml +++ b/lambda/transl_array_comprehension.ml @@ -696,38 +696,38 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing = (* Case 2: Fixed size, known array kind *) | Fixed_size, (Pintarray | Paddrarray) -> Immutable StrictOpt, make_vect ~loc ~length:array_size.var ~init:(int 0) - | Fixed_size, (Pfloatarray | Punboxedfloatarray Pfloat64) -> + | Fixed_size, (Pfloatarray | Punboxedfloatarray Unboxed_float64) -> (* The representations of these two are the same, it's only accesses that differ. *) Immutable StrictOpt, make_float_vect ~loc array_size.var - | Fixed_size, Punboxedfloatarray Pfloat32 -> + | Fixed_size, Punboxedfloatarray Unboxed_float32 -> Immutable StrictOpt, make_unboxed_float32_vect ~loc array_size.var - | Fixed_size, Punboxedintarray Pint32 -> + | Fixed_size, Punboxedintarray Unboxed_int32 -> Immutable StrictOpt, make_unboxed_int32_vect ~loc array_size.var - | Fixed_size, Punboxedintarray Pint64 -> + | Fixed_size, Punboxedintarray Unboxed_int64 -> Immutable StrictOpt, make_unboxed_int64_vect ~loc array_size.var - | Fixed_size, Punboxedintarray Pnativeint -> + | Fixed_size, Punboxedintarray Unboxed_nativeint -> Immutable StrictOpt, make_unboxed_nativeint_vect ~loc array_size.var - | Fixed_size, Punboxedvectorarray Pvec128 -> + | Fixed_size, Punboxedvectorarray Unboxed_vec128 -> Immutable StrictOpt, make_unboxed_vec128_vect ~loc array_size.var (* Case 3: Unknown size, known array kind *) | Dynamic_size, (Pintarray | Paddrarray) -> Mutable, Resizable_array.make ~loc array_kind (int 0) | Dynamic_size, Pfloatarray -> Mutable, Resizable_array.make ~loc array_kind (float 0.) - | Dynamic_size, Punboxedfloatarray Pfloat64 -> + | Dynamic_size, Punboxedfloatarray Unboxed_float64 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_float 0.) - | Dynamic_size, Punboxedfloatarray Pfloat32 -> + | Dynamic_size, Punboxedfloatarray Unboxed_float32 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_float32 0.) - | Dynamic_size, Punboxedintarray Pint32 -> + | Dynamic_size, Punboxedintarray Unboxed_int32 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_int32 0l) - | Dynamic_size, Punboxedintarray Pint64 -> + | Dynamic_size, Punboxedintarray Unboxed_int64 -> Mutable, Resizable_array.make ~loc array_kind (unboxed_int64 0L) - | Dynamic_size, Punboxedintarray Pnativeint -> + | Dynamic_size, Punboxedintarray Unboxed_nativeint -> ( Mutable, Resizable_array.make ~loc array_kind (unboxed_nativeint Targetint.zero) ) - | Dynamic_size, Punboxedvectorarray Pvec128 -> + | Dynamic_size, Punboxedvectorarray Unboxed_vec128 -> (* The above cases are not actually allowed/tested yet. *) Misc.fatal_error "Comprehensions on arrays of unboxed types are not yet supported." @@ -819,7 +819,7 @@ let body ~loc ~array_kind ~array_size ~array_sizing ~array ~index ~body = set_element_in_bounds elt.var, layout_unit )) | Pintarray | Paddrarray | Pfloatarray - | Punboxedfloatarray (Pfloat64 | Pfloat32) + | Punboxedfloatarray (Unboxed_float64 | Unboxed_float32) | Punboxedintarray _ | Punboxedvectorarray _ -> set_element_in_bounds body | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> diff --git a/lambda/translprim.ml b/lambda/translprim.ml index f9919211e25..dd9716be0d7 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -310,9 +310,9 @@ let indexing_primitives = let index_kinds = [ (Ptagged_int_index, ""); - (Punboxed_int_index Pnativeint, "_indexed_by_nativeint#"); - (Punboxed_int_index Pint32, "_indexed_by_int32#"); - (Punboxed_int_index Pint64, "_indexed_by_int64#"); + (Punboxed_int_index Unboxed_nativeint, "_indexed_by_nativeint#"); + (Punboxed_int_index Unboxed_int32, "_indexed_by_int32#"); + (Punboxed_int_index Unboxed_int64, "_indexed_by_int64#"); ] in (let ( let* ) x f = List.concat_map f x in @@ -429,34 +429,34 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%decr" -> Primitive ((Poffsetref(-1)), 1) | "%floatoffloat32" -> Primitive (Pfloatoffloat32 mode, 1) | "%float32offloat" -> Primitive (Pfloat32offloat mode, 1) - | "%intoffloat32" -> Primitive (Pintoffloat Pfloat32, 1) - | "%float32ofint" -> Primitive (Pfloatofint (Pfloat32, mode), 1) - | "%negfloat32" -> Primitive (Pnegfloat (Pfloat32, mode), 1) - | "%absfloat32" -> Primitive (Pabsfloat (Pfloat32, mode), 1) - | "%addfloat32" -> Primitive (Paddfloat (Pfloat32, mode), 2) - | "%subfloat32" -> Primitive (Psubfloat (Pfloat32, mode), 2) - | "%mulfloat32" -> Primitive (Pmulfloat (Pfloat32, mode), 2) - | "%divfloat32" -> Primitive (Pdivfloat (Pfloat32, mode), 2) - | "%eqfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFeq)), 2) - | "%noteqfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFneq)), 2) - | "%ltfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFlt)), 2) - | "%lefloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFle)), 2) - | "%gtfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFgt)), 2) - | "%gefloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFge)), 2) - | "%intoffloat" -> Primitive (Pintoffloat Pfloat64, 1) - | "%floatofint" -> Primitive (Pfloatofint (Pfloat64, mode), 1) - | "%negfloat" -> Primitive (Pnegfloat (Pfloat64, mode), 1) - | "%absfloat" -> Primitive (Pabsfloat (Pfloat64, mode), 1) - | "%addfloat" -> Primitive (Paddfloat (Pfloat64, mode), 2) - | "%subfloat" -> Primitive (Psubfloat (Pfloat64, mode), 2) - | "%mulfloat" -> Primitive (Pmulfloat (Pfloat64, mode), 2) - | "%divfloat" -> Primitive (Pdivfloat (Pfloat64, mode), 2) - | "%eqfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFeq)), 2) - | "%noteqfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFneq)), 2) - | "%ltfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFlt)), 2) - | "%lefloat" -> Primitive ((Pfloatcomp (Pfloat64, CFle)), 2) - | "%gtfloat" -> Primitive ((Pfloatcomp (Pfloat64, CFgt)), 2) - | "%gefloat" -> Primitive ((Pfloatcomp (Pfloat64, CFge)), 2) + | "%intoffloat32" -> Primitive (Pintoffloat Boxed_float32, 1) + | "%float32ofint" -> Primitive (Pfloatofint (Boxed_float32, mode), 1) + | "%negfloat32" -> Primitive (Pnegfloat (Boxed_float32, mode), 1) + | "%absfloat32" -> Primitive (Pabsfloat (Boxed_float32, mode), 1) + | "%addfloat32" -> Primitive (Paddfloat (Boxed_float32, mode), 2) + | "%subfloat32" -> Primitive (Psubfloat (Boxed_float32, mode), 2) + | "%mulfloat32" -> Primitive (Pmulfloat (Boxed_float32, mode), 2) + | "%divfloat32" -> Primitive (Pdivfloat (Boxed_float32, mode), 2) + | "%eqfloat32" -> Primitive ((Pfloatcomp (Boxed_float32, CFeq)), 2) + | "%noteqfloat32" -> Primitive ((Pfloatcomp (Boxed_float32, CFneq)), 2) + | "%ltfloat32" -> Primitive ((Pfloatcomp (Boxed_float32, CFlt)), 2) + | "%lefloat32" -> Primitive ((Pfloatcomp (Boxed_float32, CFle)), 2) + | "%gtfloat32" -> Primitive ((Pfloatcomp (Boxed_float32, CFgt)), 2) + | "%gefloat32" -> Primitive ((Pfloatcomp (Boxed_float32, CFge)), 2) + | "%intoffloat" -> Primitive (Pintoffloat Boxed_float64, 1) + | "%floatofint" -> Primitive (Pfloatofint (Boxed_float64, mode), 1) + | "%negfloat" -> Primitive (Pnegfloat (Boxed_float64, mode), 1) + | "%absfloat" -> Primitive (Pabsfloat (Boxed_float64, mode), 1) + | "%addfloat" -> Primitive (Paddfloat (Boxed_float64, mode), 2) + | "%subfloat" -> Primitive (Psubfloat (Boxed_float64, mode), 2) + | "%mulfloat" -> Primitive (Pmulfloat (Boxed_float64, mode), 2) + | "%divfloat" -> Primitive (Pdivfloat (Boxed_float64, mode), 2) + | "%eqfloat" -> Primitive ((Pfloatcomp (Boxed_float64, CFeq)), 2) + | "%noteqfloat" -> Primitive ((Pfloatcomp (Boxed_float64, CFneq)), 2) + | "%ltfloat" -> Primitive ((Pfloatcomp (Boxed_float64, CFlt)), 2) + | "%lefloat" -> Primitive ((Pfloatcomp (Boxed_float64, CFle)), 2) + | "%gtfloat" -> Primitive ((Pfloatcomp (Boxed_float64, CFgt)), 2) + | "%gefloat" -> Primitive ((Pfloatcomp (Boxed_float64, CFge)), 2) | "%string_length" -> Primitive (Pstringlength, 1) | "%string_safe_get" -> Primitive (Pstringrefs, 2) | "%string_safe_set" -> Primitive (Pbytessets, 3) @@ -484,51 +484,51 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = 3) | "%array_safe_get_indexed_by_int64#" -> Primitive - ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Pint64, Mutable)), 2) + ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Unboxed_int64, Mutable)), 2) | "%array_safe_set_indexed_by_int64#" -> Primitive (Parraysets - (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint64), + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_int64), 3) | "%array_unsafe_get_indexed_by_int64#" -> Primitive - (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Pint64, Mutable), 2) + (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Unboxed_int64, Mutable), 2) | "%array_unsafe_set_indexed_by_int64#" -> Primitive ((Parraysetu - (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint64)), + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_int64)), 3) | "%array_safe_get_indexed_by_int32#" -> Primitive - ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Pint32, Mutable)), 2) + ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Unboxed_int32, Mutable)), 2) | "%array_safe_set_indexed_by_int32#" -> Primitive (Parraysets - (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint32), + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_int32), 3) | "%array_unsafe_get_indexed_by_int32#" -> Primitive - (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Pint32, Mutable), 2) + (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Unboxed_int32, Mutable), 2) | "%array_unsafe_set_indexed_by_int32#" -> Primitive ((Parraysetu - (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pint32)), + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_int32)), 3) | "%array_safe_get_indexed_by_nativeint#" -> Primitive - ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Pnativeint, Mutable)), 2) + ((Parrayrefs (gen_array_ref_kind mode, Punboxed_int_index Unboxed_nativeint, Mutable)), 2) | "%array_safe_set_indexed_by_nativeint#" -> Primitive (Parraysets - (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pnativeint), + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_nativeint), 3) | "%array_unsafe_get_indexed_by_nativeint#" -> Primitive - (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Pnativeint, Mutable), 2) + (Parrayrefu (gen_array_ref_kind mode, Punboxed_int_index Unboxed_nativeint, Mutable), 2) | "%array_unsafe_set_indexed_by_nativeint#" -> Primitive ((Parraysetu - (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Pnativeint)), + (gen_array_set_kind (get_first_arg_mode ()), Punboxed_int_index Unboxed_nativeint)), 3) | "%makearray_dynamic" -> Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha; @@ -553,60 +553,60 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%obj_is_int" -> Primitive (Pisint { variant_only = false }, 1) | "%is_null" -> Primitive (Pisnull, 1) | "%lazy_force" -> Lazy_force pos - | "%nativeint_of_int" -> Primitive ((Pbintofint (Pnativeint, mode)), 1) - | "%nativeint_to_int" -> Primitive ((Pintofbint Pnativeint), 1) - | "%nativeint_neg" -> Primitive ((Pnegbint (Pnativeint, mode)), 1) - | "%nativeint_add" -> Primitive ((Paddbint (Pnativeint, mode)), 2) - | "%nativeint_sub" -> Primitive ((Psubbint (Pnativeint, mode)), 2) - | "%nativeint_mul" -> Primitive ((Pmulbint (Pnativeint, mode)), 2) + | "%nativeint_of_int" -> Primitive ((Pbintofint (Boxed_nativeint, mode)), 1) + | "%nativeint_to_int" -> Primitive ((Pintofbint Boxed_nativeint), 1) + | "%nativeint_neg" -> Primitive ((Pnegbint (Boxed_nativeint, mode)), 1) + | "%nativeint_add" -> Primitive ((Paddbint (Boxed_nativeint, mode)), 2) + | "%nativeint_sub" -> Primitive ((Psubbint (Boxed_nativeint, mode)), 2) + | "%nativeint_mul" -> Primitive ((Pmulbint (Boxed_nativeint, mode)), 2) | "%nativeint_div" -> - Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe; mode }), 2); + Primitive ((Pdivbint { size = Boxed_nativeint; is_safe = Safe; mode }), 2); | "%nativeint_mod" -> - Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe; mode }), 2); - | "%nativeint_and" -> Primitive ((Pandbint (Pnativeint, mode)), 2) - | "%nativeint_or" -> Primitive ( (Porbint (Pnativeint, mode)), 2) - | "%nativeint_xor" -> Primitive ((Pxorbint (Pnativeint, mode)), 2) - | "%nativeint_lsl" -> Primitive ((Plslbint (Pnativeint, mode)), 2) - | "%nativeint_lsr" -> Primitive ((Plsrbint (Pnativeint, mode)), 2) - | "%nativeint_asr" -> Primitive ((Pasrbint (Pnativeint, mode)), 2) - | "%int32_of_int" -> Primitive ((Pbintofint (Pint32, mode)), 1) - | "%int32_to_int" -> Primitive ((Pintofbint Pint32), 1) - | "%int32_neg" -> Primitive ((Pnegbint (Pint32, mode)), 1) - | "%int32_add" -> Primitive ((Paddbint (Pint32, mode)), 2) - | "%int32_sub" -> Primitive ((Psubbint (Pint32, mode)), 2) - | "%int32_mul" -> Primitive ((Pmulbint (Pint32, mode)), 2) + Primitive ((Pmodbint { size = Boxed_nativeint; is_safe = Safe; mode }), 2); + | "%nativeint_and" -> Primitive ((Pandbint (Boxed_nativeint, mode)), 2) + | "%nativeint_or" -> Primitive ( (Porbint (Boxed_nativeint, mode)), 2) + | "%nativeint_xor" -> Primitive ((Pxorbint (Boxed_nativeint, mode)), 2) + | "%nativeint_lsl" -> Primitive ((Plslbint (Boxed_nativeint, mode)), 2) + | "%nativeint_lsr" -> Primitive ((Plsrbint (Boxed_nativeint, mode)), 2) + | "%nativeint_asr" -> Primitive ((Pasrbint (Boxed_nativeint, mode)), 2) + | "%int32_of_int" -> Primitive ((Pbintofint (Boxed_int32, mode)), 1) + | "%int32_to_int" -> Primitive ((Pintofbint Boxed_int32), 1) + | "%int32_neg" -> Primitive ((Pnegbint (Boxed_int32, mode)), 1) + | "%int32_add" -> Primitive ((Paddbint (Boxed_int32, mode)), 2) + | "%int32_sub" -> Primitive ((Psubbint (Boxed_int32, mode)), 2) + | "%int32_mul" -> Primitive ((Pmulbint (Boxed_int32, mode)), 2) | "%int32_div" -> - Primitive ((Pdivbint { size = Pint32; is_safe = Safe; mode }), 2) + Primitive ((Pdivbint { size = Boxed_int32; is_safe = Safe; mode }), 2) | "%int32_mod" -> - Primitive ((Pmodbint { size = Pint32; is_safe = Safe; mode }), 2) - | "%int32_and" -> Primitive ((Pandbint (Pint32, mode)), 2) - | "%int32_or" -> Primitive ( (Porbint (Pint32, mode)), 2) - | "%int32_xor" -> Primitive ((Pxorbint (Pint32, mode)), 2) - | "%int32_lsl" -> Primitive ((Plslbint (Pint32, mode)), 2) - | "%int32_lsr" -> Primitive ((Plsrbint (Pint32, mode)), 2) - | "%int32_asr" -> Primitive ((Pasrbint (Pint32, mode)), 2) - | "%int64_of_int" -> Primitive ((Pbintofint (Pint64, mode)), 1) - | "%int64_to_int" -> Primitive ((Pintofbint Pint64), 1) - | "%int64_neg" -> Primitive ((Pnegbint (Pint64, mode)), 1) - | "%int64_add" -> Primitive ((Paddbint (Pint64, mode)), 2) - | "%int64_sub" -> Primitive ((Psubbint (Pint64, mode)), 2) - | "%int64_mul" -> Primitive ((Pmulbint (Pint64, mode)), 2) + Primitive ((Pmodbint { size = Boxed_int32; is_safe = Safe; mode }), 2) + | "%int32_and" -> Primitive ((Pandbint (Boxed_int32, mode)), 2) + | "%int32_or" -> Primitive ( (Porbint (Boxed_int32, mode)), 2) + | "%int32_xor" -> Primitive ((Pxorbint (Boxed_int32, mode)), 2) + | "%int32_lsl" -> Primitive ((Plslbint (Boxed_int32, mode)), 2) + | "%int32_lsr" -> Primitive ((Plsrbint (Boxed_int32, mode)), 2) + | "%int32_asr" -> Primitive ((Pasrbint (Boxed_int32, mode)), 2) + | "%int64_of_int" -> Primitive ((Pbintofint (Boxed_int64, mode)), 1) + | "%int64_to_int" -> Primitive ((Pintofbint Boxed_int64), 1) + | "%int64_neg" -> Primitive ((Pnegbint (Boxed_int64, mode)), 1) + | "%int64_add" -> Primitive ((Paddbint (Boxed_int64, mode)), 2) + | "%int64_sub" -> Primitive ((Psubbint (Boxed_int64, mode)), 2) + | "%int64_mul" -> Primitive ((Pmulbint (Boxed_int64, mode)), 2) | "%int64_div" -> - Primitive ((Pdivbint { size = Pint64; is_safe = Safe; mode }), 2) + Primitive ((Pdivbint { size = Boxed_int64; is_safe = Safe; mode }), 2) | "%int64_mod" -> - Primitive ((Pmodbint { size = Pint64; is_safe = Safe; mode }), 2) - | "%int64_and" -> Primitive ((Pandbint (Pint64, mode)), 2) - | "%int64_or" -> Primitive ( (Porbint (Pint64, mode)), 2) - | "%int64_xor" -> Primitive ((Pxorbint (Pint64, mode)), 2) - | "%int64_lsl" -> Primitive ((Plslbint (Pint64, mode)), 2) - | "%int64_lsr" -> Primitive ((Plsrbint (Pint64, mode)), 2) - | "%int64_asr" -> Primitive ((Pasrbint (Pint64, mode)), 2) - | "%nativeint_of_int32" -> Primitive ((Pcvtbint(Pint32, Pnativeint, mode)), 1) - | "%nativeint_to_int32" -> Primitive ((Pcvtbint(Pnativeint, Pint32, mode)), 1) - | "%int64_of_int32" -> Primitive ((Pcvtbint(Pint32, Pint64, mode)), 1) - | "%int64_to_int32" -> Primitive ((Pcvtbint(Pint64, Pint32, mode)), 1) - | "%int64_of_nativeint" -> Primitive ((Pcvtbint(Pnativeint, Pint64, mode)), 1) - | "%int64_to_nativeint" -> Primitive ((Pcvtbint(Pint64, Pnativeint, mode)), 1) + Primitive ((Pmodbint { size = Boxed_int64; is_safe = Safe; mode }), 2) + | "%int64_and" -> Primitive ((Pandbint (Boxed_int64, mode)), 2) + | "%int64_or" -> Primitive ( (Porbint (Boxed_int64, mode)), 2) + | "%int64_xor" -> Primitive ((Pxorbint (Boxed_int64, mode)), 2) + | "%int64_lsl" -> Primitive ((Plslbint (Boxed_int64, mode)), 2) + | "%int64_lsr" -> Primitive ((Plsrbint (Boxed_int64, mode)), 2) + | "%int64_asr" -> Primitive ((Pasrbint (Boxed_int64, mode)), 2) + | "%nativeint_of_int32" -> Primitive ((Pcvtbint(Boxed_int32, Boxed_nativeint, mode)), 1) + | "%nativeint_to_int32" -> Primitive ((Pcvtbint(Boxed_nativeint, Boxed_int32, mode)), 1) + | "%int64_of_int32" -> Primitive ((Pcvtbint(Boxed_int32, Boxed_int64, mode)), 1) + | "%int64_to_int32" -> Primitive ((Pcvtbint(Boxed_int64, Boxed_int32, mode)), 1) + | "%int64_of_nativeint" -> Primitive ((Pcvtbint(Boxed_nativeint, Boxed_int64, mode)), 1) + | "%int64_to_nativeint" -> Primitive ((Pcvtbint(Boxed_int64, Boxed_nativeint, mode)), 1) | "%caml_ba_ref_1" -> Primitive ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), @@ -835,9 +835,9 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%caml_unboxed_nativeint_array_set128u#" -> Primitive ((Punboxed_nativeint_array_set_128 {unsafe = true; boxed = false}), 3) | "%bswap16" -> Primitive (Pbswap16, 1) - | "%bswap_int32" -> Primitive ((Pbbswap(Pint32, mode)), 1) - | "%bswap_int64" -> Primitive ((Pbbswap(Pint64, mode)), 1) - | "%bswap_native" -> Primitive ((Pbbswap(Pnativeint, mode)), 1) + | "%bswap_int32" -> Primitive ((Pbbswap(Boxed_int32, mode)), 1) + | "%bswap_int64" -> Primitive ((Pbbswap(Boxed_int64, mode)), 1) + | "%bswap_native" -> Primitive ((Pbbswap(Boxed_nativeint, mode)), 1) | "%int_as_pointer" -> Primitive (Pint_as_pointer mode, 1) | "%opaque" -> Primitive (Popaque layout, 1) | "%sys_argv" -> Sys_argv @@ -855,12 +855,12 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%obj_magic" -> Primitive(Pobj_magic layout, 1) | "%array_to_iarray" -> Primitive (Parray_to_iarray, 1) | "%array_of_iarray" -> Primitive (Parray_of_iarray, 1) - | "%unbox_float" -> Primitive(Punbox_float Pfloat64, 1) - | "%box_float" -> Primitive(Pbox_float (Pfloat64, mode), 1) - | "%unbox_float32" -> Primitive(Punbox_float Pfloat32, 1) - | "%box_float32" -> Primitive(Pbox_float (Pfloat32, mode), 1) - | "%unbox_vec128" -> Primitive(Punbox_vector Pvec128, 1) - | "%box_vec128" -> Primitive(Pbox_vector (Pvec128, mode), 1) + | "%unbox_float" -> Primitive(Punbox_float Boxed_float64, 1) + | "%box_float" -> Primitive(Pbox_float (Boxed_float64, mode), 1) + | "%unbox_float32" -> Primitive(Punbox_float Boxed_float32, 1) + | "%box_float32" -> Primitive(Pbox_float (Boxed_float32, mode), 1) + | "%unbox_vec128" -> Primitive(Punbox_vector Boxed_vec128, 1) + | "%box_vec128" -> Primitive(Pbox_vector (Boxed_vec128, mode), 1) | "%get_header" -> Primitive (Pget_header mode, 1) | "%atomic_load" -> Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1) @@ -877,12 +877,12 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = if runtime5 then Primitive (Presume, 4) else Unsupported Presume | "%dls_get" -> Primitive (Pdls_get, 1) | "%poll" -> Primitive (Ppoll, 1) - | "%unbox_nativeint" -> Primitive(Punbox_int Pnativeint, 1) - | "%box_nativeint" -> Primitive(Pbox_int (Pnativeint, mode), 1) - | "%unbox_int32" -> Primitive(Punbox_int Pint32, 1) - | "%box_int32" -> Primitive(Pbox_int (Pint32, mode), 1) - | "%unbox_int64" -> Primitive(Punbox_int Pint64, 1) - | "%box_int64" -> Primitive(Pbox_int (Pint64, mode), 1) + | "%unbox_nativeint" -> Primitive(Punbox_int Boxed_nativeint, 1) + | "%box_nativeint" -> Primitive(Pbox_int (Boxed_nativeint, mode), 1) + | "%unbox_int32" -> Primitive(Punbox_int Boxed_int32, 1) + | "%box_int32" -> Primitive(Pbox_int (Boxed_int32, mode), 1) + | "%unbox_int64" -> Primitive(Punbox_int Boxed_int64, 1) + | "%box_int64" -> Primitive(Pbox_int (Boxed_int64, mode), 1) | "%reinterpret_tagged_int63_as_unboxed_int64" -> Primitive(Preinterpret_tagged_int63_as_unboxed_int64, 1) | "%reinterpret_unboxed_int64_as_tagged_int63" -> @@ -957,22 +957,22 @@ let glb_array_type loc t1 t2 = | Pfloatarray, (Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _) -> (* Have a nice error message for a case reachable. *) raise(Error(loc, Invalid_floatarray_glb)) - | (Pgenarray | Punboxedfloatarray Pfloat64), Punboxedfloatarray Pfloat64 -> - Punboxedfloatarray Pfloat64 - | (Pgenarray | Punboxedfloatarray Pfloat32), Punboxedfloatarray Pfloat32 -> - Punboxedfloatarray Pfloat32 + | (Pgenarray | Punboxedfloatarray Unboxed_float64), Punboxedfloatarray Unboxed_float64 -> + Punboxedfloatarray Unboxed_float64 + | (Pgenarray | Punboxedfloatarray Unboxed_float32), Punboxedfloatarray Unboxed_float32 -> + Punboxedfloatarray Unboxed_float32 | Punboxedfloatarray _, _ | _, Punboxedfloatarray _ -> Misc.fatal_error "unexpected array kind in glb" - | (Pgenarray | Punboxedintarray Pint32), Punboxedintarray Pint32 -> - Punboxedintarray Pint32 - | (Pgenarray | Punboxedintarray Pint64), Punboxedintarray Pint64 -> - Punboxedintarray Pint64 - | (Pgenarray | Punboxedintarray Pnativeint), Punboxedintarray Pnativeint -> - Punboxedintarray Pnativeint + | (Pgenarray | Punboxedintarray Unboxed_int32), Punboxedintarray Unboxed_int32 -> + Punboxedintarray Unboxed_int32 + | (Pgenarray | Punboxedintarray Unboxed_int64), Punboxedintarray Unboxed_int64 -> + Punboxedintarray Unboxed_int64 + | (Pgenarray | Punboxedintarray Unboxed_nativeint), Punboxedintarray Unboxed_nativeint -> + Punboxedintarray Unboxed_nativeint | Punboxedintarray _, _ | _, Punboxedintarray _ -> Misc.fatal_error "unexpected array kind in glb" - | (Pgenarray | Punboxedvectorarray Pvec128), Punboxedvectorarray Pvec128 -> - Punboxedvectorarray Pvec128 + | (Pgenarray | Punboxedvectorarray Unboxed_vec128), Punboxedvectorarray Unboxed_vec128 -> + Punboxedvectorarray Unboxed_vec128 | Punboxedvectorarray _, _ | _, Punboxedvectorarray _ -> Misc.fatal_error "unexpected array kind in glb" @@ -1017,23 +1017,23 @@ let glb_array_ref_type loc t1 t2 = | Pfloatarray_ref _, (Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _) -> (* Have a nice error message for a case reachable. *) raise(Error(loc, Invalid_floatarray_glb)) - | (Pgenarray_ref _ | Punboxedfloatarray_ref Pfloat64), Punboxedfloatarray Pfloat64 -> - Punboxedfloatarray_ref Pfloat64 - | (Pgenarray_ref _ | Punboxedfloatarray_ref Pfloat32), Punboxedfloatarray Pfloat32 -> - Punboxedfloatarray_ref Pfloat32 + | (Pgenarray_ref _ | Punboxedfloatarray_ref Unboxed_float64), Punboxedfloatarray Unboxed_float64 -> + Punboxedfloatarray_ref Unboxed_float64 + | (Pgenarray_ref _ | Punboxedfloatarray_ref Unboxed_float32), Punboxedfloatarray Unboxed_float32 -> + Punboxedfloatarray_ref Unboxed_float32 | Punboxedfloatarray_ref _, _ | _, Punboxedfloatarray _ -> Misc.fatal_error "unexpected array kind in glb" - | (Pgenarray_ref _ | Punboxedintarray_ref Pint32), Punboxedintarray Pint32 -> - Punboxedintarray_ref Pint32 - | (Pgenarray_ref _ | Punboxedintarray_ref Pint64), Punboxedintarray Pint64 -> - Punboxedintarray_ref Pint64 - | (Pgenarray_ref _ | Punboxedintarray_ref Pnativeint), Punboxedintarray Pnativeint -> - Punboxedintarray_ref Pnativeint + | (Pgenarray_ref _ | Punboxedintarray_ref Unboxed_int32), Punboxedintarray Unboxed_int32 -> + Punboxedintarray_ref Unboxed_int32 + | (Pgenarray_ref _ | Punboxedintarray_ref Unboxed_int64), Punboxedintarray Unboxed_int64 -> + Punboxedintarray_ref Unboxed_int64 + | (Pgenarray_ref _ | Punboxedintarray_ref Unboxed_nativeint), Punboxedintarray Unboxed_nativeint -> + Punboxedintarray_ref Unboxed_nativeint | Punboxedintarray_ref _, _ | _, Punboxedintarray _ -> Misc.fatal_error "unexpected array kind in glb" - | (Pgenarray_ref _ | Punboxedvectorarray_ref Pvec128), Punboxedvectorarray Pvec128 -> - Punboxedvectorarray_ref Pvec128 + | (Pgenarray_ref _ | Punboxedvectorarray_ref Unboxed_vec128), Punboxedvectorarray Unboxed_vec128 -> + Punboxedvectorarray_ref Unboxed_vec128 | Punboxedvectorarray_ref _, _ | _, Punboxedvectorarray _ -> Misc.fatal_error "unexpected array kind in glb" @@ -1092,23 +1092,23 @@ let glb_array_set_type loc t1 t2 = | Pfloatarray_set, (Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _) -> (* Have a nice error message for a case reachable. *) raise(Error(loc, Invalid_floatarray_glb)) - | (Pgenarray_set _ | Punboxedfloatarray_set Pfloat64), Punboxedfloatarray Pfloat64 -> - Punboxedfloatarray_set Pfloat64 - | (Pgenarray_set _ | Punboxedfloatarray_set Pfloat32), Punboxedfloatarray Pfloat32 -> - Punboxedfloatarray_set Pfloat32 + | (Pgenarray_set _ | Punboxedfloatarray_set Unboxed_float64), Punboxedfloatarray Unboxed_float64 -> + Punboxedfloatarray_set Unboxed_float64 + | (Pgenarray_set _ | Punboxedfloatarray_set Unboxed_float32), Punboxedfloatarray Unboxed_float32 -> + Punboxedfloatarray_set Unboxed_float32 | Punboxedfloatarray_set _, _ | _, Punboxedfloatarray _ -> Misc.fatal_error "unexpected array kind in glb" - | (Pgenarray_set _ | Punboxedintarray_set Pint32), Punboxedintarray Pint32 -> - Punboxedintarray_set Pint32 - | (Pgenarray_set _ | Punboxedintarray_set Pint64), Punboxedintarray Pint64 -> - Punboxedintarray_set Pint64 - | (Pgenarray_set _ | Punboxedintarray_set Pnativeint), Punboxedintarray Pnativeint -> - Punboxedintarray_set Pnativeint + | (Pgenarray_set _ | Punboxedintarray_set Unboxed_int32), Punboxedintarray Unboxed_int32 -> + Punboxedintarray_set Unboxed_int32 + | (Pgenarray_set _ | Punboxedintarray_set Unboxed_int64), Punboxedintarray Unboxed_int64 -> + Punboxedintarray_set Unboxed_int64 + | (Pgenarray_set _ | Punboxedintarray_set Unboxed_nativeint), Punboxedintarray Unboxed_nativeint -> + Punboxedintarray_set Unboxed_nativeint | Punboxedintarray_set _, _ | _, Punboxedintarray _ -> Misc.fatal_error "unexpected array kind in glb" - | (Pgenarray_set _ | Punboxedvectorarray_set Pvec128), Punboxedvectorarray Pvec128 -> - Punboxedvectorarray_set Pvec128 + | (Pgenarray_set _ | Punboxedvectorarray_set Unboxed_vec128), Punboxedvectorarray Unboxed_vec128 -> + Punboxedvectorarray_set Unboxed_vec128 | Punboxedvectorarray_set _, _ | _, Punboxedvectorarray _ -> Misc.fatal_error "unexpected array kind in glb" @@ -1362,67 +1362,67 @@ let comparison_primitive comparison comparison_kind = match comparison, comparison_kind with | Equal, Compare_generic -> Pccall caml_equal | Equal, Compare_ints -> Pintcomp Ceq - | Equal, Compare_floats -> Pfloatcomp (Pfloat64, CFeq) - | Equal, Compare_float32s -> Pfloatcomp (Pfloat32, CFeq) + | Equal, Compare_floats -> Pfloatcomp (Boxed_float64, CFeq) + | Equal, Compare_float32s -> Pfloatcomp (Boxed_float32, CFeq) | Equal, Compare_strings -> Pccall caml_string_equal | Equal, Compare_bytes -> Pccall caml_bytes_equal - | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) - | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq) - | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) + | Equal, Compare_nativeints -> Pbintcomp(Boxed_nativeint, Ceq) + | Equal, Compare_int32s -> Pbintcomp(Boxed_int32, Ceq) + | Equal, Compare_int64s -> Pbintcomp(Boxed_int64, Ceq) | Not_equal, Compare_generic -> Pccall caml_notequal | Not_equal, Compare_ints -> Pintcomp Cne - | Not_equal, Compare_floats -> Pfloatcomp (Pfloat64, CFneq) - | Not_equal, Compare_float32s -> Pfloatcomp (Pfloat32, CFneq) + | Not_equal, Compare_floats -> Pfloatcomp (Boxed_float64, CFneq) + | Not_equal, Compare_float32s -> Pfloatcomp (Boxed_float32, CFneq) | Not_equal, Compare_strings -> Pccall caml_string_notequal | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal - | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) - | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne) - | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) + | Not_equal, Compare_nativeints -> Pbintcomp(Boxed_nativeint, Cne) + | Not_equal, Compare_int32s -> Pbintcomp(Boxed_int32, Cne) + | Not_equal, Compare_int64s -> Pbintcomp(Boxed_int64, Cne) | Less_equal, Compare_generic -> Pccall caml_lessequal | Less_equal, Compare_ints -> Pintcomp Cle - | Less_equal, Compare_floats -> Pfloatcomp (Pfloat64, CFle) - | Less_equal, Compare_float32s -> Pfloatcomp (Pfloat32, CFle) + | Less_equal, Compare_floats -> Pfloatcomp (Boxed_float64, CFle) + | Less_equal, Compare_float32s -> Pfloatcomp (Boxed_float32, CFle) | Less_equal, Compare_strings -> Pccall caml_string_lessequal | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal - | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) - | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle) - | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) + | Less_equal, Compare_nativeints -> Pbintcomp(Boxed_nativeint, Cle) + | Less_equal, Compare_int32s -> Pbintcomp(Boxed_int32, Cle) + | Less_equal, Compare_int64s -> Pbintcomp(Boxed_int64, Cle) | Less_than, Compare_generic -> Pccall caml_lessthan | Less_than, Compare_ints -> Pintcomp Clt - | Less_than, Compare_floats -> Pfloatcomp (Pfloat64, CFlt) - | Less_than, Compare_float32s -> Pfloatcomp (Pfloat32, CFlt) + | Less_than, Compare_floats -> Pfloatcomp (Boxed_float64, CFlt) + | Less_than, Compare_float32s -> Pfloatcomp (Boxed_float32, CFlt) | Less_than, Compare_strings -> Pccall caml_string_lessthan | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan - | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) - | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt) - | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) + | Less_than, Compare_nativeints -> Pbintcomp(Boxed_nativeint, Clt) + | Less_than, Compare_int32s -> Pbintcomp(Boxed_int32, Clt) + | Less_than, Compare_int64s -> Pbintcomp(Boxed_int64, Clt) | Greater_equal, Compare_generic -> Pccall caml_greaterequal | Greater_equal, Compare_ints -> Pintcomp Cge - | Greater_equal, Compare_floats -> Pfloatcomp (Pfloat64, CFge) - | Greater_equal, Compare_float32s -> Pfloatcomp (Pfloat32, CFge) + | Greater_equal, Compare_floats -> Pfloatcomp (Boxed_float64, CFge) + | Greater_equal, Compare_float32s -> Pfloatcomp (Boxed_float32, CFge) | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal - | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) - | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge) - | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) + | Greater_equal, Compare_nativeints -> Pbintcomp(Boxed_nativeint, Cge) + | Greater_equal, Compare_int32s -> Pbintcomp(Boxed_int32, Cge) + | Greater_equal, Compare_int64s -> Pbintcomp(Boxed_int64, Cge) | Greater_than, Compare_generic -> Pccall caml_greaterthan | Greater_than, Compare_ints -> Pintcomp Cgt - | Greater_than, Compare_floats -> Pfloatcomp (Pfloat64, CFgt) - | Greater_than, Compare_float32s -> Pfloatcomp (Pfloat32, CFgt) + | Greater_than, Compare_floats -> Pfloatcomp (Boxed_float64, CFgt) + | Greater_than, Compare_float32s -> Pfloatcomp (Boxed_float32, CFgt) | Greater_than, Compare_strings -> Pccall caml_string_greaterthan | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan - | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) - | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt) - | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) + | Greater_than, Compare_nativeints -> Pbintcomp(Boxed_nativeint, Cgt) + | Greater_than, Compare_int32s -> Pbintcomp(Boxed_int32, Cgt) + | Greater_than, Compare_int64s -> Pbintcomp(Boxed_int64, Cgt) | Compare, Compare_generic -> Pccall caml_compare | Compare, Compare_ints -> Pcompare_ints - | Compare, Compare_floats -> Pcompare_floats Pfloat64 - | Compare, Compare_float32s -> Pcompare_floats Pfloat32 + | Compare, Compare_floats -> Pcompare_floats Boxed_float64 + | Compare, Compare_float32s -> Pcompare_floats Boxed_float32 | Compare, Compare_strings -> Pccall caml_string_compare | Compare, Compare_bytes -> Pccall caml_bytes_compare - | Compare, Compare_nativeints -> Pcompare_bints Pnativeint - | Compare, Compare_int32s -> Pcompare_bints Pint32 - | Compare, Compare_int64s -> Pcompare_bints Pint64 + | Compare, Compare_nativeints -> Pcompare_bints Boxed_nativeint + | Compare, Compare_int32s -> Pcompare_bints Boxed_int32 + | Compare, Compare_int64s -> Pcompare_bints Boxed_int64 let lambda_of_loc kind sloc = let loc = to_location sloc in diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 80c2f657f84..ea92ea96211 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -522,32 +522,32 @@ let unarize_extern_repr alloc_mode (extern_repr : Lambda.extern_repr) = [{ kind; arg_transformer = None; return_transformer = None }] | Same_as_ocaml_repr (Product sorts) -> List.concat_map unarize_const_sort_for_extern_repr sorts - | Unboxed_float Pfloat64 -> + | Unboxed_float Boxed_float64 -> [ { kind = K.naked_float; arg_transformer = Some (P.Unbox_number Naked_float); return_transformer = Some (P.Box_number (Naked_float, alloc_mode)) } ] - | Unboxed_float Pfloat32 -> + | Unboxed_float Boxed_float32 -> [ { kind = K.naked_float32; arg_transformer = Some (P.Unbox_number Naked_float32); return_transformer = Some (P.Box_number (Naked_float32, alloc_mode)) } ] - | Unboxed_integer Pnativeint -> + | Unboxed_integer Boxed_nativeint -> [ { kind = K.naked_nativeint; arg_transformer = Some (P.Unbox_number Naked_nativeint); return_transformer = Some (P.Box_number (Naked_nativeint, alloc_mode)) } ] - | Unboxed_integer Pint32 -> + | Unboxed_integer Boxed_int32 -> [ { kind = K.naked_int32; arg_transformer = Some (P.Unbox_number Naked_int32); return_transformer = Some (P.Box_number (Naked_int32, alloc_mode)) } ] - | Unboxed_integer Pint64 -> + | Unboxed_integer Boxed_int64 -> [ { kind = K.naked_int64; arg_transformer = Some (P.Unbox_number Naked_int64); return_transformer = Some (P.Box_number (Naked_int64, alloc_mode)) } ] - | Unboxed_vector Pvec128 -> + | Unboxed_vector Boxed_vec128 -> [ { kind = K.naked_vec128; arg_transformer = Some (P.Unbox_number Naked_vec128); return_transformer = Some (P.Box_number (Naked_vec128, alloc_mode)) @@ -700,11 +700,11 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds in match prim_native_name with | "caml_int64_float_of_bits_unboxed" -> - unboxed_int64_to_and_from_unboxed_float ~src_kind:(Unboxed_integer Pint64) - ~dst_kind:(Unboxed_float Pfloat64) ~op:Unboxed_int64_as_unboxed_float64 + unboxed_int64_to_and_from_unboxed_float ~src_kind:(Unboxed_integer Boxed_int64) + ~dst_kind:(Unboxed_float Boxed_float64) ~op:Unboxed_int64_as_unboxed_float64 | "caml_int64_bits_of_float_unboxed" -> - unboxed_int64_to_and_from_unboxed_float ~src_kind:(Unboxed_float Pfloat64) - ~dst_kind:(Unboxed_integer Pint64) ~op:Unboxed_float64_as_unboxed_int64 + unboxed_int64_to_and_from_unboxed_float ~src_kind:(Unboxed_float Boxed_float64) + ~dst_kind:(Unboxed_integer Boxed_int64) ~op:Unboxed_float64_as_unboxed_int64 | _ -> let callee = Simple.symbol call_symbol in let apply = diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index ea3182806fc..3927a3df966 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -1248,28 +1248,28 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents List.for_all (fun (kind : Lambda.value_kind) -> match kind.raw_kind with - | Pboxedfloatval Pfloat64 -> true - | Pboxedfloatval Pfloat32 + | Pboxedfloatval Boxed_float64 -> true + | Pboxedfloatval Boxed_float32 | Pgenval | Pintval | Pboxedintval _ | Pvariant _ | Parrayval _ | Pboxedvectorval _ -> false) field_kinds); Some (Unboxed_float_record (List.length field_kinds)) - | Pvalue { nullable = Non_nullable; raw_kind = Pboxedfloatval Pfloat64 } -> + | Pvalue { nullable = Non_nullable; raw_kind = Pboxedfloatval Boxed_float64 } -> Some (Unboxed_number Naked_float) - | Pvalue { nullable = Non_nullable; raw_kind = Pboxedfloatval Pfloat32 } -> + | Pvalue { nullable = Non_nullable; raw_kind = Pboxedfloatval Boxed_float32 } -> Some (Unboxed_number Naked_float32) | Pvalue { nullable = Non_nullable; raw_kind = Pboxedintval bi } -> let bn : Flambda_kind.Boxable_number.t = match bi with - | Pint32 -> Naked_int32 - | Pint64 -> Naked_int64 - | Pnativeint -> Naked_nativeint + | Boxed_int32 -> Naked_int32 + | Boxed_int64 -> Naked_int64 + | Boxed_nativeint -> Naked_nativeint in Some (Unboxed_number bn) | Pvalue { nullable = Non_nullable; raw_kind = Pboxedvectorval bv } -> let bn : Flambda_kind.Boxable_number.t = - match bv with Pvec128 -> Naked_vec128 + match bv with Boxed_vec128 -> Naked_vec128 in Some (Unboxed_number bn) | Pvalue 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 732b2c9f422..085fcf177e0 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -31,27 +31,27 @@ let convert_integer_comparison_prim (comp : L.integer_comparison) : | Cle -> Int_comp (Tagged_immediate, Yielding_bool (Le Signed)) | Cge -> Int_comp (Tagged_immediate, Yielding_bool (Ge Signed)) -let convert_boxed_integer_comparison_prim (kind : L.boxed_integer) +let convert_unboxed_integer_comparison_prim (kind : L.unboxed_integer) (comp : L.integer_comparison) : P.binary_primitive = match kind, comp with - | Pint32, Ceq -> Int_comp (Naked_int32, Yielding_bool Eq) - | Pint32, Cne -> Int_comp (Naked_int32, Yielding_bool Neq) - | Pint32, Clt -> Int_comp (Naked_int32, Yielding_bool (Lt Signed)) - | Pint32, Cgt -> Int_comp (Naked_int32, Yielding_bool (Gt Signed)) - | Pint32, Cle -> Int_comp (Naked_int32, Yielding_bool (Le Signed)) - | Pint32, Cge -> Int_comp (Naked_int32, Yielding_bool (Ge Signed)) - | Pint64, Ceq -> Int_comp (Naked_int64, Yielding_bool Eq) - | Pint64, Cne -> Int_comp (Naked_int64, Yielding_bool Neq) - | Pint64, Clt -> Int_comp (Naked_int64, Yielding_bool (Lt Signed)) - | Pint64, Cgt -> Int_comp (Naked_int64, Yielding_bool (Gt Signed)) - | Pint64, Cle -> Int_comp (Naked_int64, Yielding_bool (Le Signed)) - | Pint64, Cge -> Int_comp (Naked_int64, Yielding_bool (Ge Signed)) - | Pnativeint, Ceq -> Int_comp (Naked_nativeint, Yielding_bool Eq) - | Pnativeint, Cne -> Int_comp (Naked_nativeint, Yielding_bool Neq) - | Pnativeint, Clt -> Int_comp (Naked_nativeint, Yielding_bool (Lt Signed)) - | Pnativeint, Cgt -> Int_comp (Naked_nativeint, Yielding_bool (Gt Signed)) - | Pnativeint, Cle -> Int_comp (Naked_nativeint, Yielding_bool (Le Signed)) - | Pnativeint, Cge -> Int_comp (Naked_nativeint, Yielding_bool (Ge Signed)) + | Unboxed_int32, Ceq -> Int_comp (Naked_int32, Yielding_bool Eq) + | Unboxed_int32, Cne -> Int_comp (Naked_int32, Yielding_bool Neq) + | Unboxed_int32, Clt -> Int_comp (Naked_int32, Yielding_bool (Lt Signed)) + | Unboxed_int32, Cgt -> Int_comp (Naked_int32, Yielding_bool (Gt Signed)) + | Unboxed_int32, Cle -> Int_comp (Naked_int32, Yielding_bool (Le Signed)) + | Unboxed_int32, Cge -> Int_comp (Naked_int32, Yielding_bool (Ge Signed)) + | Unboxed_int64, Ceq -> Int_comp (Naked_int64, Yielding_bool Eq) + | Unboxed_int64, Cne -> Int_comp (Naked_int64, Yielding_bool Neq) + | Unboxed_int64, Clt -> Int_comp (Naked_int64, Yielding_bool (Lt Signed)) + | Unboxed_int64, Cgt -> Int_comp (Naked_int64, Yielding_bool (Gt Signed)) + | Unboxed_int64, Cle -> Int_comp (Naked_int64, Yielding_bool (Le Signed)) + | Unboxed_int64, Cge -> Int_comp (Naked_int64, Yielding_bool (Ge Signed)) + | Unboxed_nativeint, Ceq -> Int_comp (Naked_nativeint, Yielding_bool Eq) + | Unboxed_nativeint, Cne -> Int_comp (Naked_nativeint, Yielding_bool Neq) + | Unboxed_nativeint, Clt -> Int_comp (Naked_nativeint, Yielding_bool (Lt Signed)) + | Unboxed_nativeint, Cgt -> Int_comp (Naked_nativeint, Yielding_bool (Gt Signed)) + | Unboxed_nativeint, Cle -> Int_comp (Naked_nativeint, Yielding_bool (Le Signed)) + | Unboxed_nativeint, Cge -> Int_comp (Naked_nativeint, Yielding_bool (Ge Signed)) let convert_float_comparison (comp : L.float_comparison) : unit P.comparison = match comp with @@ -69,22 +69,30 @@ let convert_float_comparison (comp : L.float_comparison) : unit P.comparison = let boxable_number_of_boxed_integer (bint : L.boxed_integer) : K.Boxable_number.t = match bint with - | Pnativeint -> Naked_nativeint - | Pint32 -> Naked_int32 - | Pint64 -> Naked_int64 + | Boxed_nativeint -> Naked_nativeint + | Boxed_int32 -> Naked_int32 + | Boxed_int64 -> Naked_int64 -let standard_int_of_boxed_integer (bint : L.boxed_integer) : K.Standard_int.t = +let standard_int_of_boxed_integer (bint : Primitive.boxed_integer) : K.Standard_int.t = match bint with - | Pnativeint -> Naked_nativeint - | Pint32 -> Naked_int32 - | Pint64 -> Naked_int64 + | Boxed_nativeint -> Naked_nativeint + | Boxed_int32 -> Naked_int32 + | Boxed_int64 -> Naked_int64 -let standard_int_or_float_of_boxed_integer (bint : L.boxed_integer) : +let standard_int_of_unboxed_integer : L.unboxed_integer -> K.Standard_int.t = function + | Unboxed_int32 -> Naked_int32 + | Unboxed_nativeint -> Naked_nativeint + | Unboxed_int64 -> Naked_int64 + +let standard_int_or_float_of_unboxed_integer (ubint : L.unboxed_integer) : K.Standard_int_or_float.t = - match bint with - | Pnativeint -> Naked_nativeint - | Pint32 -> Naked_int32 - | Pint64 -> Naked_int64 + match ubint with + | Unboxed_nativeint -> Naked_nativeint + | Unboxed_int32 -> Naked_int32 + | Unboxed_int64 -> Naked_int64 + +let standard_int_or_float_of_boxed_integer bint = + standard_int_or_float_of_unboxed_integer (Primitive.unbox_integer bint) let convert_block_access_field_kind i_or_p : P.Block_access_field_kind.t = match i_or_p with L.Immediate -> Immediate | L.Pointer -> Any_value @@ -128,12 +136,12 @@ let convert_array_kind (kind : L.array_kind) : converted_array_kind = Float_array_opt_dynamic | Paddrarray -> Array_kind Values | Pintarray -> Array_kind Immediates - | Pfloatarray | Punboxedfloatarray Pfloat64 -> Array_kind Naked_floats - | Punboxedfloatarray Pfloat32 -> Array_kind Naked_float32s - | Punboxedintarray Pint32 -> Array_kind Naked_int32s - | Punboxedintarray Pint64 -> Array_kind Naked_int64s - | Punboxedintarray Pnativeint -> Array_kind Naked_nativeints - | Punboxedvectorarray Pvec128 -> Array_kind Naked_vec128s + | Pfloatarray | Punboxedfloatarray Unboxed_float64 -> Array_kind Naked_floats + | Punboxedfloatarray Unboxed_float32 -> Array_kind Naked_float32s + | Punboxedintarray Unboxed_int32 -> Array_kind Naked_int32s + | Punboxedintarray Unboxed_int64 -> Array_kind Naked_int64s + | Punboxedintarray Unboxed_nativeint -> Array_kind Naked_nativeints + | Punboxedvectorarray Unboxed_vec128 -> Array_kind Naked_vec128s | Pgcscannableproductarray kinds -> let rec convert_kind (kind : L.scannable_product_element_kind) : P.Array_kind.t = @@ -149,11 +157,11 @@ let convert_array_kind (kind : L.array_kind) : converted_array_kind = P.Array_kind.t = match kind with | Pint_ignorable -> Immediates - | Punboxedfloat_ignorable Pfloat32 -> Naked_float32s - | Punboxedfloat_ignorable Pfloat64 -> Naked_floats - | Punboxedint_ignorable Pint32 -> Naked_int32s - | Punboxedint_ignorable Pint64 -> Naked_int64s - | Punboxedint_ignorable Pnativeint -> Naked_nativeints + | Punboxedfloat_ignorable Unboxed_float32 -> Naked_float32s + | Punboxedfloat_ignorable Unboxed_float64 -> Naked_floats + | Punboxedint_ignorable Unboxed_int32 -> Naked_int32s + | Punboxedint_ignorable Unboxed_int64 -> Naked_int64s + | Punboxedint_ignorable Unboxed_nativeint -> Naked_nativeints | Pproduct_ignorable kinds -> Unboxed_product (List.map convert_kind kinds) in @@ -202,17 +210,17 @@ let convert_array_ref_kind (kind : L.array_ref_kind) : converted_array_ref_kind | Paddrarray_ref -> Array_ref_kind (No_float_array_opt Values) | Pintarray_ref -> Array_ref_kind (No_float_array_opt Immediates) | Pfloatarray_ref mode -> Array_ref_kind (Naked_floats_to_be_boxed mode) - | Punboxedfloatarray_ref Pfloat64 -> + | Punboxedfloatarray_ref Unboxed_float64 -> Array_ref_kind (No_float_array_opt Naked_floats) - | Punboxedfloatarray_ref Pfloat32 -> + | Punboxedfloatarray_ref Unboxed_float32 -> Array_ref_kind (No_float_array_opt Naked_float32s) - | Punboxedintarray_ref Pint32 -> + | Punboxedintarray_ref Unboxed_int32 -> Array_ref_kind (No_float_array_opt Naked_int32s) - | Punboxedintarray_ref Pint64 -> + | Punboxedintarray_ref Unboxed_int64 -> Array_ref_kind (No_float_array_opt Naked_int64s) - | Punboxedintarray_ref Pnativeint -> + | Punboxedintarray_ref Unboxed_nativeint -> Array_ref_kind (No_float_array_opt Naked_nativeints) - | Punboxedvectorarray_ref Pvec128 -> + | Punboxedvectorarray_ref Unboxed_vec128 -> Array_ref_kind (No_float_array_opt Naked_vec128s) | Pgcscannableproductarray_ref kinds -> let rec convert_kind (kind : L.scannable_product_element_kind) : @@ -230,11 +238,11 @@ let convert_array_ref_kind (kind : L.array_ref_kind) : converted_array_ref_kind Array_ref_kind.no_float_array_opt = match kind with | Pint_ignorable -> Immediates - | Punboxedfloat_ignorable Pfloat32 -> Naked_float32s - | Punboxedfloat_ignorable Pfloat64 -> Naked_floats - | Punboxedint_ignorable Pint32 -> Naked_int32s - | Punboxedint_ignorable Pint64 -> Naked_int64s - | Punboxedint_ignorable Pnativeint -> Naked_nativeints + | Punboxedfloat_ignorable Unboxed_float32 -> Naked_float32s + | Punboxedfloat_ignorable Unboxed_float64 -> Naked_floats + | Punboxedint_ignorable Unboxed_int32 -> Naked_int32s + | Punboxedint_ignorable Unboxed_int64 -> Naked_int64s + | Punboxedint_ignorable Unboxed_nativeint -> Naked_nativeints | Pproduct_ignorable kinds -> Unboxed_product (List.map convert_kind kinds) in @@ -329,17 +337,17 @@ let convert_array_set_kind (kind : L.array_set_kind) : converted_array_set_kind (Values (Assignment (Alloc_mode.For_assignments.from_lambda mode)))) | Pintarray_set -> Array_set_kind (No_float_array_opt Immediates) | Pfloatarray_set -> Array_set_kind Naked_floats_to_be_unboxed - | Punboxedfloatarray_set Pfloat64 -> + | Punboxedfloatarray_set Unboxed_float64 -> Array_set_kind (No_float_array_opt Naked_floats) - | Punboxedfloatarray_set Pfloat32 -> + | Punboxedfloatarray_set Unboxed_float32 -> Array_set_kind (No_float_array_opt Naked_float32s) - | Punboxedintarray_set Pint32 -> + | Punboxedintarray_set Unboxed_int32 -> Array_set_kind (No_float_array_opt Naked_int32s) - | Punboxedintarray_set Pint64 -> + | Punboxedintarray_set Unboxed_int64 -> Array_set_kind (No_float_array_opt Naked_int64s) - | Punboxedintarray_set Pnativeint -> + | Punboxedintarray_set Unboxed_nativeint -> Array_set_kind (No_float_array_opt Naked_nativeints) - | Punboxedvectorarray_set Pvec128 -> + | Punboxedvectorarray_set Unboxed_vec128 -> Array_set_kind (No_float_array_opt Naked_vec128s) | Pgcscannableproductarray_set (mode, kinds) -> let rec convert_kind (kind : L.scannable_product_element_kind) : @@ -358,11 +366,11 @@ let convert_array_set_kind (kind : L.array_set_kind) : converted_array_set_kind Array_set_kind.no_float_array_opt = match kind with | Pint_ignorable -> Immediates - | Punboxedfloat_ignorable Pfloat32 -> Naked_float32s - | Punboxedfloat_ignorable Pfloat64 -> Naked_floats - | Punboxedint_ignorable Pint32 -> Naked_int32s - | Punboxedint_ignorable Pint64 -> Naked_int64s - | Punboxedint_ignorable Pnativeint -> Naked_nativeints + | Punboxedfloat_ignorable Unboxed_float32 -> Naked_float32s + | Punboxedfloat_ignorable Unboxed_float64 -> Naked_floats + | Punboxedint_ignorable Unboxed_int32 -> Naked_int32s + | Punboxedint_ignorable Unboxed_int64 -> Naked_int64s + | Punboxedint_ignorable Unboxed_nativeint -> Naked_nativeints | Pproduct_ignorable kinds -> Unboxed_product (List.map convert_kind kinds) in @@ -432,17 +440,17 @@ let convert_array_kind_to_duplicate_array_kind (kind : L.array_kind) : Float_array_opt_dynamic | Paddrarray -> Duplicate_array_kind Values | Pintarray -> Duplicate_array_kind Immediates - | Pfloatarray | Punboxedfloatarray Pfloat64 -> + | Pfloatarray | Punboxedfloatarray Unboxed_float64 -> Duplicate_array_kind (Naked_floats { length = None }) - | Punboxedfloatarray Pfloat32 -> + | Punboxedfloatarray Unboxed_float32 -> Duplicate_array_kind (Naked_float32s { length = None }) - | Punboxedintarray Pint32 -> + | Punboxedintarray Unboxed_int32 -> Duplicate_array_kind (Naked_int32s { length = None }) - | Punboxedintarray Pint64 -> + | Punboxedintarray Unboxed_int64 -> Duplicate_array_kind (Naked_int64s { length = None }) - | Punboxedintarray Pnativeint -> + | Punboxedintarray Unboxed_nativeint -> Duplicate_array_kind (Naked_nativeints { length = None }) - | Punboxedvectorarray Pvec128 -> + | Punboxedvectorarray Unboxed_vec128 -> Duplicate_array_kind (Naked_vec128s { length = None }) | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> Misc.fatal_error @@ -527,11 +535,11 @@ let bint_shift bi mode prim arg1 arg2 = let convert_index_to_tagged_int ~index ~(index_kind : Lambda.array_index_kind) = match index_kind with | Ptagged_int_index -> index - | Punboxed_int_index bint -> + | Punboxed_int_index ubint -> H.Prim (Unary ( Num_conv - { src = standard_int_or_float_of_boxed_integer bint; + { src = standard_int_or_float_of_unboxed_integer ubint; dst = Tagged_immediate }, index )) @@ -541,7 +549,7 @@ let convert_index_to_untagged_int ~index ~(index_kind : Lambda.array_index_kind) let src : I_or_f.t = match index_kind with | Ptagged_int_index -> Tagged_immediate - | Punboxed_int_index bint -> standard_int_or_float_of_boxed_integer bint + | Punboxed_int_index ubint -> standard_int_or_float_of_unboxed_integer ubint in H.Prim (Unary (Num_conv { src; dst = Naked_immediate }, index)) @@ -590,9 +598,9 @@ let check_bound ~(index_kind : Lambda.array_index_kind) ~(bound_kind : I.t) | Ptagged_int_index -> I.Naked_immediate, untag_int index, convert_bound_to Naked_immediate | Punboxed_int_index bint -> - ( standard_int_of_boxed_integer bint, + ( standard_int_of_unboxed_integer bint, index, - convert_bound_to (standard_int_or_float_of_boxed_integer bint) ) + convert_bound_to (standard_int_or_float_of_unboxed_integer bint) ) in Binary (Int_comp (comp_kind, Yielding_bool (Lt Unsigned)), index, bound) @@ -739,11 +747,11 @@ let string_like_load ~dbg ~unsafe assert (not boxed); tag_int | Thirty_two, Some mode -> - if boxed then box_bint Pint32 mode ~current_region else Fun.id + if boxed then box_bint Boxed_int32 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 + if boxed then box_bint Boxed_int64 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 _ @@ -765,7 +773,7 @@ let string_like_load ~dbg ~unsafe ~index_kind index let get_header obj mode ~current_region = - let wrap hd = box_bint Pnativeint mode hd ~current_region in + let wrap hd = box_bint Boxed_nativeint mode hd ~current_region in wrap (Unary (Get_header, obj)) (* Bytes-like set *) @@ -779,9 +787,9 @@ let bytes_like_set ~dbg ~unsafe | Eight | Sixteen -> assert (not boxed); untag_int - | Thirty_two -> if boxed then unbox_bint Pint32 else Fun.id + | Thirty_two -> if boxed then unbox_bint Boxed_int32 else Fun.id | Single -> if boxed then unbox_float32 else Fun.id - | Sixty_four -> if boxed then unbox_bint Pint64 else Fun.id + | Sixty_four -> if boxed then unbox_bint Boxed_int64 else Fun.id | One_twenty_eight _ -> if boxed then unbox_vec128 else Fun.id in H.Ternary @@ -1225,9 +1233,9 @@ let checked_arith_op ~dbg (bi : Lambda.boxed_integer option) op mode arg1 arg2 | Some bi, Some mode -> let kind, zero = match bi with - | Pint32 -> I.Naked_int32, Reg_width_const.naked_int32 0l - | Pint64 -> I.Naked_int64, Reg_width_const.naked_int64 0L - | Pnativeint -> + | Boxed_int32 -> I.Naked_int32, Reg_width_const.naked_int32 0l + | Boxed_int64 -> I.Naked_int64, Reg_width_const.naked_int64 0L + | Boxed_nativeint -> ( I.Naked_nativeint, Reg_width_const.naked_nativeint Targetint_32_64.zero ) in @@ -1363,9 +1371,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) let args = match lambda_array_kind with | Pgenarray | Paddrarray | Pintarray - | Punboxedfloatarray (Pfloat64 | Pfloat32) - | Punboxedintarray (Pint32 | Pint64 | Pnativeint) - | Punboxedvectorarray Pvec128 + | Punboxedfloatarray (Unboxed_float64 | Unboxed_float32) + | Punboxedintarray (Unboxed_int32 | Unboxed_int64 | Unboxed_nativeint) + | Punboxedvectorarray Unboxed_vec128 | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> args | Pfloatarray -> List.map unbox_float args @@ -1459,11 +1467,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) let arg1 = unbox_bint kind arg1 in let arg2 = unbox_bint kind arg2 in [ tag_int - (Binary (convert_boxed_integer_comparison_prim kind comp, arg1, arg2)) + (Binary (convert_unboxed_integer_comparison_prim (Primitive.unbox_integer kind) comp, arg1, arg2)) ] | Punboxed_int_comp (kind, comp), [[arg1]; [arg2]] -> [ tag_int - (Binary (convert_boxed_integer_comparison_prim kind comp, arg1, arg2)) + (Binary (convert_unboxed_integer_comparison_prim kind comp, arg1, arg2)) ] | Pfloatoffloat32 mode, [[arg]] -> let src = K.Standard_int_or_float.Naked_float32 in @@ -1477,114 +1485,114 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [ box_float32 mode (Unary (Num_conv { src; dst }, unbox_float arg)) ~current_region ] - | Pintoffloat Pfloat64, [[arg]] -> + | Pintoffloat Boxed_float64, [[arg]] -> let src = K.Standard_int_or_float.Naked_float in let dst = K.Standard_int_or_float.Tagged_immediate in [Unary (Num_conv { src; dst }, unbox_float arg)] - | Pfloatofint (Pfloat64, mode), [[arg]] -> + | Pfloatofint (Boxed_float64, mode), [[arg]] -> let src = K.Standard_int_or_float.Tagged_immediate in let dst = K.Standard_int_or_float.Naked_float in [box_float mode (Unary (Num_conv { src; dst }, arg)) ~current_region] - | Pnegfloat (Pfloat64, mode), [[arg]] -> + | Pnegfloat (Boxed_float64, mode), [[arg]] -> [ box_float mode (Unary (Float_arith (Float64, Neg), unbox_float arg)) ~current_region ] - | Pabsfloat (Pfloat64, mode), [[arg]] -> + | Pabsfloat (Boxed_float64, mode), [[arg]] -> [ box_float mode (Unary (Float_arith (Float64, Abs), unbox_float arg)) ~current_region ] - | Paddfloat (Pfloat64, mode), [[arg1]; [arg2]] -> + | Paddfloat (Boxed_float64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith (Float64, Add), unbox_float arg1, unbox_float arg2)) ~current_region ] - | Psubfloat (Pfloat64, mode), [[arg1]; [arg2]] -> + | Psubfloat (Boxed_float64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith (Float64, Sub), unbox_float arg1, unbox_float arg2)) ~current_region ] - | Pmulfloat (Pfloat64, mode), [[arg1]; [arg2]] -> + | Pmulfloat (Boxed_float64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith (Float64, Mul), unbox_float arg1, unbox_float arg2)) ~current_region ] - | Pdivfloat (Pfloat64, mode), [[arg1]; [arg2]] -> + | Pdivfloat (Boxed_float64, mode), [[arg1]; [arg2]] -> [ box_float mode (Binary (Float_arith (Float64, Div), unbox_float arg1, unbox_float arg2)) ~current_region ] - | Pfloatcomp (Pfloat64, comp), [[arg1]; [arg2]] -> + | Pfloatcomp (Boxed_float64, comp), [[arg1]; [arg2]] -> [ tag_int (Binary ( Float_comp (Float64, Yielding_bool (convert_float_comparison comp)), unbox_float arg1, unbox_float arg2 )) ] - | Punboxed_float_comp (Pfloat64, comp), [[arg1]; [arg2]] -> + | Punboxed_float_comp (Unboxed_float64, comp), [[arg1]; [arg2]] -> [ tag_int (Binary ( Float_comp (Float64, Yielding_bool (convert_float_comparison comp)), arg1, arg2 )) ] - | Punbox_float Pfloat64, [[arg]] -> [Unary (Unbox_number Naked_float, arg)] - | Pbox_float (Pfloat64, mode), [[arg]] -> + | Punbox_float Boxed_float64, [[arg]] -> [Unary (Unbox_number Naked_float, arg)] + | Pbox_float (Boxed_float64, mode), [[arg]] -> [ Unary ( Box_number ( Naked_float, Alloc_mode.For_allocations.from_lambda mode ~current_region ), arg ) ] - | Pintoffloat Pfloat32, [[arg]] -> + | Pintoffloat Boxed_float32, [[arg]] -> let src = K.Standard_int_or_float.Naked_float32 in let dst = K.Standard_int_or_float.Tagged_immediate in [Unary (Num_conv { src; dst }, unbox_float32 arg)] - | Pfloatofint (Pfloat32, mode), [[arg]] -> + | Pfloatofint (Boxed_float32, mode), [[arg]] -> let src = K.Standard_int_or_float.Tagged_immediate in let dst = K.Standard_int_or_float.Naked_float32 in [box_float32 mode (Unary (Num_conv { src; dst }, arg)) ~current_region] - | Pnegfloat (Pfloat32, mode), [[arg]] -> + | Pnegfloat (Boxed_float32, mode), [[arg]] -> [ box_float32 mode (Unary (Float_arith (Float32, Neg), unbox_float32 arg)) ~current_region ] - | Pabsfloat (Pfloat32, mode), [[arg]] -> + | Pabsfloat (Boxed_float32, mode), [[arg]] -> [ box_float32 mode (Unary (Float_arith (Float32, Abs), unbox_float32 arg)) ~current_region ] - | Paddfloat (Pfloat32, mode), [[arg1]; [arg2]] -> + | Paddfloat (Boxed_float32, mode), [[arg1]; [arg2]] -> [ box_float32 mode (Binary (Float_arith (Float32, Add), unbox_float32 arg1, unbox_float32 arg2)) ~current_region ] - | Psubfloat (Pfloat32, mode), [[arg1]; [arg2]] -> + | Psubfloat (Boxed_float32, mode), [[arg1]; [arg2]] -> [ box_float32 mode (Binary (Float_arith (Float32, Sub), unbox_float32 arg1, unbox_float32 arg2)) ~current_region ] - | Pmulfloat (Pfloat32, mode), [[arg1]; [arg2]] -> + | Pmulfloat (Boxed_float32, mode), [[arg1]; [arg2]] -> [ box_float32 mode (Binary (Float_arith (Float32, Mul), unbox_float32 arg1, unbox_float32 arg2)) ~current_region ] - | Pdivfloat (Pfloat32, mode), [[arg1]; [arg2]] -> + | Pdivfloat (Boxed_float32, mode), [[arg1]; [arg2]] -> [ box_float32 mode (Binary (Float_arith (Float32, Div), unbox_float32 arg1, unbox_float32 arg2)) ~current_region ] - | Pfloatcomp (Pfloat32, comp), [[arg1]; [arg2]] -> + | Pfloatcomp (Boxed_float32, comp), [[arg1]; [arg2]] -> [ tag_int (Binary ( Float_comp (Float32, Yielding_bool (convert_float_comparison comp)), unbox_float32 arg1, unbox_float32 arg2 )) ] - | Punboxed_float_comp (Pfloat32, comp), [[arg1]; [arg2]] -> + | Punboxed_float_comp (Unboxed_float32, comp), [[arg1]; [arg2]] -> [ tag_int (Binary ( Float_comp (Float32, Yielding_bool (convert_float_comparison comp)), arg1, arg2 )) ] - | Punbox_float Pfloat32, [[arg]] -> [Unary (Unbox_number Naked_float32, arg)] - | Pbox_float (Pfloat32, mode), [[arg]] -> + | Punbox_float Boxed_float32, [[arg]] -> [Unary (Unbox_number Naked_float32, arg)] + | Pbox_float (Boxed_float32, mode), [[arg]] -> [ Unary ( Box_number ( Naked_float32, Alloc_mode.For_allocations.from_lambda mode ~current_region ), arg ) ] - | Punbox_vector Pvec128, [[arg]] -> [Unary (Unbox_number Naked_vec128, arg)] - | Pbox_vector (Pvec128, mode), [[arg]] -> + | Punbox_vector Boxed_vec128, [[arg]] -> [Unary (Unbox_number Naked_vec128, arg)] + | Pbox_vector (Boxed_vec128, mode), [[arg]] -> [ Unary ( Box_number ( Naked_vec128, @@ -1924,23 +1932,23 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [checked_arith_op ~dbg None Div None arg1 arg2 ~current_region] | Pmodint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Mod None arg1 arg2 ~current_region] - | Pdivbint { size = Pint32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> - [ checked_arith_op ~dbg (Some Pint32) Div (Some mode) arg1 arg2 + | Pdivbint { size = Boxed_int32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Boxed_int32) Div (Some mode) arg1 arg2 ~current_region ] - | Pmodbint { size = Pint32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> - [ checked_arith_op ~dbg (Some Pint32) Mod (Some mode) arg1 arg2 + | Pmodbint { size = Boxed_int32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Boxed_int32) Mod (Some mode) arg1 arg2 ~current_region ] - | Pdivbint { size = Pint64; is_safe = Safe; mode }, [[arg1]; [arg2]] -> - [ checked_arith_op ~dbg (Some Pint64) Div (Some mode) arg1 arg2 + | Pdivbint { size = Boxed_int64; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Boxed_int64) Div (Some mode) arg1 arg2 ~current_region ] - | Pmodbint { size = Pint64; is_safe = Safe; mode }, [[arg1]; [arg2]] -> - [ checked_arith_op ~dbg (Some Pint64) Mod (Some mode) arg1 arg2 + | Pmodbint { size = Boxed_int64; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Boxed_int64) Mod (Some mode) arg1 arg2 ~current_region ] - | Pdivbint { size = Pnativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] -> - [ checked_arith_op ~dbg (Some Pnativeint) Div (Some mode) arg1 arg2 + | Pdivbint { size = Boxed_nativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Boxed_nativeint) Div (Some mode) arg1 arg2 ~current_region ] - | Pmodbint { size = Pnativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] -> - [ checked_arith_op ~dbg (Some Pnativeint) Mod (Some mode) arg1 arg2 + | Pmodbint { size = Boxed_nativeint; is_safe = Safe; mode }, [[arg1]; [arg2]] -> + [ checked_arith_op ~dbg (Some Boxed_nativeint) Mod (Some mode) arg1 arg2 ~current_region ] | Parrayrefu (array_ref_kind, index_kind, mut), [[array]; [index]] -> (* For this and the following cases we will end up relying on the backend to @@ -2036,11 +2044,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [ tag_int (Unary (Int_arith (Naked_immediate, Swap_byte_endianness), untag_int arg)) ] - | Pbbswap (Pint32, mode), [[arg]] -> + | Pbbswap (Boxed_int32, mode), [[arg]] -> [bbswap Naked_int32 Naked_int32 mode arg ~current_region] - | Pbbswap (Pint64, mode), [[arg]] -> + | Pbbswap (Boxed_int64, mode), [[arg]] -> [bbswap Naked_int64 Naked_int64 mode arg ~current_region] - | Pbbswap (Pnativeint, mode), [[arg]] -> + | Pbbswap (Boxed_nativeint, mode), [[arg]] -> [bbswap Naked_nativeint Naked_nativeint mode arg ~current_region] | Pint_as_pointer mode, [[arg]] -> (* This is not a stack allocation, but nonetheless has a region @@ -2236,13 +2244,13 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) (Tagged_immediate, Yielding_int_like_compare_functions Signed), i1, i2 )) ] - | Pcompare_floats Pfloat64, [[f1]; [f2]] -> + | Pcompare_floats Boxed_float64, [[f1]; [f2]] -> [ tag_int (Binary ( Float_comp (Float64, Yielding_int_like_compare_functions ()), Prim (Unary (Unbox_number Naked_float, f1)), Prim (Unary (Unbox_number Naked_float, f2)) )) ] - | Pcompare_floats Pfloat32, [[f1]; [f2]] -> + | Pcompare_floats Boxed_float32, [[f1]; [f2]] -> [ tag_int (Binary ( Float_comp (Float32, Yielding_int_like_compare_functions ()), diff --git a/middle_end/flambda2/kinds/flambda_arity.ml b/middle_end/flambda2/kinds/flambda_arity.ml index f5b035a3bcd..d9a0c44a7e1 100644 --- a/middle_end/flambda2/kinds/flambda_arity.ml +++ b/middle_end/flambda2/kinds/flambda_arity.ml @@ -73,12 +73,12 @@ module Component_for_creation = struct let rec from_lambda (layout : Lambda.layout) = match layout with | Pvalue vk -> Singleton (KS.from_lambda_value_kind vk) - | Punboxed_float Pfloat64 -> Singleton KS.naked_float - | Punboxed_float Pfloat32 -> Singleton KS.naked_float32 - | Punboxed_int Pint32 -> Singleton KS.naked_int32 - | Punboxed_int Pint64 -> Singleton KS.naked_int64 - | Punboxed_int Pnativeint -> Singleton KS.naked_nativeint - | Punboxed_vector Pvec128 -> Singleton KS.naked_vec128 + | Punboxed_float Unboxed_float64 -> Singleton KS.naked_float + | Punboxed_float Unboxed_float32 -> Singleton KS.naked_float32 + | Punboxed_int Unboxed_int32 -> Singleton KS.naked_int32 + | Punboxed_int Unboxed_int64 -> Singleton KS.naked_int64 + | Punboxed_int Unboxed_nativeint -> Singleton KS.naked_nativeint + | Punboxed_vector Unboxed_vec128 -> Singleton KS.naked_vec128 | Punboxed_product layouts -> Unboxed_product (List.map from_lambda layouts) | Ptop | Pbottom -> Misc.fatal_errorf diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index 69594cd582a..38e47286c04 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -84,12 +84,12 @@ let to_lambda (t : t) : Lambda.layout = | Value -> Lambda.layout_any_value | Naked_number Naked_immediate -> Misc.fatal_error "Can't convert kind [Naked_immediate] to lambda layout" - | Naked_number Naked_float -> Punboxed_float Pfloat64 - | Naked_number Naked_float32 -> Punboxed_float Pfloat32 - | Naked_number Naked_int32 -> Punboxed_int Pint32 - | Naked_number Naked_int64 -> Punboxed_int Pint64 - | Naked_number Naked_nativeint -> Punboxed_int Pnativeint - | Naked_number Naked_vec128 -> Punboxed_vector Pvec128 + | Naked_number Naked_float -> Punboxed_float Unboxed_float64 + | Naked_number Naked_float32 -> Punboxed_float Unboxed_float32 + | Naked_number Naked_int32 -> Punboxed_int Unboxed_int32 + | Naked_number Naked_int64 -> Punboxed_int Unboxed_int64 + | Naked_number Naked_nativeint -> Punboxed_int Unboxed_nativeint + | Naked_number Naked_vec128 -> Punboxed_vector Unboxed_vec128 | Region -> Misc.fatal_error "Can't convert kind [Region] to lambda layout" | Rec_info -> Misc.fatal_error "Can't convert kind [Rec_info] to lambda layout" @@ -494,9 +494,9 @@ module Boxable_number = struct let primitive_kind t : Primitive.boxed_integer = match t with | Naked_vec128 | Naked_float | Naked_float32 -> assert false - | Naked_int32 -> Pint32 - | Naked_int64 -> Pint64 - | Naked_nativeint -> Pnativeint + | Naked_int32 -> Boxed_int32 + | Naked_int64 -> Boxed_int64 + | Naked_nativeint -> Boxed_nativeint include Container_types.Make (struct type nonrec t = t @@ -900,12 +900,12 @@ module With_subkind = struct let value_subkind : Non_null_value_subkind.t = match vk.raw_kind with | Pgenval -> Anything - | Pboxedfloatval Pfloat64 -> Boxed_float - | Pboxedfloatval Pfloat32 -> Boxed_float32 - | Pboxedintval Pint32 -> Boxed_int32 - | Pboxedintval Pint64 -> Boxed_int64 - | Pboxedintval Pnativeint -> Boxed_nativeint - | Pboxedvectorval Pvec128 -> Boxed_vec128 + | Pboxedfloatval Boxed_float64 -> Boxed_float + | Pboxedfloatval Boxed_float32 -> Boxed_float32 + | Pboxedintval Boxed_int32 -> Boxed_int32 + | Pboxedintval Boxed_int64 -> Boxed_int64 + | Pboxedintval Boxed_nativeint -> Boxed_nativeint + | Pboxedvectorval Boxed_vec128 -> Boxed_vec128 | Pintval -> Tagged_immediate | Pvariant { consts; non_consts } -> ( match consts, non_consts with @@ -960,12 +960,12 @@ module With_subkind = struct | Parrayval Pintarray -> Immediate_array | Parrayval Paddrarray -> Value_array | Parrayval Pgenarray -> Generic_array - | Parrayval (Punboxedfloatarray Pfloat64) -> Float_array - | Parrayval (Punboxedfloatarray Pfloat32) -> Unboxed_float32_array - | Parrayval (Punboxedintarray Pint32) -> Unboxed_int32_array - | Parrayval (Punboxedintarray Pint64) -> Unboxed_int64_array - | Parrayval (Punboxedintarray Pnativeint) -> Unboxed_nativeint_array - | Parrayval (Punboxedvectorarray Pvec128) -> Unboxed_vec128_array + | Parrayval (Punboxedfloatarray Unboxed_float64) -> Float_array + | Parrayval (Punboxedfloatarray Unboxed_float32) -> Unboxed_float32_array + | Parrayval (Punboxedintarray Unboxed_int32) -> Unboxed_int32_array + | Parrayval (Punboxedintarray Unboxed_int64) -> Unboxed_int64_array + | Parrayval (Punboxedintarray Unboxed_nativeint) -> Unboxed_nativeint_array + | Parrayval (Punboxedvectorarray Unboxed_vec128) -> Unboxed_vec128_array | Parrayval (Pgcscannableproductarray _ | Pgcignorableproductarray _) -> Unboxed_product_array in @@ -979,12 +979,12 @@ module With_subkind = struct let from_lambda_values_and_unboxed_numbers_only (layout : Lambda.layout) = match layout with | Pvalue vk -> from_lambda_value_kind vk - | Punboxed_float Pfloat64 -> naked_float - | Punboxed_float Pfloat32 -> naked_float32 - | Punboxed_int Pint32 -> naked_int32 - | Punboxed_int Pint64 -> naked_int64 - | Punboxed_int Pnativeint -> naked_nativeint - | Punboxed_vector Pvec128 -> naked_vec128 + | Punboxed_float Unboxed_float64 -> naked_float + | Punboxed_float Unboxed_float32 -> naked_float32 + | Punboxed_int Unboxed_int32 -> naked_int32 + | Punboxed_int Unboxed_int64 -> naked_int64 + | Punboxed_int Unboxed_nativeint -> naked_nativeint + | Punboxed_vector Unboxed_vec128 -> naked_vec128 | Punboxed_product _ | Ptop | Pbottom -> Misc.fatal_errorf "Flambda_kind.from_lambda_values_and_unboxed_numbers_only: cannot \ diff --git a/middle_end/flambda2/term_basics/empty_array_kind.ml b/middle_end/flambda2/term_basics/empty_array_kind.ml index dea965ff74d..d6631a0064b 100644 --- a/middle_end/flambda2/term_basics/empty_array_kind.ml +++ b/middle_end/flambda2/term_basics/empty_array_kind.ml @@ -54,11 +54,11 @@ let of_element_kind t = let of_lambda array_kind = match (array_kind : Lambda.array_kind) with | Pgenarray | Paddrarray | Pintarray | Pfloatarray - | Punboxedfloatarray Pfloat64 -> + | Punboxedfloatarray Unboxed_float64 -> Values_or_immediates_or_naked_floats - | Punboxedfloatarray Pfloat32 -> Naked_float32s - | Punboxedintarray Pint32 -> Naked_int32s - | Punboxedintarray Pint64 -> Naked_int64s - | Punboxedintarray Pnativeint -> Naked_nativeints - | Punboxedvectorarray Pvec128 -> Naked_vec128s + | Punboxedfloatarray Unboxed_float32 -> Naked_float32s + | Punboxedintarray Unboxed_int32 -> Naked_int32s + | Punboxedintarray Unboxed_int64 -> Naked_int64s + | Punboxedintarray Unboxed_nativeint -> Naked_nativeints + | Punboxedvectorarray Unboxed_vec128 -> Naked_vec128s | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> Unboxed_products diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index d81332bffde..48f3244b8fa 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -545,9 +545,9 @@ let unary_int_arith_primitive _env dbg kind op arg = order to match the Lambda semantics (where the swap might affect the sign). *) | Naked_int32, Swap_byte_endianness -> - C.sign_extend_32 dbg (C.bbswap Pint32 arg dbg) - | Naked_int64, Swap_byte_endianness -> C.bbswap Pint64 arg dbg - | Naked_nativeint, Swap_byte_endianness -> C.bbswap Pnativeint arg dbg + C.sign_extend_32 dbg (C.bbswap Unboxed_int32 arg dbg) + | Naked_int64, Swap_byte_endianness -> C.bbswap Unboxed_int64 arg dbg + | Naked_nativeint, Swap_byte_endianness -> C.bbswap Unboxed_nativeint arg dbg let unary_float_arith_primitive _env dbg width op arg = match (width : P.float_bitwidth), (op : P.unary_float_arith_op) with @@ -672,8 +672,8 @@ let binary_int_arith_primitive _env dbg (kind : K.Standard_int.t) if it doesn't support operations on 32-bit physical registers. There was a prototype developed of this but it was quite complicated and didn't get merged.) *) - C.sign_extend_32 dbg (C.safe_div_bi Unsafe x y Pint32 dbg) - | Mod -> C.sign_extend_32 dbg (C.safe_mod_bi Unsafe x y Pint32 dbg)) + C.sign_extend_32 dbg (C.safe_div_bi Unsafe x y Boxed_int32 dbg) + | Mod -> C.sign_extend_32 dbg (C.safe_mod_bi Unsafe x y Boxed_int32 dbg)) | Naked_immediate -> ( let sign_extend_63_can_delay_overflow f = C.sign_extend_63 dbg (f (C.low_63 dbg x) (C.low_63 dbg y) dbg) @@ -685,14 +685,14 @@ let binary_int_arith_primitive _env dbg (kind : K.Standard_int.t) | Xor -> sign_extend_63_can_delay_overflow C.xor_int | And -> sign_extend_63_can_delay_overflow C.and_int | Or -> sign_extend_63_can_delay_overflow C.or_int - | Div -> C.sign_extend_63 dbg (C.safe_div_bi Unsafe x y Pint64 dbg) - | Mod -> C.sign_extend_63 dbg (C.safe_mod_bi Unsafe x y Pint64 dbg)) + | Div -> C.sign_extend_63 dbg (C.safe_div_bi Unsafe x y Boxed_int64 dbg) + | Mod -> C.sign_extend_63 dbg (C.safe_mod_bi Unsafe x y Boxed_int64 dbg)) | Naked_int64 | Naked_nativeint -> ( (* Machine-width integers, no sign extension required. *) let bi : Primitive.boxed_integer = match kind with - | Naked_int64 -> Pint64 - | Naked_nativeint -> Pnativeint + | Naked_int64 -> Boxed_int64 + | Naked_nativeint -> Boxed_nativeint | Naked_int32 | Naked_immediate | Tagged_immediate -> assert false in match op with diff --git a/middle_end/flambda2/types/env/typing_env.ml b/middle_end/flambda2/types/env/typing_env.ml index d233d7f82eb..7fb291c552c 100644 --- a/middle_end/flambda2/types/env/typing_env.ml +++ b/middle_end/flambda2/types/env/typing_env.ml @@ -265,7 +265,14 @@ end = struct let already_meeting = already_meeting_or_joining end -type meet_type_new = t -> TG.t -> TG.t -> (TG.t * t) Or_bottom.t +type 'a meet_return_value = + | Left_input + | Right_input + | Both_inputs + | New_result of 'a + +type meet_type_new = + t -> TG.t -> TG.t -> (TG.t meet_return_value * t) Or_bottom.t type meet_type_old = Meet_env.t -> TG.t -> TG.t -> (TG.t * Typing_env_extension.t) Or_bottom.t @@ -894,37 +901,35 @@ and add_equation1 ~raise_on_bottom t name ty ~(meet_type : meet_type) = meet ty". Note also that [p] and [x] may have different name modes! *) - let ty, t = - let[@inline always] name eqn_name ~coercion = - assert (Coercion.is_id coercion); - (* true by definition *) - match meet_type with - | New meet_type_new -> ( - let existing_ty = find t eqn_name (Some (TG.kind ty)) in - match meet_type_new t ty existing_ty with - | Bottom -> - if raise_on_bottom - then raise Bottom_equation - else MTC.bottom (TG.kind ty), t - | Ok (meet_ty, env) -> meet_ty, env) - | Old meet_type_old -> ( - if Name.equal name eqn_name - then ty, t - else - let env = Meet_env.create t in - let existing_ty = find t eqn_name (Some (TG.kind ty)) in - match meet_type_old env ty existing_ty with - | Bottom -> MTC.bottom (TG.kind ty), t - | Ok (meet_ty, env_extension) -> - ( meet_ty, - add_env_extension ~raise_on_bottom t env_extension ~meet_type )) - in - Simple.pattern_match bare_lhs ~name ~const:(fun _ -> ty, t) - in - let[@inline always] name name ~coercion = + let[@inline always] name eqn_name ~coercion = assert (Coercion.is_id coercion); (* true by definition *) - add_equation0 t name ty + match meet_type with + | New meet_type_new -> ( + let existing_ty = find t eqn_name (Some (TG.kind ty)) in + match meet_type_new t ty existing_ty with + | Bottom -> + if raise_on_bottom + then raise Bottom_equation + else add_equation0 t eqn_name (MTC.bottom (TG.kind ty)) + | Ok (meet_ty, env) -> ( + match meet_ty with + | Left_input -> add_equation0 env eqn_name ty + | Right_input | Both_inputs -> env + | New_result ty' -> add_equation0 env eqn_name ty')) + | Old meet_type_old -> ( + if Name.equal name eqn_name + then add_equation0 t eqn_name ty + else + let env = Meet_env.create t in + let existing_ty = find t eqn_name (Some (TG.kind ty)) in + match meet_type_old env ty existing_ty with + | Bottom -> add_equation0 t eqn_name (MTC.bottom (TG.kind ty)) + | Ok (meet_ty, env_extension) -> + let t = + add_env_extension ~raise_on_bottom t env_extension ~meet_type + in + add_equation0 t eqn_name meet_ty) in Simple.pattern_match bare_lhs ~name ~const:(fun _ -> t) diff --git a/middle_end/flambda2/types/env/typing_env.mli b/middle_end/flambda2/types/env/typing_env.mli index 4dff689c204..284e598dc8d 100644 --- a/middle_end/flambda2/types/env/typing_env.mli +++ b/middle_end/flambda2/types/env/typing_env.mli @@ -95,8 +95,17 @@ module Join_env : sig val already_joining : t -> Simple.t -> Simple.t -> bool end +type 'a meet_return_value = + | Left_input + | Right_input + | Both_inputs + | New_result of 'a + type meet_type_new = - t -> Type_grammar.t -> Type_grammar.t -> (Type_grammar.t * t) Or_bottom.t + t -> + Type_grammar.t -> + Type_grammar.t -> + (Type_grammar.t meet_return_value * t) Or_bottom.t type meet_type_old = Meet_env.t -> diff --git a/middle_end/flambda2/types/meet_and_join_new.ml b/middle_end/flambda2/types/meet_and_join_new.ml index 113e5d626e4..538792111a2 100644 --- a/middle_end/flambda2/types/meet_and_join_new.ml +++ b/middle_end/flambda2/types/meet_and_join_new.ml @@ -33,7 +33,7 @@ let all_aliases_of env simple_opt ~in_env = ~f:(fun simple -> TE.mem_simple in_env simple) simples -type 'a meet_return_value = +type 'a meet_return_value = 'a TE.meet_return_value = | Left_input | Right_input | Both_inputs @@ -52,8 +52,7 @@ type 'a meet_result = let add_equation (simple : Simple.t) ty_of_simple env ~meet_type : unit meet_result = - match Simple.must_be_name simple with - | Some (name, coercion_from_name_to_simple) -> ( + let name name ~coercion:coercion_from_name_to_simple = let coercion_from_simple_to_name = Coercion.inverse coercion_from_name_to_simple in @@ -64,8 +63,20 @@ let add_equation (simple : Simple.t) ty_of_simple env ~meet_type : TE.add_equation_strict env name ty_of_name ~meet_type:(TE.New meet_type) with | Ok env -> Ok (New_result (), env) - | Bottom -> Bottom (New_result ())) - | None -> Ok (New_result (), env) + | Bottom -> Bottom (New_result ()) + in + Simple.pattern_match simple ~name ~const:(fun const -> + (* A constant is its own most precise type, but we still need to check + that is matches the assigned type. *) + if Flambda_features.check_light_invariants () + then assert (TG.get_alias_opt ty_of_simple == None); + let expanded = + Expand_head.expand_head0 env (MTC.type_for_const const) + ~known_canonical_simple_at_in_types_mode:(Some simple) + in + match meet_type env (ET.to_type expanded) ty_of_simple with + | Or_bottom.Ok (_, env) -> Ok (New_result (), env) + | Or_bottom.Bottom -> Bottom (New_result ())) let map_result ~f = function | Bottom r -> Bottom r @@ -505,49 +516,36 @@ let rec meet env (t1 : TG.t) (t2 : TG.t) : TG.t meet_result = Expand_head.expand_head0 env t1 ~known_canonical_simple_at_in_types_mode:simple1 in - let expanded2 = - Expand_head.expand_head0 env t2 - ~known_canonical_simple_at_in_types_mode:simple2 - in match simple2 with | None -> + let expanded2 = + Expand_head.expand_head0 env t2 + ~known_canonical_simple_at_in_types_mode:simple2 + in map_result ~f:ET.to_type (meet_expanded_head env expanded1 expanded2) | Some simple2 -> ( (* Here we are meeting a non-alias type on the left with an alias on the right. In all cases, the return type is the alias, so we will always - return [Right_input]; the interesting part will be the environment. *) + return [Right_input]; the interesting part will be the environment. + + [add_equation] will meet [expanded1] with the existing type of + [simple2]. *) let env : unit meet_result = - match meet_expanded_head env expanded1 expanded2 with - | Ok (Left_input, env) -> - add_equation simple2 (ET.to_type expanded1) env ~meet_type - | Ok ((Right_input | Both_inputs), env) -> Ok (New_result (), env) - | Ok (New_result expanded, env) -> - add_equation simple2 (ET.to_type expanded) env ~meet_type - | Bottom r -> Bottom r + add_equation simple2 (ET.to_type expanded1) env ~meet_type in match env with | Ok (_, env) -> Ok (Right_input, env) | Bottom r -> Bottom r)) - | Some simple1 as simple1_opt -> ( + | Some simple1 -> ( match simple2 with | None -> ( - let expanded1 = - Expand_head.expand_head0 env t1 - ~known_canonical_simple_at_in_types_mode:simple1_opt - in let expanded2 = Expand_head.expand_head0 env t2 ~known_canonical_simple_at_in_types_mode:simple2 in (* We always return [Left_input] (see comment above) *) let env : unit meet_result = - match meet_expanded_head env expanded1 expanded2 with - | Ok (Right_input, env) -> - add_equation simple1 (ET.to_type expanded2) env ~meet_type - | Ok ((Left_input | Both_inputs), env) -> Ok (New_result (), env) - | Ok (New_result expanded, env) -> - add_equation simple1 (ET.to_type expanded) env ~meet_type - | Bottom r -> Bottom r + add_equation simple1 (ET.to_type expanded2) env ~meet_type in match env with | Ok (_, env) -> Ok (Left_input, env) @@ -1531,7 +1529,7 @@ and meet_type env t1 t2 : _ Or_bottom.t = then Bottom else match meet env t1 t2 with - | Ok (res, env) -> Ok (extract_value res t1 t2, env) + | Ok (res, env) -> Ok (res, env) | Bottom _ -> Bottom and join ?bound_name env (t1 : TG.t) (t2 : TG.t) : TG.t Or_unknown.t = diff --git a/middle_end/flambda2/types/meet_and_join_new.mli b/middle_end/flambda2/types/meet_and_join_new.mli index 13655f0de04..39b3c70e1f7 100644 --- a/middle_end/flambda2/types/meet_and_join_new.mli +++ b/middle_end/flambda2/types/meet_and_join_new.mli @@ -49,4 +49,4 @@ val meet_type : Typing_env.t -> Type_grammar.t -> Type_grammar.t -> - (Type_grammar.t * Typing_env.t) Or_bottom.t + (Type_grammar.t Typing_env.meet_return_value * Typing_env.t) Or_bottom.t diff --git a/testsuite/tests/typing-unique/unique.ml b/testsuite/tests/typing-unique/unique.ml index 46a1b0ef9c7..d8a840cefb0 100644 --- a/testsuite/tests/typing-unique/unique.ml +++ b/testsuite/tests/typing-unique/unique.ml @@ -597,10 +597,18 @@ let array_pats (arr : int option array) = | [| o |] -> let _ = unique_id arr in aliased_id o | _ -> None [%%expect{| -val array_pats : int option array @ unique -> int option = +Line 3, characters 33-36: +3 | | [| o |] -> let _ = unique_id arr in aliased_id o + ^^^ +Error: This value is used here as unique, + but it has already been used in an array pattern: +Line 3, characters 4-11: +3 | | [| o |] -> let _ = unique_id arr in aliased_id o + ^^^^^^^ + |}] -let array_pats (arr : int option iarray) = +let iarray_pats (arr : int option iarray) = match arr with | [: o :] -> let _ = unique_id arr in unique_id o | _ -> None @@ -622,3 +630,67 @@ let shadow x = [%%expect{| val shadow : 'a -> 'a * (int * int) = |}] + +let array_pat_barrier (arr : int option array) = + match arr with + | [| _ |] -> unique_id arr + | _ -> [| None |] +[%%expect{| +Line 3, characters 25-28: +3 | | [| _ |] -> unique_id arr + ^^^ +Error: This value is used here as unique, + but it has already been used in an array pattern: +Line 3, characters 4-11: +3 | | [| _ |] -> unique_id arr + ^^^^^^^ + +|}] + +let iarray_pat_barrier (arr : int option iarray) = + match arr with + | [: _ :] -> unique_id arr + | _ -> [: None :] +[%%expect{| +Line 3, characters 25-28: +3 | | [: _ :] -> unique_id arr + ^^^ +Error: This value is used here as unique, + but it has already been used in an array pattern: +Line 3, characters 4-11: +3 | | [: _ :] -> unique_id arr + ^^^^^^^ + +|}] + +let constant_pat_barrier (opt : int option) = + match opt with + | Some 1 -> unique_id opt + | _ -> None +[%%expect{| +Line 3, characters 24-27: +3 | | Some 1 -> unique_id opt + ^^^ +Error: This value is used here as unique, + but part of it has already been used in a constant pattern: +Line 3, characters 9-10: +3 | | Some 1 -> unique_id opt + ^ + +|}] + +let lazy_pat_barrier (l : int Lazy.t) = + match l with + | lazy 1 -> unique_id l + | _ -> lazy 2 +[%%expect{| +Line 3, characters 24-25: +3 | | lazy 1 -> unique_id l + ^ +Error: This value is used here as unique, + but it has already been used in a lazy pattern: +Line 3, characters 4-10: +3 | | lazy 1 -> unique_id l + ^^^^^^ + +|}] diff --git a/typing/primitive.ml b/typing/primitive.ml index 58ad2ac79f4..d65a140d6af 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -20,11 +20,13 @@ open Parsetree module String = Misc.Stdlib.String -type boxed_integer = Pnativeint | Pint32 | Pint64 +type unboxed_integer = Unboxed_int64 | Unboxed_nativeint | Unboxed_int32 +type unboxed_float = Unboxed_float64 | Unboxed_float32 +type unboxed_vector = Unboxed_vec128 -type boxed_float = Pfloat64 | Pfloat32 - -type boxed_vector = Pvec128 +type boxed_integer = Boxed_int64 | Boxed_nativeint | Boxed_int32 +type boxed_float = Boxed_float64 | Boxed_float32 +type boxed_vector = Boxed_vec128 type native_repr = | Repr_poly @@ -193,8 +195,8 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res ~is_layout_poly Inconsistent_noalloc_attributes_for_effects)); let native_repr_args, native_repr_res = if old_style_float then - (make_prim_repr_args arity (Prim_global, Unboxed_float Pfloat64), - (Prim_global, Unboxed_float Pfloat64)) + (make_prim_repr_args arity (Prim_global, Unboxed_float Boxed_float64), + (Prim_global, Unboxed_float Boxed_float64)) else (native_repr_args, native_repr_res) in @@ -330,30 +332,45 @@ let native_name p = let byte_name p = p.prim_name -let equal_boxed_vector v1 v2 = - match v1, v2 with - | Pvec128, Pvec128 -> true +let unbox_integer = function + | Boxed_int64 -> Unboxed_int64 + | Boxed_nativeint -> Unboxed_nativeint + | Boxed_int32 -> Unboxed_int32 + +let unbox_float = function + | Boxed_float64 -> Unboxed_float64 + | Boxed_float32 -> Unboxed_float32 + +let unbox_vector = function + | Boxed_vec128 -> Unboxed_vec128 + +(* since these are just constant constructors, we can just use polymorphic + equality and comparison at no performance loss: *) +let equal_unboxed_integer + ((Unboxed_int32 | Unboxed_nativeint | Unboxed_int64) as i1) i2 = i1 = i2 +let equal_unboxed_float + ((Unboxed_float32 | Unboxed_float64) as f1) f2 = f1 = f2 +let compare_unboxed_float + ((Unboxed_float32 | Unboxed_float64) as f1) f2 = Stdlib.compare f1 f2 +let equal_unboxed_vector ((Unboxed_vec128) as v1) v2 = v1 = v2 +let compare_unboxed_vector ((Unboxed_vec128) as v1) v2 = Stdlib.compare v1 v2 let equal_boxed_integer bi1 bi2 = - match bi1, bi2 with - | Pnativeint, Pnativeint - | Pint32, Pint32 - | Pint64, Pint64 -> - true - | (Pnativeint | Pint32 | Pint64), _ -> - false - -let equal_boxed_float f1 f2 = - match f1, f2 with - | Pfloat32, Pfloat32 - | Pfloat64, Pfloat64 -> true - | (Pfloat32 | Pfloat64), _ -> false - -let equal_boxed_vector_size bi1 bi2 = + equal_unboxed_integer (unbox_integer bi1) (unbox_integer bi2) +let equal_boxed_float bf1 bf2 = + equal_unboxed_float (unbox_float bf1) (unbox_float bf2) +let equal_boxed_vector bv1 bv2 = + equal_unboxed_vector (unbox_vector bv1) (unbox_vector bv2) +let compare_boxed_float bf1 bf2 = + compare_unboxed_float (unbox_float bf1) (unbox_float bf2) +let compare_boxed_vector bv1 bv2 = + compare_unboxed_vector (unbox_vector bv1) (unbox_vector bv2) + +let equal_unboxed_vector_size v1 v2 = (* For the purposes of layouts/native representations, all 128-bit vector types are equal. *) - match bi1, bi2 with - | Pvec128, Pvec128 -> true + match v1, v2 with + | Unboxed_vec128, Unboxed_vec128 -> true let equal_native_repr nr1 nr2 = match nr1, nr2 with @@ -361,7 +378,8 @@ let equal_native_repr nr1 nr2 = | Repr_poly, (Unboxed_float _ | Unboxed_integer _ | Untagged_immediate | Unboxed_vector _ | Same_as_ocaml_repr _) | (Unboxed_float _ | Unboxed_integer _ - | Untagged_immediate | Unboxed_vector _ | Same_as_ocaml_repr _), Repr_poly -> false + | Untagged_immediate | Unboxed_vector _ | Same_as_ocaml_repr _), Repr_poly + -> false | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> Jkind_types.Sort.Const.equal s1 s2 | Same_as_ocaml_repr _, @@ -371,7 +389,8 @@ let equal_native_repr nr1 nr2 = | Unboxed_float _, (Same_as_ocaml_repr _ | Unboxed_integer _ | Untagged_immediate | Unboxed_vector _) -> false - | Unboxed_vector vi1, Unboxed_vector vi2 -> equal_boxed_vector_size vi1 vi2 + | Unboxed_vector vi1, Unboxed_vector vi2 -> + equal_unboxed_vector_size (unbox_vector vi1) (unbox_vector vi2) | Unboxed_vector _, (Same_as_ocaml_repr _ | Unboxed_float _ | Untagged_immediate | Unboxed_integer _) -> false diff --git a/typing/primitive.mli b/typing/primitive.mli index 54db1ac2e82..1d72dd5751f 100644 --- a/typing/primitive.mli +++ b/typing/primitive.mli @@ -15,11 +15,13 @@ (* Description of primitive functions *) -type boxed_integer = Pnativeint | Pint32 | Pint64 +type unboxed_integer = Unboxed_int64 | Unboxed_nativeint | Unboxed_int32 +type unboxed_float = Unboxed_float64 | Unboxed_float32 +type unboxed_vector = Unboxed_vec128 -type boxed_float = Pfloat64 | Pfloat32 - -type boxed_vector = Pvec128 +type boxed_integer = Boxed_int64 | Boxed_nativeint | Boxed_int32 +type boxed_float = Boxed_float64 | Boxed_float32 +type boxed_vector = Boxed_vec128 (* Representation of arguments/result for the native code version of a primitive *) @@ -97,9 +99,20 @@ val print val native_name: 'a description_gen -> string val byte_name: 'a description_gen -> string + +val unbox_float : boxed_float -> unboxed_float +val unbox_integer : boxed_integer -> unboxed_integer +val unbox_vector : boxed_vector -> unboxed_vector +val equal_unboxed_integer : unboxed_integer -> unboxed_integer -> bool +val equal_unboxed_float : unboxed_float -> unboxed_float -> bool +val equal_unboxed_vector : unboxed_vector -> unboxed_vector -> bool +val compare_unboxed_float : unboxed_float -> unboxed_float -> int +val compare_unboxed_vector : unboxed_vector -> unboxed_vector -> int val equal_boxed_integer : boxed_integer -> boxed_integer -> bool val equal_boxed_float : boxed_float -> boxed_float -> bool val equal_boxed_vector : boxed_vector -> boxed_vector -> bool +val compare_boxed_float : boxed_float -> boxed_float -> int +val compare_boxed_vector : boxed_vector -> boxed_vector -> int val equal_native_repr : native_repr -> native_repr -> bool val equal_effects : effects -> effects -> bool val equal_coeffects : coeffects -> coeffects -> bool diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 7c1747e97a9..2641c8cd8b0 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -2751,27 +2751,27 @@ let native_repr_of_type env kind ty sort_or_poly = -> Some Untagged_immediate | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> - Some (Unboxed_float Pfloat64) + Some (Unboxed_float Boxed_float64) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float32 -> - Some (Unboxed_float Pfloat32) + Some (Unboxed_float Boxed_float32) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 -> - Some (Unboxed_integer Pint32) + Some (Unboxed_integer Boxed_int32) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 -> - Some (Unboxed_integer Pint64) + Some (Unboxed_integer Boxed_int64) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint -> - Some (Unboxed_integer Pnativeint) + Some (Unboxed_integer Boxed_nativeint) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int8x16 -> - Some (Unboxed_vector Pvec128) + Some (Unboxed_vector Boxed_vec128) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int16x8 -> - Some (Unboxed_vector Pvec128) + Some (Unboxed_vector Boxed_vec128) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32x4 -> - Some (Unboxed_vector Pvec128) + Some (Unboxed_vector Boxed_vec128) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64x2 -> - Some (Unboxed_vector Pvec128) + Some (Unboxed_vector Boxed_vec128) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float32x4 -> - Some (Unboxed_vector Pvec128) + Some (Unboxed_vector Boxed_vec128) | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float64x2 -> - Some (Unboxed_vector Pvec128) + Some (Unboxed_vector Boxed_vec128) | _ -> None diff --git a/typing/typedtree.mli b/typing/typedtree.mli index faa5efea45d..c4a2f2a52e6 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -84,20 +84,21 @@ module Unique_barrier : sig val print : Format.formatter -> t -> unit end -(** A unique use annotates accesses to an allocation. - In the type checker we ensure that - actual_mode <= expected_mode - unique_use.uniqueness == expected_mode.uniqueness - unique_use.linearity == actual_mode.linearity - That is, if the user expects an access to be unique, - both the actual_mode and unique_use are also unique. - In the uniqueness analysis, we check whether a particular access - is the only lexically use in its branch and if not, we set - aliased /\ many <= unique_use - This means that an allocation's actual_mode can be unique, - while a particular access of the allocation is aliased. - Furthermore, if there is more than one access to an allocation, - its actual_mode will have to be many. *) +(** The uniqueness/linearity of a usage (such as [Pexp_ident]) inferred by the + type checker. It is derived during type checking as follows: + [unique_use.uniqueness = expected_mode.uniqueness] + [unique_use.linearity = actual_mode.linearity] + for example, [let x = P in f x], [(Pexp_ident x).unique_use] will contain + the expected [uniqueness] of [f]'s parameter, and [linearity] of [P]. + [uniqueness_analysis.ml] will _lexically_ infer the uniqueness/linearity of + a usage and compare against [unique_use]. Following the example, if there + are two [f x], the uniqueness analysis will perform the following for + [unique_use] of both [Pexp_ident x]: + [unique_use.uniqueness >= aliased] + [unique_use.linearity <= many] + That is, the consumers of the values (that is [f]) must not require its + parameter to be [unique], and the value itself (that is [P]) must be [many]. +*) type unique_use = Mode.Uniqueness.r * Mode.Linearity.l val print_unique_use : Format.formatter -> unique_use -> unit diff --git a/typing/typeopt.ml b/typing/typeopt.ml index 668ecd15708..917c80b6650 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -179,12 +179,12 @@ let classify ~classify_product env loc ty sort : _ classification = | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ | Tunboxed_tuple _ -> assert false end - | Base Float64 -> Unboxed_float Pfloat64 - | Base Float32 -> Unboxed_float Pfloat32 - | Base Bits32 -> Unboxed_int Pint32 - | Base Bits64 -> Unboxed_int Pint64 - | Base Vec128 -> Unboxed_vector Pvec128 - | Base Word -> Unboxed_int Pnativeint + | Base Float64 -> Unboxed_float Unboxed_float64 + | Base Float32 -> Unboxed_float Unboxed_float32 + | Base Bits32 -> Unboxed_int Unboxed_int32 + | Base Bits64 -> Unboxed_int Unboxed_int64 + | Base Vec128 -> Unboxed_vector Unboxed_vec128 + | Base Word -> Unboxed_int Unboxed_nativeint | Base Void as c -> raise (Error (loc, Unsupported_sort c)) | Product c -> Product (classify_product ty c) @@ -210,11 +210,11 @@ let rec ignorable_product_array_kind loc sorts = and sort_to_ignorable_product_element_kind loc (s : Jkind.Sort.Const.t) = match s with | Base Value -> Pint_ignorable - | Base Float64 -> Punboxedfloat_ignorable Pfloat64 - | Base Float32 -> Punboxedfloat_ignorable Pfloat32 - | Base Bits32 -> Punboxedint_ignorable Pint32 - | Base Bits64 -> Punboxedint_ignorable Pint64 - | Base Word -> Punboxedint_ignorable Pnativeint + | Base Float64 -> Punboxedfloat_ignorable Unboxed_float64 + | Base Float32 -> Punboxedfloat_ignorable Unboxed_float32 + | Base Bits32 -> Punboxedint_ignorable Unboxed_int32 + | Base Bits64 -> Punboxedint_ignorable Unboxed_int64 + | Base Word -> Punboxedint_ignorable Unboxed_nativeint | Base Vec128 -> raise (Error (loc, Unsupported_vector_in_product_array)) | Base Void as c -> raise (Error (loc, Unsupported_sort c)) | Product sorts -> Pproduct_ignorable (ignorable_product_array_kind loc sorts) @@ -467,27 +467,27 @@ let rec value_kind env ~loc ~visited ~depth ~num_nodes_visited ty | Tconstr(p, _, _) when Path.same p Predef.path_int16 -> num_nodes_visited, mk_nn Pintval | Tconstr(p, _, _) when Path.same p Predef.path_float -> - num_nodes_visited, mk_nn (Pboxedfloatval Pfloat64) + num_nodes_visited, mk_nn (Pboxedfloatval Boxed_float64) | Tconstr(p, _, _) when Path.same p Predef.path_float32 -> - num_nodes_visited, mk_nn (Pboxedfloatval Pfloat32) + num_nodes_visited, mk_nn (Pboxedfloatval Boxed_float32) | Tconstr(p, _, _) when Path.same p Predef.path_int32 -> - num_nodes_visited, mk_nn (Pboxedintval Pint32) + num_nodes_visited, mk_nn (Pboxedintval Boxed_int32) | Tconstr(p, _, _) when Path.same p Predef.path_int64 -> - num_nodes_visited, mk_nn (Pboxedintval Pint64) + num_nodes_visited, mk_nn (Pboxedintval Boxed_int64) | Tconstr(p, _, _) when Path.same p Predef.path_nativeint -> - num_nodes_visited, mk_nn (Pboxedintval Pnativeint) + num_nodes_visited, mk_nn (Pboxedintval Boxed_nativeint) | Tconstr(p, _, _) when Path.same p Predef.path_int8x16 -> - num_nodes_visited, mk_nn (Pboxedvectorval Pvec128) + num_nodes_visited, mk_nn (Pboxedvectorval Boxed_vec128) | Tconstr(p, _, _) when Path.same p Predef.path_int16x8 -> - num_nodes_visited, mk_nn (Pboxedvectorval Pvec128) + num_nodes_visited, mk_nn (Pboxedvectorval Boxed_vec128) | Tconstr(p, _, _) when Path.same p Predef.path_int32x4 -> - num_nodes_visited, mk_nn (Pboxedvectorval Pvec128) + num_nodes_visited, mk_nn (Pboxedvectorval Boxed_vec128) | Tconstr(p, _, _) when Path.same p Predef.path_int64x2 -> - num_nodes_visited, mk_nn (Pboxedvectorval Pvec128) + num_nodes_visited, mk_nn (Pboxedvectorval Boxed_vec128) | Tconstr(p, _, _) when Path.same p Predef.path_float32x4 -> - num_nodes_visited, mk_nn (Pboxedvectorval Pvec128) + num_nodes_visited, mk_nn (Pboxedvectorval Boxed_vec128) | Tconstr(p, _, _) when Path.same p Predef.path_float64x2 -> - num_nodes_visited, mk_nn (Pboxedvectorval Pvec128) + num_nodes_visited, mk_nn (Pboxedvectorval Boxed_vec128) | Tconstr(p, _, _) when (Path.same p Predef.path_array || Path.same p Predef.path_floatarray) -> @@ -732,7 +732,7 @@ and value_kind_record env ~loc ~visited ~depth ~num_nodes_visited optimization. *) match rep with | Record_float | Record_ufloat -> - num_nodes_visited, mk_nn (Pboxedfloatval Pfloat64) + num_nodes_visited, mk_nn (Pboxedfloatval Boxed_float64) | Record_inlined _ | Record_boxed _ -> value_kind env ~loc ~visited ~depth ~num_nodes_visited label.ld_type @@ -797,19 +797,19 @@ let[@inline always] rec layout_of_const_sort_generic ~value_kind ~error : Jkind.Sort.Const.t -> _ = function | Base Value -> Lambda.Pvalue (Lazy.force value_kind) | Base Float64 when Language_extension.(is_at_least Layouts Stable) -> - Lambda.Punboxed_float Pfloat64 + Lambda.Punboxed_float Unboxed_float64 | Base Word when Language_extension.(is_at_least Layouts Stable) -> - Lambda.Punboxed_int Pnativeint + Lambda.Punboxed_int Unboxed_nativeint | Base Bits32 when Language_extension.(is_at_least Layouts Stable) -> - Lambda.Punboxed_int Pint32 + Lambda.Punboxed_int Unboxed_int32 | Base Bits64 when Language_extension.(is_at_least Layouts Stable) -> - Lambda.Punboxed_int Pint64 + Lambda.Punboxed_int Unboxed_int64 | Base Float32 when Language_extension.(is_at_least Layouts Stable) && Language_extension.(is_enabled Small_numbers) -> - Lambda.Punboxed_float Pfloat32 + Lambda.Punboxed_float Unboxed_float32 | Base Vec128 when Language_extension.(is_at_least Layouts Stable) && Language_extension.(is_at_least SIMD Stable) -> - Lambda.Punboxed_vector Pvec128 + Lambda.Punboxed_vector Unboxed_vec128 | Product consts when Language_extension.(is_at_least Layouts Stable) -> (* CR layouts v7.1: assess whether it is important for performance to support deep value_kinds here *) @@ -943,11 +943,11 @@ let rec layout_union l1 l2 = | Pvalue layout1, Pvalue layout2 -> Pvalue (value_kind_union layout1 layout2) | Punboxed_float f1, Punboxed_float f2 -> - if equal_boxed_float f1 f2 then l1 else Ptop + if Primitive.equal_unboxed_float f1 f2 then l1 else Ptop | Punboxed_int bi1, Punboxed_int bi2 -> - if equal_boxed_integer bi1 bi2 then l1 else Ptop + if Primitive.equal_unboxed_integer bi1 bi2 then l1 else Ptop | Punboxed_vector vi1, Punboxed_vector vi2 -> - if equal_boxed_vector vi1 vi2 then l1 else Ptop + if Primitive.equal_unboxed_vector vi1 vi2 then l1 else Ptop | Punboxed_product layouts1, Punboxed_product layouts2 -> if List.compare_lengths layouts1 layouts2 <> 0 then Ptop else Punboxed_product (List.map2 layout_union layouts1 layouts2) diff --git a/typing/uniqueness_analysis.ml b/typing/uniqueness_analysis.ml index 39a41173c71..26ba92da0ed 100644 --- a/typing/uniqueness_analysis.ml +++ b/typing/uniqueness_analysis.ml @@ -114,7 +114,7 @@ end = struct let mark_multi_use l = let force_one ((uni, lin), occ) = (* values being multi-used means two things: - - the expected mode must be higher than [aliased] + - the expected mode must be higher than Aliased - the access mode must be lower than [many] *) match Linearity.submode lin Linearity.many with | Error _ -> Error { occ; axis = Linearity } @@ -227,8 +227,10 @@ module Aliased : sig type t type reason = - | Forced (** aliased because forced *) - | Lazy (** aliased because it is the argument of lazy forcing *) + | Forced (** aliased because forced due to multiple usage *) + | Lazy (** aliased because of a lazy pattern *) + | Array (** aliased because of an array pattern *) + | Constant (** aliased because of an constant pattern *) | Lifted of Maybe_aliased.access (** aliased because lifted from implicit borrowing, carries the original access *) @@ -246,6 +248,8 @@ end = struct type reason = | Forced | Lazy + | Array + | Constant | Lifted of Maybe_aliased.access type t = Occurrence.t * reason @@ -261,6 +265,8 @@ end = struct let print_reason ppf = function | Forced -> fprintf ppf "Forced" | Lazy -> fprintf ppf "Lazy" + | Array -> fprintf ppf "Array" + | Constant -> fprintf ppf "Constant" | Lifted ma -> fprintf ppf "Lifted(%a)" Maybe_aliased.print_access ma in fprintf ppf "(%a,%a)" Occurrence.print occ print_reason reason @@ -360,56 +366,82 @@ module Usage : sig val print : Format.formatter -> t -> unit end = struct - (* We have Unused (top) > Borrowed > Aliased > Unique > Error (bot). - - - Unused means unused - - Borrowed means read-only access confined to a region - - Aliased means read-only access that may escape a region. For example, - storing the value in a cell that can be accessed later. - - Unique means accessing the value as if it's the only pointer. Example - includes overwriting. - - Error means error happens when composing usage. - - Some observations: - - It is sound to relax mode towards Error. It grants the access more - "capability" and usually helps performance. - For example, relaxing borrowed to aliased allows code motion of - projections. Relaxing aliased to unique allows in-place update. - - An example of the relaxing borrowed to aliased: - - let x = r.a in - (a lot of codes) - x - - In first line, r.memory_address is accessed as borrowed. But if we weaken - it to aliased and it still mode checks, that means - - there is no "unique" access in the "a lot of codes" - - or equivalently, that r.memory_address stays unchanged and safe to read - - and as a result, we can delay the projection at `x`. - - The downside of relaxing is the loss of completeness: if we relax too - much the program will fail type check. In the extreme case we relax it to - Error which fails type check outright (and extremely sound, hehe). - - - The purpose of this uniqueness analysis is to figure out the most relaxed - mode for each use, such that we get the best performance, while still - type-check. Currently there are really only two choices worth figuring out, - Namely - - borrowed or aliased? - - aliased or unique? - - As a result, instead of having full-range inference, we only care about the + (* [Usage.t] describes the extend to which a value is used. + + - Unused means unused + - Borrowed means read-only usage confined to a region + - Aliased means read-only usage that may escape a region. For example, + storing the value in a cell that can be used later. + - Unique means using the value as if it's the only usage. Example includes + overwriting. + - Error means error happens when composing usage. + + And we have Unused (top) > Borrowed > Aliased > Unique > Error (bot). Lower + usage is stronger. + + A program can use a value multiple times. We take a hierarchical view of the + usages. At the bottom are the usages caused by "use sites" (such as + [Pexp_ident]). Those usages are then composed together by [par], [seq], + etc., reflecting the lexical structure. Certain composition of certain + usages (such as [seq Unique Unique]) is illegal and leads to Error. + + The uniqueness analysis is to infer the strongest usage that can be granted + to each use site. To do that, each use site will be granted a usage that is + unconstrained, which gets constrained during composition with other usages. + For example, [seq u1 u2] will constrain both [u1] and [u2] to be weaker than + Unique. + + For each use site, the lexically-inferred usage is eagerly compared against + the typing-inferred usage (e.g., [unique_use] in [Pexp_ident]). Type errors + are raised if that fails. + + For example: + [ + let x = .. in + use_as_unique x; + use_as_unique x + ] + + type checking would infer both [Pexp_ident x] use sites to be Unique, but + uniqueness analysis would infer both to be strictly weaker than Unique. + Type error is raised. + + It is sound for the analysis to infer a use site to have a weaker usage, + which might result in false mode errors. It is useful for the analysis to + infer a use site to have a stronger usage, as that usually helps with + performance. For example, forcing Borrowed to Aliased allows code motion of + projections. Forcing Aliased to Unique allows in-place update. + + An example of the relaxing Borrowed to Aliased: + + let x = r.a in + (a lot of codes) + x + + In first line, r.memory_address is accessed as Borrowed. But if we + force it to Aliased and it still mode checks, that means + - there is no Unique access in the "a lot of codes" + - or equivalently, that [r.memory_address] stays unchanged and safe to + read + As a result, we can delay the projection at [x]. + + On the other hand, the analysis shouldn't grant to a use site a too strong + usage, as that might be unsound. + + Currently there are only two choices worth figuring out: + - Borrowed or Aliased? + - Aliased or Unique? + + Therefore, instead of having full-range inference, we only care about the following ranges: - - unused - - borrowed (Currently not useful, because we don't have explicit borrowing) - - borrowed or aliased - - aliased - - aliased or unique - - error + - Unused + - Borrowed (Currently not useful, because we don't have explicit borrowing) + - Borrowed or Aliased + - Aliased + - Aliased or Unique + - Error - error is represented as exception which is just easier. + Error is represented as exception for simplicity. We could additionally include a zero for our semiring that sits above unused. However, this would have to suppress errors which prevents us from representing @@ -1819,82 +1851,121 @@ let rec pattern_match_tuple pat values = let ext, uf' = pattern_match_single pat paths in ext, UF.seq uf uf' -and pattern_match_single pat paths : Ienv.Extension.t * UF.t = +(** This function ensures the soundness of pattern-matching in the presence + of destructive updates on the memory that was matched on. + If the pattern-match reads from the underlying memory, we need to ensure + either that the memory access is not pushed down or that no destructive + updates can be performed on the memory. + Reads from the underlying memory occur when the pattern has to inspect the + tag or content of the memory to decide whether a branch should be taken + as well as when binding the contents of a subpattern to a name. + + Each pattern falls into one of three cases: + - If we do not read from the underlying memory, + we do not have to take an action. + - We can allow destructive updates later on by borrowing the + memory address. Then we have to protect the read from getting + pushed down using a unique barrier. + - We can disallow any destructive updates following the read + by consuming the memory address as aliased. + + [pattern_match_single] recurs down the structure of the pattern, + calling [pattern_match_barrier] at each step, so [pattern_match_barrier] + itself does not need to recur into subpatterns. *) +and pattern_match_barrier pat paths : UF.t = let loc = pat.pat_loc in let occ = Occurrence.mk loc in - (* To read from the allocation, we need to borrow its memory cell - and set the unique_barrier. However, we do not read in every case, - since the user might want use a wildcard for already-consumed data. *) - let no_borrow_memory_address () = - Unique_barrier.enable pat.pat_unique_barrier; - ignore (Unique_barrier.resolve pat.pat_unique_barrier) + Unique_barrier.enable pat.pat_unique_barrier; + let no_memory_access () = + ignore (Unique_barrier.resolve pat.pat_unique_barrier); + UF.unused in let borrow_memory_address () = - Unique_barrier.enable pat.pat_unique_barrier; Paths.mark_implicit_borrow_memory_address occ (Read pat.pat_unique_barrier) paths in + let consume_memory_address reason = + ignore (Unique_barrier.resolve pat.pat_unique_barrier); + Paths.mark_aliased occ reason paths + in match pat.pat_desc with - | Tpat_or (pat0, pat1, _) -> - no_borrow_memory_address (); - let ext0, uf0 = pattern_match_single pat0 paths in - let ext1, uf1 = pattern_match_single pat1 paths in - Ienv.Extension.disjunct ext0 ext1, UF.choose uf0 uf1 - | Tpat_any -> - no_borrow_memory_address (); - Ienv.Extension.empty, UF.unused - | Tpat_var (id, _, _, _) -> - no_borrow_memory_address (); - Ienv.Extension.singleton id paths, UF.unused - | Tpat_alias (pat', id, _, _, _) -> - no_borrow_memory_address (); - let ext0 = Ienv.Extension.singleton id paths in - let ext1, uf = pattern_match_single pat' paths in - Ienv.Extension.conjunct ext0 ext1, uf + | Tpat_or _ -> no_memory_access () + | Tpat_any -> no_memory_access () + | Tpat_var _ -> no_memory_access () + | Tpat_alias _ -> no_memory_access () | Tpat_constant _ -> - let uf_read = borrow_memory_address () in - Ienv.Extension.empty, uf_read - | Tpat_construct (lbl, cd, pats, _) -> - let uf_tag = - Paths.learn_tag { tag = cd.cstr_tag; name_for_error = lbl } paths - in - let uf_read = borrow_memory_address () in - let pats_args = List.combine pats cd.cstr_args in - let ext, uf_pats = - List.mapi - (fun i (pat, { Types.ca_modalities = gf; _ }) -> - let name = Longident.last lbl.txt in - let paths = Paths.construct_field gf name i paths in - pattern_match_single pat paths) - pats_args - |> conjuncts_pattern_match - in - ext, UF.pars [uf_tag; uf_read; uf_pats] - | Tpat_variant (lbl, arg, _) -> - let uf_read = borrow_memory_address () in - let ext, uf_arg = + (* This is necessary since we can not guarantee that + the reads of constants in the pattern-matching code + are never pushed down. + CR uniqueness: We can probably use [borrow_memory_address] + for certain constants (eg. integers) here. *) + consume_memory_address Constant + | Tpat_construct _ -> borrow_memory_address () + | Tpat_variant _ -> borrow_memory_address () + | Tpat_record _ -> borrow_memory_address () + | Tpat_array _ -> + (* This is necessary since we do not yet guarantee that + the reads of arrays in the pattern-matching code + are never pushed down. + CR uniqueness: we should add a unique barrier to array reads + and change this to use [borrow_memory_address] as well. *) + consume_memory_address Array + | Tpat_lazy _ -> + (* Lazy patterns consume their memory anyway since + forcing a lazy expression is like calling a nullary-function *) + consume_memory_address Lazy + | Tpat_tuple _ -> borrow_memory_address () + | Tpat_unboxed_tuple _ -> + (* unboxed tuples are not allocations *) + no_memory_access () + | Tpat_record_unboxed_product _ -> + (* unboxed records are not allocations *) + no_memory_access () + +and pattern_match_single pat paths : Ienv.Extension.t * UF.t = + let uf_read = pattern_match_barrier pat paths in + let ext, uf_pats = + match pat.pat_desc with + | Tpat_or (pat0, pat1, _) -> + let ext0, uf0 = pattern_match_single pat0 paths in + let ext1, uf1 = pattern_match_single pat1 paths in + Ienv.Extension.disjunct ext0 ext1, UF.choose uf0 uf1 + | Tpat_any -> Ienv.Extension.empty, UF.unused + | Tpat_var (id, _, _, _) -> Ienv.Extension.singleton id paths, UF.unused + | Tpat_alias (pat', id, _, _, _) -> + let ext0 = Ienv.Extension.singleton id paths in + let ext1, uf = pattern_match_single pat' paths in + Ienv.Extension.conjunct ext0 ext1, uf + | Tpat_constant _ -> Ienv.Extension.empty, UF.unused + | Tpat_construct (lbl, cd, pats, _) -> + let uf_tag = + Paths.learn_tag { tag = cd.cstr_tag; name_for_error = lbl } paths + in + let pats_args = List.combine pats cd.cstr_args in + let ext, uf_pats = + List.mapi + (fun i (pat, { Types.ca_modalities = gf; _ }) -> + let name = Longident.last lbl.txt in + let paths = Paths.construct_field gf name i paths in + pattern_match_single pat paths) + pats_args + |> conjuncts_pattern_match + in + ext, UF.par uf_tag uf_pats + | Tpat_variant (lbl, arg, _) -> ( match arg with | Some arg -> let paths = Paths.variant_field lbl paths in pattern_match_single arg paths - | None -> Ienv.Extension.empty, UF.unused - in - ext, UF.pars [uf_read; uf_arg] - | Tpat_record (pats, _) -> - let uf_read = borrow_memory_address () in - let ext, uf_pats = + | None -> Ienv.Extension.empty, UF.unused) + | Tpat_record (pats, _) -> List.map (fun (_, l, pat) -> let paths = Paths.record_field l.lbl_modalities l.lbl_name paths in pattern_match_single pat paths) pats |> conjuncts_pattern_match - in - ext, UF.par uf_read uf_pats - | Tpat_record_unboxed_product (pats, _) -> - (* No borrow since unboxed data can not be consumed. *) - no_borrow_memory_address (); - let ext, uf_pats = + | Tpat_record_unboxed_product (pats, _) -> List.map (fun (_, l, pat) -> let paths = @@ -1903,50 +1974,37 @@ and pattern_match_single pat paths : Ienv.Extension.t * UF.t = pattern_match_single pat paths) pats |> conjuncts_pattern_match - in - ext, uf_pats - | Tpat_array (mut, _, pats) -> - let uf_read = borrow_memory_address () in - let ext, uf_pats = + | Tpat_array (mut, _, pats) -> List.mapi (fun idx pat -> let paths = Paths.array_index mut idx paths in pattern_match_single pat paths) pats |> conjuncts_pattern_match - in - ext, UF.par uf_read uf_pats - | Tpat_lazy arg -> - no_borrow_memory_address (); - (* forced below: *) - (* forcing a lazy expression is like calling a nullary-function *) - let uf_force = Paths.mark_aliased occ Lazy paths in - let paths = Paths.fresh () in - let ext, uf_arg = pattern_match_single arg paths in - ext, UF.par uf_force uf_arg - | Tpat_tuple args -> - let uf_read = borrow_memory_address () in - let ext, uf_args = + | Tpat_lazy arg -> + (* forcing a lazy expression is like calling a nullary-function *) + let loc = pat.pat_loc in + let occ = Occurrence.mk loc in + let uf_force = Paths.mark_aliased occ Lazy paths in + let ext, uf_arg = pattern_match_single arg (Paths.fresh ()) in + ext, UF.par uf_force uf_arg + | Tpat_tuple args -> List.mapi (fun i (_, arg) -> let paths = Paths.tuple_field i paths in pattern_match_single arg paths) args |> conjuncts_pattern_match - in - ext, UF.par uf_read uf_args - | Tpat_unboxed_tuple args -> - (* No borrow since unboxed data can not be consumed. *) - no_borrow_memory_address (); - let ext, uf_args = + | Tpat_unboxed_tuple args -> + (* No borrow since unboxed data can not be consumed. *) List.mapi (fun i (_, arg, _) -> let paths = Paths.tuple_field i paths in pattern_match_single arg paths) args |> conjuncts_pattern_match - in - ext, uf_args + in + ext, UF.par uf_read uf_pats let pattern_match pat = function | Match_tuple values -> pattern_match_tuple pat values @@ -2535,7 +2593,10 @@ let report_multi_use inner first_is_of_second = Maybe_aliased.string_of_access (Maybe_aliased.extract_access t) | Usage.Aliased t -> ( match Aliased.reason t with - | Forced | Lazy -> "used" + | Forced -> "used" + | Lazy -> "used in a lazy pattern" + | Array -> "used in an array pattern" + | Constant -> "used in a constant pattern" | Lifted access -> Maybe_aliased.string_of_access access ^ " in a closure that might be called later")