diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index bae0b5cdb81..1e89062920e 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -78,14 +78,14 @@ jobs: config: --enable-middle-end=flambda2 --disable-warn-error os: macos-latest - - name: flambda2_macos_arm64_irc - config: --enable-middle-end=flambda2 --disable-warn-error + - name: flambda2_macos_arm64_runtime5_irc + config: --enable-middle-end=flambda2 --enable-runtime5 --disable-warn-error os: macos-latest build_ocamlparam: '_,w=-46,regalloc=irc' ocamlparam: '_,w=-46,regalloc=irc' - - name: flambda2_macos_arm64_ls - config: --enable-middle-end=flambda2 --disable-warn-error + - name: flambda2_macos_arm64_runtime5_ls + config: --enable-middle-end=flambda2 --enable-runtime5 --disable-warn-error os: macos-latest build_ocamlparam: '_,w=-46,regalloc=ls' ocamlparam: '_,w=-46,regalloc=ls' @@ -282,22 +282,22 @@ jobs: run: | PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH make check_all_arches - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: ${{ failure() }} && matrix.os != 'macos-latest' with: - name: cores + name: cores-${{ github.sha }} path: /cores - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: ${{ failure() }} && matrix.os != 'macos-latest' with: - name: _build + name: _build-${{ github.sha }} path: $GITHUB_WORKSPACE/_build - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: ${{ failure() }} && matrix.os != 'macos-latest' with: - name: _runtest + name: _runtest-${{ github.sha }} path: $GITHUB_WORKSPACE/_runtest concurrency: diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 3fe5f2edc8c..537af760eea 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -89,8 +89,8 @@ jobs: # BUILD_OCAMLPARAM: ${{ matrix.ocamlparam }} # # - name: Publish coverage report -# uses: actions/upload-artifact@v3 +# uses: actions/upload-artifact@v4 # with: -# name: coverage +# name: coverage-${{ github.sha }} # path: flambda_backend/_coverage/** # diff --git a/.github/workflows/ocamlformat.yml b/.github/workflows/ocamlformat.yml index 6436fb783b9..e4e2a479d95 100644 --- a/.github/workflows/ocamlformat.yml +++ b/.github/workflows/ocamlformat.yml @@ -21,7 +21,7 @@ jobs: path: 'flambda_backend' - name: Setup OCaml ${{ matrix.ocaml-compiler }} - uses: ocaml/setup-ocaml@v2 + uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: ${{ matrix.ocaml-compiler }} diff --git a/Makefile b/Makefile index 324f3249b88..13e2765b885 100644 --- a/Makefile +++ b/Makefile @@ -87,7 +87,7 @@ promote: .PHONY: fmt fmt: - ocamlformat -i $$(find . \( -name "*.ml" -or -name "*.mli" \)) + find . \( -name "*.ml" -or -name "*.mli" \) | xargs -P $$(nproc 2>/dev/null || echo 1) -n 20 ocamlformat -i .PHONY: check-fmt check-fmt: diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index f3ced698ac2..96bcd8c4444 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -349,6 +349,16 @@ let sourcefile_for_dwarf ~named_startup_file filename = if named_startup_file then filename else ".startup" +let emit_ocamlrunparam ~ppf_dump = + Asmgen.compile_phrase ~ppf_dump + (Cmm.Cdata [ + Cmm.Cdefine_symbol { + sym_name = "caml_ocamlrunparam"; + sym_global = Global + }; + Cmm.Cstring (!Clflags.ocamlrunparam ^ "\000") + ]) + let make_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units cached_gen = Location.input_name := "caml_startup"; (* set name of "current" input *) let startup_comp_unit = @@ -361,6 +371,7 @@ let make_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units cached_g let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in let name_list = List.flatten (List.map (fun u -> u.defines) units) in + emit_ocamlrunparam ~ppf_dump; List.iter compile_phrase (Cmm_helpers.entry_point name_list); List.iter compile_phrase (* Emit the GC roots table, for dynlink. *) @@ -414,6 +425,7 @@ let make_shared_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units = Emitaux.Dwarf_helpers.init ~disable_dwarf:(not !Dwarf_flags.dwarf_for_startup_file) ~sourcefile:sourcefile_for_dwarf; Emit.begin_assembly unix; + emit_ocamlrunparam ~ppf_dump; List.iter compile_phrase (Cmm_helpers.emit_gc_roots_table ~symbols:[] (Generic_fns.compile ~shared:true genfns)); diff --git a/backend/amd64/CSE.ml b/backend/amd64/CSE.ml index 4d3098f77a0..e0692a7f735 100644 --- a/backend/amd64/CSE.ml +++ b/backend/amd64/CSE.ml @@ -1,4 +1,3 @@ -# 2 "backend/amd64/CSE.ml" (**************************************************************************) (* *) (* OCaml *) @@ -21,6 +20,12 @@ open Arch open Mach open CSE_utils +let of_simd_class (cl : Simd.operation_class) = + match cl with + | Pure -> Op_pure + | Load { is_mutable = true } -> Op_load Mutable + | Load { is_mutable = false } -> Op_load Immutable + class cse = object inherit CSEgen.cse_generic as super @@ -37,9 +42,9 @@ method! class_of_operation op = | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence -> Op_other | Isimd op -> - begin match Simd.class_of_operation op with - | Pure -> Op_pure - end + of_simd_class (Simd.class_of_operation op) + | Isimd_mem (op,_addr) -> + of_simd_class (Simd.Mem.class_of_operation op) | Ipause | Icldemote _ | Iprefetch _ -> Op_other @@ -81,9 +86,9 @@ class cfg_cse = object | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence -> Op_other | Isimd op -> - begin match Simd.class_of_operation op with - | Pure -> Op_pure - end + of_simd_class (Simd.class_of_operation op) + | Isimd_mem (op,_addr) -> + of_simd_class (Simd.Mem.class_of_operation op) | Ipause | Icldemote _ | Iprefetch _ -> Op_other diff --git a/backend/amd64/arch.ml b/backend/amd64/arch.ml index 8098cbf7158..66c3566a4da 100644 --- a/backend/amd64/arch.ml +++ b/backend/amd64/arch.ml @@ -1,4 +1,3 @@ -# 2 "backend/amd64/arch.ml" (**************************************************************************) (* *) (* OCaml *) @@ -153,6 +152,9 @@ type specific_operation = | Imfence (* memory fence *) | Ipause (* hint for spin-wait loops *) | Isimd of Simd.operation (* SIMD instruction set operations *) + | Isimd_mem of Simd.Mem.operation * addressing_mode + (* SIMD instruction set operations + with memory args *) | Icldemote of addressing_mode (* hint to demote a cacheline to L3 *) | Iprefetch of (* memory prefetching hint *) { is_write: bool; @@ -273,6 +275,8 @@ let print_specific_operation printreg op ppf arg = fprintf ppf "rdpmc %a" printreg arg.(0) | Isimd simd -> Simd.print_operation printreg simd ppf arg + | Isimd_mem (simd, addr) -> + Simd.Mem.print_operation printreg (print_addressing printreg addr) simd ppf arg | Ipause -> fprintf ppf "pause" | Icldemote _ -> @@ -299,13 +303,14 @@ let operation_is_pure = function | Istore_int (_, _, _) | Ioffset_loc (_, _) | Icldemote _ | Iprefetch _ -> false | Isimd op -> Simd.is_pure op + | Isimd_mem (op, _addr) -> Simd.Mem.is_pure op (* Specific operations that can raise *) (* Keep in sync with [Vectorize_specific] *) let operation_can_raise = function | Ilea _ | Ibswap _ | Isextend32 | Izextend32 | Ifloatarithmem _ - | Irdtsc | Irdpmc | Ipause | Isimd _ + | Irdtsc | Irdpmc | Ipause | Isimd _ | Isimd_mem _ | Ilfence | Isfence | Imfence | Istore_int (_, _, _) | Ioffset_loc (_, _) | Icldemote _ | Iprefetch _ -> false @@ -314,7 +319,7 @@ let operation_can_raise = function let operation_allocates = function | Ilea _ | Ibswap _ | Isextend32 | Izextend32 | Ifloatarithmem _ - | Irdtsc | Irdpmc | Ipause | Isimd _ + | Irdtsc | Irdpmc | Ipause | Isimd _ | Isimd_mem _ | Ilfence | Isfence | Imfence | Istore_int (_, _, _) | Ioffset_loc (_, _) | Icldemote _ | Iprefetch _ -> false @@ -405,9 +410,11 @@ let equal_specific_operation left right = && equal_addressing_mode left_addr right_addr | Isimd l, Isimd r -> Simd.equal_operation l r + | Isimd_mem (l,al), Isimd_mem (r,ar) -> + Simd.Mem.equal_operation l r && equal_addressing_mode al ar | (Ilea _ | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ | Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence | - Ipause | Isimd _ | Icldemote _ | Iprefetch _), _ -> + Ipause | Isimd _ | Isimd_mem _ | Icldemote _ | Iprefetch _), _ -> false (* addressing mode functions *) @@ -512,7 +519,9 @@ let isomorphic_specific_operation op1 op2 = && equal_addressing_mode_without_displ left_addr right_addr | Isimd l, Isimd r -> Simd.equal_operation l r + | Isimd_mem (l,al), Isimd_mem (r,ar) -> + Simd.Mem.equal_operation l r && equal_addressing_mode_without_displ al ar | (Ilea _ | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ | Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence | - Ipause | Isimd _ | Icldemote _ | Iprefetch _), _ -> + Ipause | Isimd _ | Isimd_mem _ | Icldemote _ | Iprefetch _), _ -> false diff --git a/backend/amd64/arch.mli b/backend/amd64/arch.mli index 91e3bbf348a..539f0e8243d 100644 --- a/backend/amd64/arch.mli +++ b/backend/amd64/arch.mli @@ -1,4 +1,3 @@ -# 2 "asmcomp/amd64/arch.mli" (**************************************************************************) (* *) (* OCaml *) @@ -86,6 +85,9 @@ type specific_operation = | Imfence (* memory fence *) | Ipause (* hint for spin-wait loops *) | Isimd of Simd.operation (* SIMD instruction set operations *) + | Isimd_mem of Simd.Mem.operation * addressing_mode + (* SIMD instruction set operations + with memory args *) | Icldemote of addressing_mode (* hint to demote a cacheline to L3 *) | Iprefetch of (* memory prefetching hint *) { is_write: bool; diff --git a/backend/amd64/cfg_selection.ml b/backend/amd64/cfg_selection.ml index 6f7bfbf3097..db7c2c65548 100644 --- a/backend/amd64/cfg_selection.ml +++ b/backend/amd64/cfg_selection.ml @@ -32,12 +32,17 @@ let pseudoregs_for_operation op arg res = | Intop (Iadd | Isub | Imul | Iand | Ior | Ixor) | Floatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> [| res.(0); arg.(1) |], res - | Intop_atomic { op = Compare_and_swap; size = _; addr = _ } -> + | Intop_atomic { op = Compare_set; size = _; addr = _ } -> (* first arg must be rax *) let arg = Array.copy arg in arg.(0) <- rax; arg, res - | Intop_atomic { op = Fetch_and_add; size = _; addr = _ } -> + | Intop_atomic { op = Compare_exchange; size = _; addr = _ } -> + (* first arg must be rax, res.(0) must be rax. *) + let arg = Array.copy arg in + arg.(0) <- rax; + arg, [| rax |] + | Intop_atomic { op = Exchange | Fetch_and_add; size = _; addr = _ } -> (* first arg must be the same as res.(0) *) let arg = Array.copy arg in arg.(0) <- res.(0); @@ -86,7 +91,14 @@ let pseudoregs_for_operation op arg res = edx (high) and eax (low). Make it simple and force the argument in rcx, and rax and rdx clobbered *) [| rcx |], res - | Specific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res + | Specific (Isimd op) -> + Simd_selection.pseudoregs_for_operation + (Simd_proc.register_behavior op) + arg res + | Specific (Isimd_mem (op, _addr)) -> + Simd_selection.pseudoregs_for_operation + (Simd_proc.Mem.register_behavior op) + arg res | Csel _ -> (* last arg must be the same as res.(0) *) let len = Array.length arg in @@ -94,6 +106,7 @@ let pseudoregs_for_operation op arg res = arg.(len - 1) <- res.(0); arg, res (* Other instructions are regular *) + | Intop_atomic { op = Add | Sub | Land | Lor | Lxor; _ } | Intop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) | Intop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) | Specific diff --git a/backend/amd64/emit.mlp b/backend/amd64/emit.ml similarity index 96% rename from backend/amd64/emit.mlp rename to backend/amd64/emit.ml index fd09de7040f..f01cde2115d 100644 --- a/backend/amd64/emit.mlp +++ b/backend/amd64/emit.ml @@ -1,4 +1,3 @@ -# 2 "backend/amd64/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -54,7 +53,7 @@ let float_reg_name = Array.init 16 (fun i -> XMM i) let register_name typ r = match (typ : machtype_component) with | Int | Val | Addr -> Reg64 (int_reg_name.(r)) - | Float | Float32 | Vec128 -> Regf (float_reg_name.(r - 100)) + | Float | Float32 | Vec128 | Valx2 -> Regf (float_reg_name.(r - 100)) let phys_rax = phys_reg Int 0 let phys_rdx = phys_reg Int 4 @@ -293,6 +292,7 @@ let emit_Llabel fallthrough lbl section_name = let x86_data_type_for_stack_slot : machtype_component -> data_type = function | Float -> REAL8 | Vec128 -> VEC128 + | Valx2 -> VEC128 | Int | Addr | Val -> QWORD | Float32 -> REAL4 @@ -364,13 +364,23 @@ let record_frame_label live dbg = let live_offset = ref [] in Reg.Set.iter (function - | {typ = Val; loc = Reg r} -> + | {typ = Val; loc = Reg r} as reg -> + assert (Proc.gc_regs_offset reg = r); live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Val; loc = Stack s} as reg -> live_offset := slot_offset s (stack_slot_class reg.typ) :: !live_offset + | {typ = Valx2; loc = Reg r} as reg -> + let n = Proc.gc_regs_offset reg in + let encode n = ((n lsl 1) + 1) in + live_offset := encode n :: encode (n + 1) :: !live_offset + | {typ = Valx2; loc = Stack s} as reg -> + let n = slot_offset s (stack_slot_class reg.typ) in + live_offset := n :: n + Arch.size_addr :: !live_offset | {typ = Addr} as r -> Misc.fatal_error ("bad GC root " ^ Reg.name r) - | _ -> () + | { typ = (Val | Valx2); loc = Unknown ; } as r -> + Misc.fatal_error ("Unknown location " ^ Reg.name r) + | { typ = Int | Float | Float32 | Vec128; _ } -> () ) live; record_frame_descr ~label:lbl ~frame_size:(frame_size()) @@ -801,7 +811,7 @@ let move (src : Reg.t) (dst : Reg.t) = begin match src.typ, src.loc, dst.typ, dst.loc with | Float, Reg _, Float, Reg _ | Float32, Reg _, Float32, Reg _ - | Vec128, _, Vec128, _ (* Vec128 stack slots are always aligned. *) -> + | (Vec128 | Valx2), _, (Vec128 | Valx2), _ (* Vec128 stack slots are always aligned. *) -> if distinct then I.movapd (reg src) (reg dst) | Float, _, Float, _ -> if distinct then I.movsd (reg src) (reg dst) @@ -809,7 +819,7 @@ let move (src : Reg.t) (dst : Reg.t) = if distinct then I.movss (reg src) (reg dst) | (Int | Val | Addr), _, (Int | Val | Addr), _ -> if distinct then I.mov (reg src) (reg dst) - | (Float | Float32 | Vec128 | Int | Val | Addr), _, _, _ -> + | (Float | Float32 | Vec128 | Int | Val | Addr | Valx2), _, _, _ -> Misc.fatal_errorf "Illegal move between registers of differing types (%a to %a)\n" Printreg.reg src Printreg.reg dst @@ -823,7 +833,7 @@ let stack_to_stack_move (src : Reg.t) (dst : Reg.t) = (* Not calling move because r15 is not in int_reg_name. *) I.mov (reg src) r15; I.mov r15 (reg dst) - | Float | Addr | Vec128 | Float32 -> + | Float | Addr | Vec128 | Valx2 | Float32 -> Misc.fatal_errorf "Unexpected register type for stack to stack move: from %s to %s\n" (Reg.name src) (Reg.name dst) @@ -972,19 +982,50 @@ let emit_push_trap_label handler = (* Emit Code *) let emit_atomic instr op (size : Cmm.atomic_bitwidth) addr = - let src, dst = match op, size with - | Fetch_and_add, Thirtytwo -> arg32 instr 0, addressing addr DWORD instr 1 - | Fetch_and_add, (Sixtyfour|Word) -> arg instr 0, addressing addr QWORD instr 1 - | Compare_and_swap, Thirtytwo -> arg32 instr 1, addressing addr DWORD instr 2 - | Compare_and_swap, (Sixtyfour|Word) -> arg instr 1, addressing addr QWORD instr 2 in + let first_memory_arg_index = + match op with + | Compare_set -> 2 + | Fetch_and_add -> 1 + | Add | Sub | Land | Lor | Lxor -> 1 + | Exchange -> 1 + | Compare_exchange -> 2 + in + let dst = + addressing addr DWORD instr first_memory_arg_index + in + let src_index = first_memory_arg_index - 1 in + let typ, src = + match size with + | Thirtytwo -> DWORD, arg32 instr src_index + | (Sixtyfour|Word) -> QWORD, arg instr src_index + in match op with - | Fetch_and_add -> I.lock_xadd src dst - | Compare_and_swap -> + | Fetch_and_add -> + assert (Reg.same_loc instr.res.(0) instr.arg.(0)); + I.lock_xadd src dst + | Add -> I.lock_add src dst + | Sub -> I.lock_sub src dst + | Land -> I.lock_and src dst + | Lor -> I.lock_or src dst + | Lxor -> I.lock_xor src dst + | Compare_set -> (* compare_with is already in rax, set_to is src *) + assert (Reg.is_reg instr.arg.(1)); + assert (Reg.same_loc instr.arg.(0) phys_rax); let res8, res = res8 instr 0, res instr 0 in I.lock_cmpxchg src dst; I.set E res8; I.movzx res8 res + | Compare_exchange -> + (* compare_with is already in rax, set_to is src, res in rax *) + assert (Reg.is_reg instr.arg.(1)); + assert (Reg.same_loc instr.arg.(0) phys_rax); + assert (Reg.same_loc instr.res.(0) phys_rax); + I.lock_cmpxchg src dst + | Exchange -> + (* no need for a "lock" prefix for XCHG with a memory operand *) + assert (Reg.is_reg instr.arg.(0)); + I.xchg src dst let emit_reinterpret_cast (cast : Cmm.reinterpret_cast) i = let distinct = not (Reg.same_loc i.arg.(0) i.res.(0)) in @@ -1035,8 +1076,8 @@ let emit_static_cast (cast : Cmm.static_cast) i = CR mslater: (SIMD) don't load 32 bits once we have unboxed int16/int8 *) I.movd (arg32 i 0) (res i 0) -let emit_simd_instr op i = - (match Simd_proc.register_behavior op with +let check_simd_instr (register_behavior : Simd_proc.register_behavior) i = + (match register_behavior with | R_to_fst -> assert (Reg.same_loc i.arg.(0) i.res.(0)); assert (Reg.is_reg i.arg.(0)) @@ -1076,6 +1117,23 @@ let emit_simd_instr op i = assert (Reg.is_reg i.arg.(0)); assert (Reg.same_loc i.res.(0) (phys_xmm0v ())) ); + () + +let emit_simd_instr_with_memory_arg op i addressing_mode = + check_simd_instr (Simd_proc.Mem.register_behavior op) i; + let addr = addressing addressing_mode VEC128 i 1 in + match (op : Simd.Mem.operation) with + | SSE2 Add_f64 -> I.addpd addr (res i 0) + | SSE2 Sub_f64 -> I.subpd addr (res i 0) + | SSE2 Mul_f64 -> I.mulpd addr (res i 0) + | SSE2 Div_f64 -> I.divpd addr (res i 0) + | SSE Add_f32 -> I.addps addr (res i 0) + | SSE Sub_f32 -> I.subps addr (res i 0) + | SSE Mul_f32 -> I.mulps addr (res i 0) + | SSE Div_f32 -> I.divps addr (res i 0) + +let emit_simd_instr op i = + check_simd_instr (Simd_proc.register_behavior op) i; match (op : Simd.operation) with | CLMUL (Clmul_64 n) -> I.pclmulqdq (X86_dsl.int n) (arg i 1) (res i 0) | BMI2 Extract_64 -> I.pext (arg i 1) (arg i 0) (res i 0) @@ -1715,6 +1773,8 @@ let emit_instr ~first ~fallthrough i = I.mfence () | Lop (Specific (Isimd op)) -> emit_simd_instr op i + | Lop (Specific (Isimd_mem (op, addressing_mode))) -> + emit_simd_instr_with_memory_arg op i addressing_mode | Lop (Static_cast cast) -> emit_static_cast cast i | Lop (Reinterpret_cast cast) -> @@ -2144,7 +2204,7 @@ let size_of_regs regs = | Float | Float32 -> (* Float32 slots still take up a full word *) acc + size_float - | Vec128 -> acc + size_vec128) + | Vec128 | Valx2 -> acc + size_vec128) regs 0 let stack_locations ~offset regs = @@ -2154,7 +2214,7 @@ let stack_locations ~offset regs = | Float | Float32 -> (* Float32 slots still take up a full word *) size_float - | Vec128 -> size_vec128 in + | Vec128 | Valx2 -> size_vec128 in next, (make_stack_loc n r ~offset :: offsets)) regs (0, []) in locs |> Array.of_list @@ -2242,6 +2302,7 @@ let emit_probe_handler_wrapper p = (match r.typ with | Val -> k::acc | Int | Float | Vec128 | Float32 -> acc + | Valx2 -> k::k+Arch.size_addr::acc | Addr -> Misc.fatal_error ("bad GC root " ^ Reg.name r)) | _ -> assert false) saved_live @@ -2316,7 +2377,7 @@ let emit_probe_notes0 () = Misc.fatal_errorf "Cannot create probe: illegal argument: %a" Printreg.reg arg in - Printf.sprintf "%d@%s" (Reg.size_of_contents_in_bytes arg) arg_name + Printf.sprintf "%d@%s" (Select_utils.size_component arg.Reg.typ) arg_name in let describe_one_probe p = let probe_name, enabled_at_init = @@ -2519,3 +2580,4 @@ let end_assembly () = (* The internal assembler does not work if reset_all is called here *) if not !Flambda_backend_flags.internal_assembler then reset_all () + diff --git a/backend/amd64/proc.ml b/backend/amd64/proc.ml index bae57a84461..8499968bd1b 100644 --- a/backend/amd64/proc.ml +++ b/backend/amd64/proc.ml @@ -1,4 +1,3 @@ -# 2 "backend/amd64/proc.ml" (**************************************************************************) (* *) (* OCaml *) @@ -102,7 +101,7 @@ let num_register_classes = 2 let register_class r = match r.typ with | Val | Int | Addr -> 0 - | Float | Float32 | Vec128 -> 1 + | Float | Float32 | Vec128 | Valx2 -> 1 let num_stack_slot_classes = 3 @@ -110,7 +109,16 @@ let stack_slot_class typ = match (typ : machtype_component) with | Val | Addr | Int -> 0 | Float | Float32 -> 1 - | Vec128 -> 2 + | Vec128 | Valx2 -> 2 + +let types_are_compatible left right = + match left.typ, right.typ with + | (Int | Val | Addr), (Int | Val | Addr) + | Float, Float + | Float32, Float32 + | (Valx2 | Vec128), (Valx2 | Vec128) -> + true + | (Int | Val | Addr | Float | Float32 | Vec128 | Valx2), _ -> false let stack_class_tag c = match c with @@ -128,7 +136,7 @@ let register_name ty r = match (ty : machtype_component) with | Int | Addr | Val -> int_reg_name.(r - first_available_register.(0)) - | Float | Float32 | Vec128 -> + | Float | Float32 | Vec128 | Valx2 -> float_reg_name.(r - first_available_register.(1)) (* Pack registers starting at %rax so as to reduce the number of REX @@ -165,7 +173,40 @@ let phys_reg ty n = | Int | Addr | Val -> hard_int_reg.(n) | Float -> hard_float_reg.(n - 100) | Float32 -> hard_float32_reg.(n - 100) - | Vec128 -> hard_vec128_reg.(n - 100) + | Vec128 | Valx2 -> hard_vec128_reg.(n - 100) + +let gc_regs_offset reg = + (* Given register [r], return the offset (the number of [value] slots, + not their size in bytes) of the register from the + [gc_regs] pointer during GC at runtime. Keep in sync with [amd64.S]. *) + let r = + match reg.loc with + | Reg r -> r + | Stack _ | Unknown -> + Misc.fatal_errorf "Unexpected register location for %d" reg.stamp + in + let reg_class = register_class reg in + let index = (r - first_available_register.(reg_class)) in + match reg_class with + | 0 -> index + | 1 -> + let slot_size_in_vals = 2 in + assert (Arch.size_vec128 / Arch.size_int = slot_size_in_vals); + if Config.runtime5 + then + (* xmm slots are above regular slots based at [gc_regs_bucket] *) + let num_regular_slots = + (* rbp is always spilled even without frame pointers *) + 13 + in + num_regular_slots + (index * slot_size_in_vals) + else + (* xmm slots are below [gc_regs] pointer *) + let num_xmm_slots = 16 in + let offset = Int.neg (num_xmm_slots * slot_size_in_vals) in + offset + (index * slot_size_in_vals) + | _ -> assert false + let rax = phys_reg Int 0 let rdx = phys_reg Int 4 @@ -236,6 +277,8 @@ let calling_conventions loc.(i) <- stack_slot (make_stack !ofs) Vec128; ofs := !ofs + size_vec128 end + | Valx2 -> + Misc.fatal_error "Unexpected machtype_component Valx2" | Float32 -> if !float <= last_float then begin loc.(i) <- phys_reg Float32 !float; @@ -387,6 +430,8 @@ let win64_loc_external_arguments arg = | Vec128 -> (* CR mslater: (SIMD) win64 calling convention requires pass by reference *) Misc.fatal_error "SIMD external arguments are not supported on Win64" + | Valx2 -> + Misc.fatal_error "Unexpected machtype_component Valx2" done; (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) @@ -462,8 +507,8 @@ let destroyed_at_pushtrap = let has_pushtrap traps = List.exists (function Cmm.Push _ -> true | Pop _ -> false) traps -let destroyed_by_simd_op op = - match Simd_proc.register_behavior op with +let destroyed_by_simd_op (register_behavior : Simd_proc.register_behavior) = + match register_behavior with | R_RM_rax_rdx_to_xmm0 | R_RM_to_xmm0 -> destroy_xmm 0 | R_RM_rax_rdx_to_rcx @@ -497,7 +542,10 @@ let destroyed_at_oper = function | Ireturn traps when has_pushtrap traps -> assert false | Iop(Ispecific (Irdtsc | Irdpmc)) -> [| rax; rdx |] | Iop(Ispecific(Ilfence | Isfence | Imfence)) -> [||] - | Iop(Ispecific(Isimd op)) -> destroyed_by_simd_op op + | Iop(Ispecific(Isimd op)) -> + destroyed_by_simd_op (Simd_proc.register_behavior op) + | Iop(Ispecific(Isimd_mem (op,_))) -> + destroyed_by_simd_op (Simd_proc.Mem.register_behavior op) | Iop(Ispecific(Isextend32 | Izextend32 | Ilea _ | Istore_int (_, _, _) | Ioffset_loc (_, _) | Ipause | Icldemote _ | Iprefetch _ @@ -550,7 +598,10 @@ let destroyed_at_basic (basic : Cfg_intf.S.basic) = | Op Poll -> destroyed_at_alloc_or_poll | Op (Alloc _) -> destroyed_at_alloc_or_poll - | Op (Specific (Isimd op)) -> destroyed_by_simd_op op + | Op (Specific (Isimd op)) -> + destroyed_by_simd_op (Simd_proc.register_behavior op) + | Op (Specific (Isimd_mem (op,_))) -> + destroyed_by_simd_op (Simd_proc.Mem.register_behavior op) | Op (Move | Spill | Reload | Const_int _ | Const_float _ | Const_float32 _ | Const_symbol _ | Const_vec128 _ @@ -602,7 +653,7 @@ let destroyed_at_terminator (terminator : Cfg_intf.S.terminator) = | Call {op = Indirect | Direct _; _} -> all_phys_regs | Specific_can_raise { op = (Ilea _ | Ibswap _ | Isextend32 | Izextend32 | Ifloatarithmem _ | Irdtsc | Irdpmc | Ipause - | Isimd _ | Ilfence | Isfence | Imfence + | Isimd _ | Isimd_mem _ | Ilfence | Isfence | Imfence | Istore_int (_, _, _) | Ioffset_loc (_, _) | Icldemote _ | Iprefetch _); _ } -> Misc.fatal_error "no instructions specific for this architecture can raise" @@ -632,7 +683,7 @@ let is_destruction_point ~(more_destruction_points : bool) (terminator : Cfg_int true | Specific_can_raise { op = (Ilea _ | Ibswap _ | Isextend32 | Izextend32 | Ifloatarithmem _ | Irdtsc | Irdpmc | Ipause - | Isimd _ | Ilfence | Isfence | Imfence + | Isimd _ | Isimd_mem _ | Ilfence | Isfence | Imfence | Istore_int (_, _, _) | Ioffset_loc (_, _) | Icldemote _ | Iprefetch _); _ } -> Misc.fatal_error "no instructions specific for this architecture can raise" @@ -656,13 +707,29 @@ let safe_register_pressure = function | Ibeginregion | Iendregion | Idls_get -> if fp then 10 else 11 -let max_register_pressure = +let max_register_pressure op = let consumes ~int ~float = if fp then [| 12 - int; 16 - float |] else [| 13 - int; 16 - float |] - in function - Iextcall _ -> + in + let simd_max_register_pressure (register_behavior : Simd_proc.register_behavior) = + (match register_behavior with + | R_RM_rax_rdx_to_xmm0 + | R_RM_to_xmm0 -> consumes ~int:0 ~float:1 + | R_RM_rax_rdx_to_rcx + | R_RM_to_rcx -> consumes ~int:1 ~float:0 + | R_to_fst + | R_to_R + | R_to_RM + | RM_to_R + | R_R_to_fst + | R_RM_to_fst + | R_RM_to_R + | R_RM_xmm0_to_fst -> consumes ~int:0 ~float:0) + in + match op with + | Iextcall _ -> if win64 then consumes ~int:5 ~float:6 else consumes ~int:9 ~float:16 @@ -676,19 +743,9 @@ let max_register_pressure = | Ifloatop ((Float64 | Float32), Icompf _) -> consumes ~int:0 ~float:1 | Ispecific(Isimd op) -> - (match Simd_proc.register_behavior op with - | R_RM_rax_rdx_to_xmm0 - | R_RM_to_xmm0 -> consumes ~int:0 ~float:1 - | R_RM_rax_rdx_to_rcx - | R_RM_to_rcx -> consumes ~int:1 ~float:0 - | R_to_fst - | R_to_R - | R_to_RM - | RM_to_R - | R_R_to_fst - | R_RM_to_fst - | R_RM_to_R - | R_RM_xmm0_to_fst -> consumes ~int:0 ~float:0) + simd_max_register_pressure (Simd_proc.register_behavior op) + | Ispecific(Isimd_mem (op,_)) -> + simd_max_register_pressure (Simd_proc.Mem.register_behavior op) | Iintop(Iadd | Isub | Imul | Imulh _ | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt|Iclz _| Ictz _) | Iintop_imm((Iadd | Isub | Imul | Imulh _ | Iand | Ior | Ixor | Ilsl | Ilsr diff --git a/backend/amd64/regalloc_stack_operands.ml b/backend/amd64/regalloc_stack_operands.ml index f85c488a30e..b3a8a2b2193 100644 --- a/backend/amd64/regalloc_stack_operands.ml +++ b/backend/amd64/regalloc_stack_operands.ml @@ -1,5 +1,3 @@ -# 2 "backend/amd64/regalloc_stack_operands.ml" - [@@@ocaml.warning "+a-4-30-40-41-42"] open! Regalloc_utils @@ -178,6 +176,21 @@ let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = may_use_stack_operand_for_second_argument map instr ~num_args:3 ~res_is_fst:true | R_to_RM -> may_use_stack_operand_for_result map instr ~num_args:1 | RM_to_R -> may_use_stack_operand_for_only_argument map instr ~has_result:true) + | Op (Specific (Isimd_mem (op,_))) -> + (match Simd_proc.Mem.register_behavior op with + | R_RM_to_fst -> May_still_have_spilled_registers + | R_to_fst + | R_to_R + | R_to_RM + | RM_to_R + | R_R_to_fst + | R_RM_to_R + | R_RM_xmm0_to_fst + | R_RM_rax_rdx_to_rcx + | R_RM_to_rcx + | R_RM_rax_rdx_to_xmm0 + | R_RM_to_xmm0 + -> Misc.fatal_error "Unexpected simd operation with memory arguments") | Op (Reinterpret_cast (Float_of_float32 | Float32_of_float | V128_of_v128)) | Op (Static_cast (V128_of_scalar Float64x2 | Scalar_of_v128 Float64x2)) | Op (Static_cast (V128_of_scalar Float32x4 | Scalar_of_v128 Float32x4)) -> diff --git a/backend/amd64/reload.ml b/backend/amd64/reload.ml index 7cf2ba897e0..74ef7739bb1 100644 --- a/backend/amd64/reload.ml +++ b/backend/amd64/reload.ml @@ -1,4 +1,3 @@ -# 2 "backend/amd64/reload.ml" (**************************************************************************) (* *) (* OCaml *) @@ -127,6 +126,7 @@ method! reload_operation op arg res = then (let r = self#makereg res.(0) in (arg, [|r|])) else (arg, res) | Ispecific(Isimd op) -> Simd_reload.reload_operation self#makereg op arg res + | Ispecific(Isimd_mem (op,_)) -> Simd_reload.Mem.reload_operation self#makereg op arg res | Iconst_int n -> if n <= 0x7FFFFFFFn && n >= -0x80000000n then (arg, res) diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index 997e12c97e2..34a1bab0f0f 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -26,12 +26,17 @@ let pseudoregs_for_operation op arg res = | Iintop (Iadd | Isub | Imul | Iand | Ior | Ixor) | Ifloatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> [| res.(0); arg.(1) |], res - | Iintop_atomic { op = Compare_and_swap; size = _; addr = _ } -> + | Iintop_atomic { op = Compare_set; size = _; addr = _ } -> (* first arg must be rax *) let arg = Array.copy arg in arg.(0) <- rax; arg, res - | Iintop_atomic { op = Fetch_and_add; size = _; addr = _ } -> + | Iintop_atomic { op = Compare_exchange; size = _; addr = _ } -> + (* first arg must be rax, res.(0) must be rax. *) + let arg = Array.copy arg in + arg.(0) <- rax; + arg, [| rax |] + | Iintop_atomic { op = Exchange | Fetch_and_add; size = _; addr = _ } -> (* first arg must be the same as res.(0) *) let arg = Array.copy arg in arg.(0) <- res.(0); @@ -80,7 +85,14 @@ let pseudoregs_for_operation op arg res = edx (high) and eax (low). Make it simple and force the argument in rcx, and rax and rdx clobbered *) [| rcx |], res - | Ispecific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res + | Ispecific (Isimd op) -> + Simd_selection.pseudoregs_for_operation + (Simd_proc.register_behavior op) + arg res + | Ispecific (Isimd_mem (op, _addr)) -> + Simd_selection.pseudoregs_for_operation + (Simd_proc.Mem.register_behavior op) + arg res | Icsel _ -> (* last arg must be the same as res.(0) *) let len = Array.length arg in @@ -88,6 +100,7 @@ let pseudoregs_for_operation op arg res = arg.(len - 1) <- res.(0); arg, res (* Other instructions are regular *) + | Iintop_atomic { op = Add | Sub | Land | Lor | Lxor; _ } | Iintop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) | Iintop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) | Ispecific diff --git a/backend/amd64/simd.ml b/backend/amd64/simd.ml index 0828956b1de..4a107f30c96 100644 --- a/backend/amd64/simd.ml +++ b/backend/amd64/simd.ml @@ -18,7 +18,9 @@ open Format -type operation_class = Pure +type operation_class = + | Pure + | Load of { is_mutable : bool } type float_condition = X86_ast.float_condition = | EQf @@ -1002,4 +1004,83 @@ let class_of_operation op = | SSE41 op -> class_of_operation_sse41 op | SSE42 op -> class_of_operation_sse42 op -let is_pure op = match class_of_operation op with Pure -> true +let is_pure op = + match class_of_operation op with Pure -> true | Load _ -> true + +module Mem = struct + (** Initial support for some operations with memory arguments. + Requires 16-byte aligned memory. *) + + type sse_operation = + | Add_f32 + | Sub_f32 + | Mul_f32 + | Div_f32 + + type sse2_operation = + | Add_f64 + | Sub_f64 + | Mul_f64 + | Div_f64 + + type operation = + | SSE of sse_operation + | SSE2 of sse2_operation + + let class_of_operation_sse (op : sse_operation) = + match op with + | Add_f32 | Sub_f32 | Mul_f32 | Div_f32 -> Load { is_mutable = true } + + let class_of_operation_sse2 (op : sse2_operation) = + match op with + | Add_f64 | Sub_f64 | Mul_f64 | Div_f64 -> Load { is_mutable = true } + + let class_of_operation (op : operation) = + match op with + | SSE op -> class_of_operation_sse op + | SSE2 op -> class_of_operation_sse2 op + + let op_name_sse (op : sse_operation) = + match op with + | Add_f32 -> "add_f32" + | Sub_f32 -> "sub_f32" + | Mul_f32 -> "mul_f32" + | Div_f32 -> "div_f32" + + let op_name_sse2 (op : sse2_operation) = + match op with + | Add_f64 -> "add_f64" + | Sub_f64 -> "sub_f64" + | Mul_f64 -> "mul_f64" + | Div_f64 -> "div_f64" + + let print_operation printreg printaddr (op : operation) ppf arg = + let addr_args = Array.sub arg 1 (Array.length arg - 1) in + let op_name = + match op with SSE op -> op_name_sse op | SSE2 op -> op_name_sse2 op + in + fprintf ppf "%s %a [%a]" op_name printreg arg.(0) printaddr addr_args + + let is_pure op = + match class_of_operation op with Pure -> true | Load _ -> true + + let equal_operation_sse2 (l : sse2_operation) (r : sse2_operation) = + match l, r with + | Add_f64, Add_f64 | Sub_f64, Sub_f64 | Mul_f64, Mul_f64 | Div_f64, Div_f64 + -> + true + | (Add_f64 | Sub_f64 | Mul_f64 | Div_f64), _ -> false + + let equal_operation_sse (l : sse_operation) (r : sse_operation) = + match l, r with + | Add_f32, Add_f32 | Sub_f32, Sub_f32 | Mul_f32, Mul_f32 | Div_f32, Div_f32 + -> + true + | (Add_f32 | Sub_f32 | Mul_f32 | Div_f32), _ -> false + + let equal_operation (l : operation) (r : operation) = + match l, r with + | SSE l, SSE r -> equal_operation_sse l r + | SSE2 l, SSE2 r -> equal_operation_sse2 l r + | (SSE _ | SSE2 _), _ -> false +end diff --git a/backend/amd64/simd_proc.ml b/backend/amd64/simd_proc.ml index f52ec00bb41..0b75165c9f5 100644 --- a/backend/amd64/simd_proc.ml +++ b/backend/amd64/simd_proc.ml @@ -122,3 +122,16 @@ let register_behavior = function | SSSE3 op -> register_behavior_ssse3 op | SSE41 op -> register_behavior_sse41 op | SSE42 op -> register_behavior_sse42 op + +module Mem = struct + let register_behavior_sse (op : Simd.Mem.sse_operation) = + match op with Add_f32 | Sub_f32 | Mul_f32 | Div_f32 -> R_RM_to_fst + + let register_behavior_sse2 (op : Simd.Mem.sse2_operation) = + match op with Add_f64 | Sub_f64 | Mul_f64 | Div_f64 -> R_RM_to_fst + + let register_behavior (op : Simd.Mem.operation) = + match op with + | SSE op -> register_behavior_sse op + | SSE2 op -> register_behavior_sse2 op +end diff --git a/backend/amd64/simd_reload.ml b/backend/amd64/simd_reload.ml index 5b5518afd7f..2a59cdaed75 100644 --- a/backend/amd64/simd_reload.ml +++ b/backend/amd64/simd_reload.ml @@ -16,11 +16,12 @@ (* SIMD instruction reload for AMD64 *) -let reload_operation makereg op arg res = +let reload_operation makereg (register_behavior : Simd_proc.register_behavior) + arg res = let stackp r = match r.Reg.loc with Stack _ -> true | Reg _ | Unknown -> false in - match Simd_proc.register_behavior op with + match register_behavior with | R_to_fst -> (* Argument must be in a register; result must be the argument. *) let arg0 = if stackp arg.(0) then makereg arg.(0) else arg.(0) in @@ -67,3 +68,11 @@ let reload_operation makereg op arg res = enforced by selection. *) let arg0 = if stackp arg.(0) then makereg arg.(0) else arg.(0) in [| arg0; arg.(1); arg.(2); arg.(3) |], res + +module Mem = struct + let reload_operation makereg (op : Simd.Mem.operation) arg res = + reload_operation makereg (Simd_proc.Mem.register_behavior op) arg res +end + +let reload_operation makereg op arg res = + reload_operation makereg (Simd_proc.register_behavior op) arg res diff --git a/backend/amd64/simd_selection.ml b/backend/amd64/simd_selection.ml index 526d37d3f11..ef3e7dd0898 100644 --- a/backend/amd64/simd_selection.ml +++ b/backend/amd64/simd_selection.ml @@ -439,12 +439,13 @@ let select_operation_cfg op args = select_simd_instr op args |> Option.map (fun (op, args) -> Operation.Specific (Isimd op), args) -let pseudoregs_for_operation op arg res = +let pseudoregs_for_operation (register_behavior : Simd_proc.register_behavior) + arg res = let rax = Proc.phys_reg Int 0 in let rcx = Proc.phys_reg Int 5 in let rdx = Proc.phys_reg Int 4 in let xmm0v () = Proc.phys_reg Vec128 100 in - match Simd_proc.register_behavior op with + match register_behavior with | R_to_R | RM_to_R | R_to_RM | R_RM_to_R -> arg, res | R_to_fst -> (* arg.(0) and res.(0) must be the same *) @@ -474,12 +475,25 @@ let vector_width_in_bits = 128 (* CR-soon gyorsh: [vectorize_operation] is too long, refactor / split up. *) let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) - ~arg_count ~res_count (cfg_ops : Operation.t list) : + ~arg_count ~res_count ~alignment_in_bytes (cfg_ops : Operation.t list) : Vectorize_utils.Vectorized_instruction.t list option = (* Assumes cfg_ops are isomorphic *) let width_in_bits = Vectorize_utils.Width_in_bits.to_int width_type in let length = List.length cfg_ops in assert (length * width_in_bits = vector_width_in_bits); + let vector_width_in_bytes = vector_width_in_bits / 8 in + let is_aligned_to_vector_width () = + match alignment_in_bytes with + | None -> Misc.fatal_error "Unexpected memory operation" + | Some alignment_in_bytes -> + alignment_in_bytes mod vector_width_in_bytes = 0 + && alignment_in_bytes / vector_width_in_bytes > 1 + in + let vec128_chunk () : Cmm.memory_chunk = + if is_aligned_to_vector_width () + then Onetwentyeight_aligned + else Onetwentyeight_unaligned + in let same_width memory_chunk = Vectorize_utils.Width_in_bits.equal width_type (Vectorize_utils.Width_in_bits.of_memory_chunk memory_chunk) @@ -491,7 +505,7 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) ~res_count operation ] in let create_const_vec consts = - let highs, lows = Misc.Stdlib.List.split_at (length / 2) consts in + let lows, highs = Misc.Stdlib.List.split_at (length / 2) consts in let pack_int64 nums = let mask = Int64.shift_right_logical Int64.minus_one (64 - width_in_bits) @@ -650,7 +664,7 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) assert (arg_count = num_args_addressing && res_count = 1); let operation = Operation.Load - { memory_chunk = Onetwentyeight_unaligned; + { memory_chunk = vec128_chunk (); addressing_mode; mutability; is_atomic @@ -670,8 +684,7 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) let num_args_addressing = Arch.num_args_addressing addressing_mode in assert (arg_count = num_args_addressing + 1 && res_count = 0); let operation = - Operation.Store - (Onetwentyeight_unaligned, addressing_mode, is_assignment) + Operation.Store (vec128_chunk (), addressing_mode, is_assignment) in Some [ { operation; @@ -703,9 +716,9 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) then ( assert (arg_count = 1 && res_count = 1); const_instruction.results.(0) - <- Vectorize_utils.Vectorized_instruction.New 0; + <- Vectorize_utils.Vectorized_instruction.New_Vec128 0; intop_instruction.arguments.(1) - <- Vectorize_utils.Vectorized_instruction.New 0; + <- Vectorize_utils.Vectorized_instruction.New_Vec128 0; Some [const_instruction; intop_instruction]) else None | _ -> None) @@ -725,7 +738,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) | Ibased _ -> None, None) | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ | Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence - | Imfence | Ipause | Isimd _ | Iprefetch _ | Icldemote _ -> + | Imfence | Ipause | Isimd _ | Isimd_mem _ | Iprefetch _ | Icldemote _ + -> assert false) | Move | Load _ | Store _ | Intop _ | Intop_imm _ | Alloc _ | Reinterpret_cast _ | Static_cast _ | Spill | Reload | Const_int _ @@ -776,8 +790,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) (* reg + displ *) Some [ make_move (Argument 0) (Result 0); - make_const (New 0) displs; - make_binary_operation (Result 0) (New 0) (Result 0) add ] + make_const (New_Vec128 0) displs; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) add ] | None -> None) | Iindexed2 _ -> ( match add_op with @@ -788,8 +802,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) Some [ make_move (Argument 0) (Result 0); make_binary_operation (Result 0) (Argument 1) (Result 0) add; - make_const (New 0) displs; - make_binary_operation (Result 0) (New 0) (Result 0) add ] + make_const (New_Vec128 0) displs; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) add ] | None -> None) | Iscaled _ -> ( match add_op, mul_op with @@ -800,10 +814,10 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) (* reg * scale + displ *) Some [ make_move (Argument 0) (Result 0); - make_const (New 0) scales; - make_binary_operation (Result 0) (New 0) (Result 0) mul; - make_const (New 1) displs; - make_binary_operation (Result 0) (New 1) (Result 0) add ] + make_const (New_Vec128 0) scales; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) mul; + make_const (New_Vec128 1) displs; + make_binary_operation (Result 0) (New_Vec128 1) (Result 0) add ] | _ -> None) | Iindexed2scaled _ -> ( match add_op, mul_op with @@ -814,11 +828,11 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) (* reg + reg * scale + displ *) Some [ make_move (Argument 1) (Result 0); - make_const (New 0) scales; - make_binary_operation (Result 0) (New 0) (Result 0) mul; + make_const (New_Vec128 0) scales; + make_binary_operation (Result 0) (New_Vec128 0) (Result 0) mul; make_binary_operation (Result 0) (Argument 0) (Result 0) add; - make_const (New 1) displs; - make_binary_operation (Result 0) (New 1) (Result 0) add ] + make_const (New_Vec128 1) displs; + make_binary_operation (Result 0) (New_Vec128 1) (Result 0) add ] | _ -> None) | Ibased _ -> None) | Isextend32 -> ( @@ -843,9 +857,124 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t) | W32 -> None (* See previous comment *) | W16 -> None | W8 -> None) - | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ | Irdtsc - | Irdpmc | Ilfence | Isfence | Imfence | Ipause | Isimd _ | Iprefetch _ - | Icldemote _ -> + | Istore_int (_n, addressing_mode, is_assignment) -> ( + if not (Vectorize_utils.Width_in_bits.equal width_type W64) + then None + else + let extract_store_int_imm (op : Operation.t) = + match op with + | Specific (Istore_int (n, _addr, _is_assign)) -> Int64.of_nativeint n + | Specific + ( Ifloatarithmem _ | Ioffset_loc _ | Iprefetch _ | Icldemote _ + | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence | Ipause | Isimd _ + | Isimd_mem _ | Ilea _ | Ibswap _ | Isextend32 | Izextend32 ) + | Intop_imm _ | Move | Load _ | Store _ | Intop _ | Alloc _ + | Reinterpret_cast _ | Static_cast _ | Spill | Reload | Const_int _ + | Const_float32 _ | Const_float _ | Const_symbol _ | Const_vec128 _ + | Stackoffset _ | Intop_atomic _ | Floatop _ | Csel _ + | Probe_is_enabled _ | Opaque | Begin_region | End_region + | Name_for_debugger _ | Dls_get | Poll -> + assert false + in + let consts = List.map extract_store_int_imm cfg_ops in + match create_const_vec consts with + | None -> None + | Some [const_instruction] -> + let num_args_addressing = Arch.num_args_addressing addressing_mode in + assert (arg_count = num_args_addressing); + assert (res_count = 0); + assert (Array.length const_instruction.results = 1); + let new_reg = Vectorize_utils.Vectorized_instruction.New_Vec128 0 in + const_instruction.results.(0) <- new_reg; + let address_args = + Array.init num_args_addressing (fun i -> + Vectorize_utils.Vectorized_instruction.Original i) + in + let store_operation = + Operation.Store + (Onetwentyeight_unaligned, addressing_mode, is_assignment) + in + let store_instruction : Vectorize_utils.Vectorized_instruction.t = + { operation = store_operation; + arguments = Array.append [| new_reg |] address_args; + results = [||] + } + in + Some [const_instruction; store_instruction] + | Some _ -> None) + | Ifloatarithmem (float_width, float_op, addressing_mode) -> + let float_width_in_bits : Vectorize_utils.Width_in_bits.t = + match float_width with Float64 -> W64 | Float32 -> W32 + in + assert (Vectorize_utils.Width_in_bits.equal float_width_in_bits width_type); + let num_args_addressing = Arch.num_args_addressing addressing_mode in + assert (arg_count = 1 + num_args_addressing); + assert (res_count = 1); + let results = [| Vectorize_utils.Vectorized_instruction.Result 0 |] in + let address_args = + Array.init num_args_addressing (fun i -> + Vectorize_utils.Vectorized_instruction.Original (i + 1)) + in + if is_aligned_to_vector_width () + then + let sse_op : Simd.Mem.operation = + match float_width, float_op with + | Float64, Ifloatadd -> SSE2 Add_f64 + | Float64, Ifloatsub -> SSE2 Sub_f64 + | Float64, Ifloatmul -> SSE2 Mul_f64 + | Float64, Ifloatdiv -> SSE2 Div_f64 + | Float32, Ifloatadd -> SSE Add_f32 + | Float32, Ifloatsub -> SSE Sub_f32 + | Float32, Ifloatmul -> SSE Mul_f32 + | Float32, Ifloatdiv -> SSE Div_f32 + in + Some + [ { operation = + Operation.Specific (Isimd_mem (sse_op, addressing_mode)); + arguments = Array.append results address_args; + results + } ] + else + (* Emit a load followed by an arithmetic operation, effectively + reverting the decision from Arch.selection. It will probably not be + beneficial with 128-bit accesses. *) + let sse_op : Simd.operation = + match float_width, float_op with + | Float64, Ifloatadd -> SSE2 Add_f64 + | Float64, Ifloatsub -> SSE2 Sub_f64 + | Float64, Ifloatmul -> SSE2 Mul_f64 + | Float64, Ifloatdiv -> SSE2 Div_f64 + | Float32, Ifloatadd -> SSE Add_f32 + | Float32, Ifloatsub -> SSE Sub_f32 + | Float32, Ifloatmul -> SSE Mul_f32 + | Float32, Ifloatdiv -> SSE Div_f32 + in + let new_reg = + [| Vectorize_utils.Vectorized_instruction.New_Vec128 0 |] + in + let load : Vectorize_utils.Vectorized_instruction.t = + { operation = + Operation.Load + { memory_chunk = vec128_chunk (); + addressing_mode; + mutability = Mutable; + is_atomic = false + }; + arguments = address_args; + results = new_reg + } + in + let arith : Vectorize_utils.Vectorized_instruction.t = + { operation = Operation.Specific (Isimd sse_op); + arguments = Array.append results new_reg; + results + } + in + Some [load; arith] + | Isimd_mem _ -> + Misc.fatal_error "Unexpected simd operation with memory arguments" + | Ioffset_loc _ | Ibswap _ | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence + | Ipause | Isimd _ | Iprefetch _ | Icldemote _ -> None) | Alloc _ | Reinterpret_cast _ | Static_cast _ | Spill | Reload | Const_float32 _ | Const_float _ | Const_symbol _ | Const_vec128 _ diff --git a/backend/amd64/vectorize_specific.ml b/backend/amd64/vectorize_specific.ml index 2f535ca2834..1e772d79dec 100644 --- a/backend/amd64/vectorize_specific.ml +++ b/backend/amd64/vectorize_specific.ml @@ -1,3 +1,5 @@ +[@@@ocaml.warning "+a-40-42"] + (* Keep in sync with [Arch.operation_is_pure], [Arch.operation_can_raise], [Arch.operation_allocates]. *) module Memory_access = Vectorize_utils.Memory_access @@ -50,4 +52,17 @@ let memory_access : Arch.specific_operation -> Memory_access.t option = (* Conservative. we don't have any simd operations with memory operations at the moment. *) if Simd.is_pure op then None else create Memory_access.Arbitrary + | Isimd_mem _ -> + Misc.fatal_errorf + "Unexpected simd instruction with memory operands before vectorization" | Ilea _ | Ibswap _ | Isextend32 | Izextend32 -> None + +let is_seed_store : + Arch.specific_operation -> Vectorize_utils.Width_in_bits.t option = + fun op -> + match op with + | Istore_int _ -> Some W64 + | Ifloatarithmem _ | Ioffset_loc _ | Iprefetch _ | Icldemote _ | Irdtsc + | Irdpmc | Ilfence | Isfence | Imfence | Ipause | Isimd _ | Isimd_mem _ + | Ilea _ | Ibswap _ | Isextend32 | Izextend32 -> + None diff --git a/backend/arm64/CSE.ml b/backend/arm64/CSE.ml index 6bbab6b4f1a..6582e48a1fe 100644 --- a/backend/arm64/CSE.ml +++ b/backend/arm64/CSE.ml @@ -1,4 +1,3 @@ -# 2 "backend/arm64/CSE.ml" (**************************************************************************) (* *) (* OCaml *) diff --git a/backend/arm64/arch.mli b/backend/arm64/arch.mli index e542b5df5dd..4d523b88258 100644 --- a/backend/arm64/arch.mli +++ b/backend/arm64/arch.mli @@ -1,4 +1,3 @@ -# 2 "asmcomp/arm64/arch.mli" (**************************************************************************) (* *) (* OCaml *) diff --git a/backend/arm64/emit.mlp b/backend/arm64/emit.mlp index 512c810f5b3..000bf2f6404 100644 --- a/backend/arm64/emit.mlp +++ b/backend/arm64/emit.mlp @@ -1,4 +1,3 @@ -#2 "backend/arm64/emit.mlp" (**************************************************************************) (* *) (* OCaml *) @@ -164,7 +163,12 @@ let record_frame_label live dbg = live_offset := slot_offset s (stack_slot_class reg.typ) :: !live_offset | {typ = Addr} as r -> Misc.fatal_error ("bad GC root " ^ Reg.name r) - | _ -> ()) + | { typ = Valx2; } as r -> + (* CR mslater: (SIMD) arm64 *) + Misc.fatal_error ("Unexpected Valx2 type of reg " ^ Reg.name r) + | { typ = Val; loc = Unknown ; } as r -> + Misc.fatal_error ("Unknown location " ^ Reg.name r) + | { typ = Int | Float | Float32 | Vec128; _ } -> ()) live; record_frame_descr ~label:lbl ~frame_size:(frame_size()) ~live_offset:!live_offset dbg; @@ -247,6 +251,7 @@ let name_for_int_operation = function | Ilsl -> "lsl" | Ilsr -> "lsr" | Iasr -> "asr" + | Iclz { arg_is_non_zero = _ } -> "clz" | _ -> assert false (* Decompose an integer constant into four 16-bit shifted fragments. @@ -1000,6 +1005,9 @@ let emit_instr i = ` smulh {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Intop (Imulh { signed = false })) -> ` umulh {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Intop (Iclz _ as op)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Intop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` diff --git a/backend/arm64/proc.ml b/backend/arm64/proc.ml index c3a028d269c..a45f941becb 100644 --- a/backend/arm64/proc.ml +++ b/backend/arm64/proc.ml @@ -1,4 +1,3 @@ -# 2 "backend/arm64/proc.ml" (**************************************************************************) (* *) (* OCaml *) @@ -72,6 +71,9 @@ let register_class r = | Float32 -> (* CR mslater: (float32) arm64 *) fatal_error "arm64: got float32 register" + | Valx2 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got valx2 register" let num_stack_slot_classes = 2 @@ -85,6 +87,25 @@ let stack_slot_class typ = | Float32 -> (* CR mslater: (float32) arm64 *) fatal_error "arm64: got float32 register" + | Valx2 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got valx2 register" + +let types_are_compatible left right = + match left.typ, right.typ with + | (Int | Val | Addr), (Int | Val | Addr) + | Float, Float -> + true + | Float32, _ | _, Float32 -> + (* CR mslater: (float32) arm64 *) + fatal_error "arm64: got float32 register" + | Vec128, _ | _, Vec128 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got vec128 register" + | Valx2, _ | _, Valx2 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got valx2 register" + | (Int | Val | Addr | Float), _ -> false let stack_class_tag c = match c with @@ -110,6 +131,9 @@ let register_name ty r = | Float32 -> (* CR mslater: (float32) arm64 *) fatal_error "arm64: got float32 register" + | Valx2 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got valx2 register" let rotate_registers = true @@ -146,6 +170,13 @@ let phys_reg ty n = | Float32 -> (* CR mslater: (float32) arm64 *) fatal_error "arm64: got float32 register" + | Valx2 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got valx2 register" + +let gc_regs_offset _ = + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: gc_reg_offset unreachable" let reg_x8 = phys_reg Int 8 let reg_d7 = phys_reg Float 107 @@ -205,6 +236,9 @@ let calling_conventions | Float32 -> (* CR mslater: (float32) arm64 *) fatal_error "arm64: got float32 register" + | Valx2 -> + (* CR mslater: (SIMD) arm64 *) + fatal_error "arm64: got valx2 register" done; (loc, Misc.align (max 0 !ofs) 16) (* keep stack 16-aligned *) @@ -484,7 +518,7 @@ let assemble_file infile outfile = let init () = () let operation_supported = function - | Cclz _ | Cctz _ | Cpopcnt + | Cctz _ | Cpopcnt | Cprefetch _ | Catomic _ (* CR mslater: (float32) arm64 *) | Cnegf Float32 | Cabsf Float32 | Caddf Float32 @@ -497,7 +531,7 @@ let operation_supported = function Int_of_float Float32 | Float_of_int Float32 | V128_of_scalar _ | Scalar_of_v128 _) -> false (* Not implemented *) - | Cbswap _ + | Cclz _ | Cbswap _ | Capply _ | Cextcall _ | Cload _ | Calloc _ | Cstore _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr diff --git a/backend/arm64/reload.ml b/backend/arm64/reload.ml index 09ebd70d55f..7d27e0760a4 100644 --- a/backend/arm64/reload.ml +++ b/backend/arm64/reload.ml @@ -1,4 +1,3 @@ -# 2 "backend/arm64/reload.ml" (**************************************************************************) (* *) (* OCaml *) diff --git a/backend/arm64/simd_selection.ml b/backend/arm64/simd_selection.ml index 3e18e247129..87a2a7eff3d 100644 --- a/backend/arm64/simd_selection.ml +++ b/backend/arm64/simd_selection.ml @@ -24,6 +24,7 @@ let pseudoregs_for_operation _ arg res = arg, res let vector_width_in_bits = 128 -let vectorize_operation _ ~arg_count:_ ~res_count:_ (_ : Operation.t list) : +let vectorize_operation _ ~arg_count:_ ~res_count:_ ~alignment_in_bytes:_ + (_ : Operation.t list) : Vectorize_utils.Vectorized_instruction.t list option = None diff --git a/backend/arm64/vectorize_specific.ml b/backend/arm64/vectorize_specific.ml index 5eb1ff3886e..983f1a20884 100644 --- a/backend/arm64/vectorize_specific.ml +++ b/backend/arm64/vectorize_specific.ml @@ -1,3 +1,5 @@ +[@@@ocaml.warning "+a-40-42"] + (* Keep in sync with [Arch.operation_is_pure], [Arch.operation_can_raise], [Arch.operation_allocates]. *) module Memory_access = Vectorize_utils.Memory_access @@ -19,3 +21,10 @@ let memory_access : Arch.specific_operation -> Memory_access.t option = (* Conservative. we don't have any specific operations with memory operations at the moment. *) if Arch.operation_is_pure op then None else create Memory_access.Arbitrary + +let is_seed_store (op : Arch.specific_operation) = + match op with + | Ifar_poll _ | Ifar_alloc _ | Ishiftarith _ | Imuladd | Imulsub | Inegmulf + | Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf | Isqrtf | Ibswap _ + | Imove32 | Isignext _ -> + None diff --git a/backend/cfg/cfg_available_regs.ml b/backend/cfg/cfg_available_regs.ml index 535ab3e6074..9c90b5028f1 100644 --- a/backend/cfg/cfg_available_regs.ml +++ b/backend/cfg/cfg_available_regs.ml @@ -174,7 +174,7 @@ module Transfer = struct let reg_is_of_type_addr = match (RD.reg reg).typ with | Addr -> true - | Val | Int | Float | Vec128 | Float32 -> false + | Val | Int | Float | Vec128 | Float32 | Valx2 -> false in if remains_available || (not (extend_live ())) diff --git a/backend/cfg/vectorize.ml b/backend/cfg/vectorize.ml index a225018a57f..6012c63524a 100644 --- a/backend/cfg/vectorize.ml +++ b/backend/cfg/vectorize.ml @@ -355,11 +355,11 @@ module Block : sig val find : t -> Instruction.Id.t -> Instruction.t - (** [find_last_instruction t instrs] returns instruction [i] - from [instrs] such that [i] appears after - all other instructions from [instrs] according to the order of instructions - in this basic block. Raises if [instrs] is empty. *) - val find_last_instruction : t -> Instruction.Id.t list -> Instruction.t + (** [find_last_instruction_id_and_pos group block] returns scalar instruction [i] from + [group] and its position [pos] such that [i] appears after all other instructions + from [group] according to the order of instructions in this basic [block]. *) + val find_last_instruction_id_and_pos : + t -> Instruction.t list -> Instruction.Id.t * int val get_live_regs_before_terminator : t -> State.live_regs @@ -417,28 +417,29 @@ end = struct let get_live_regs_before_terminator t = State.liveness t.state t.block.terminator.id - let find_last_instruction t instructions = - let instruction_set = Instruction.Id.Set.of_list instructions in - let terminator = terminator t in - if Instruction.Id.Set.mem (Instruction.id terminator) instruction_set - then terminator - else - let body = t.block.body in - let rec find_last cell_option = - match cell_option with - | None -> - Misc.fatal_errorf "Vectorizer.find_last_instruction in block %a" - Label.print t.block.start () - | Some cell -> - let current_instruction = Instruction.basic (DLL.value cell) in - let current_instruction_id = Instruction.id current_instruction in - if Instruction.Id.Set.exists - (Instruction.Id.equal current_instruction_id) - instruction_set - then current_instruction - else find_last (DLL.prev cell) - in - find_last (DLL.last_cell body) + let find_last_instruction_id_and_pos t instructions = + let get instr = + let id = Instruction.id instr in + let pos = pos t id in + id, pos + in + let rec loop instructions last_id last_pos = + match instructions with + | [] -> last_id, last_pos + | hd :: tl -> + let hd_id, hd_pos = get hd in + if Int.compare hd_pos last_pos > 0 + then loop tl hd_id hd_pos + else loop tl last_id last_pos + in + let loop_non_empty instructions = + match instructions with + | [] -> assert false + | hd :: tl -> + let last_id, last_pos = get hd in + loop tl last_id last_pos + in + loop_non_empty instructions end (* CR-someday gyorsh: Dependencies computed below can be used for other @@ -638,6 +639,8 @@ module Dependencies : sig type t val first_memory_arg_index : t -> int + + val alignment_in_bytes : t -> int end end @@ -821,6 +824,8 @@ end = struct type t val first_memory_arg_index : t -> int + + val alignment_in_bytes : t -> int end module Dependencies : sig @@ -918,6 +923,8 @@ end = struct val first_memory_arg_index : t -> int + val alignment_in_bytes : t -> int + val get_instruction_id : t -> Instruction.Id.t (** [is_adjacent t1 t2] assumes that [t1] and [t2] have isomorphic operations, @@ -956,6 +963,9 @@ end = struct let first_memory_arg_index t = Memory_access.first_memory_arg_index t.memory_access + let alignment_in_bytes t = + Vectorize_utils.Memory_access.alignment_in_bytes t.memory_access + let get_instruction_id t = Instruction.id t.instruction let memory_access (instruction : Instruction.t) : Memory_access.t option = @@ -1004,7 +1014,12 @@ end = struct } in let first_memory_arg_index = - match op with Compare_and_swap -> 2 | Fetch_and_add -> 1 + match op with + | Compare_set -> 2 + | Fetch_and_add -> 1 + | Add | Sub | Land | Lor | Lxor -> 1 + | Exchange -> 1 + | Compare_exchange -> 2 in create ~first_memory_arg_index desc | Specific s -> Vectorize_specific.memory_access s @@ -1807,6 +1822,8 @@ end = struct let (new_node : Node.t) = Instruction.Id.Tbl.find t new_id in Instruction.Id.Set.union new_node.all_dependencies acc) init init + |> (* reflexivity *) + Instruction.Id.Set.add id in let node = { node with all_dependencies } in Instruction.Id.Tbl.add t id node @@ -2091,6 +2108,35 @@ end = struct in List.for_all is_isomorphic tl + let vectorizable_machtypes regs1 regs2 count = + let rec loop index = + if index = count + then true + else if Vectorize_utils.vectorizable_machtypes regs1.(index) + regs2.(index) + then loop (index + 1) + else false + in + loop 0 + + let vectorizable_machtypes ~non_address_arg_count instructions = + match instructions with + | [] -> true + | hd :: tl -> + (* assumes the instructions are isomorphic, which guarantees the same + number of result registers for all instructions, and the same number + of argument registers for all instructions. *) + let res_count = get_res_count hd in + let res = Instruction.results hd in + let arg = Instruction.arguments hd in + List.for_all + (fun instr -> + vectorizable_machtypes res (Instruction.results instr) res_count + && vectorizable_machtypes arg + (Instruction.arguments instr) + non_address_arg_count) + tl + let independent instructions deps = let res = Dependencies.all_independent deps instructions in State.dump_debug (Dependencies.state deps) "Group.independent: res=%b\n" @@ -2119,7 +2165,7 @@ end = struct = Simd_selection.vector_width_in_bits); Format.( State.dump_debug (Dependencies.state deps) "Group.init\n%a\n" - (pp_print_list ~pp_sep:pp_print_newline Instruction.print_id) + (pp_print_list ~pp_sep:pp_print_newline Instruction.print) instructions); match instructions with | [] -> assert false @@ -2127,29 +2173,36 @@ end = struct let arg_count = get_arg_count instruction in let res_count = get_res_count instruction in let mem_op = Dependencies.get_memory_operation deps instruction in + let non_address_arg_count = + match mem_op with + | None -> arg_count + | Some mem_op -> + Dependencies.Memory.Operation.first_memory_arg_index mem_op + in if not (same_stack_offset instructions && have_isomorphic_op instructions + && vectorizable_machtypes instructions ~non_address_arg_count && independent instructions deps && can_vectorize_memory_accesses mem_op instructions deps) then None else + let alignment_in_bytes = + Option.map Dependencies.Memory.Operation.alignment_in_bytes mem_op + in let cfg_ops = List.map (fun i -> i |> Instruction.op |> Option.get) instructions in let vector_instructions = Simd_selection.vectorize_operation width_in_bits ~arg_count - ~res_count cfg_ops + ~res_count ~alignment_in_bytes cfg_ops in match vector_instructions with - | None -> None + | None -> + State.dump_debug (Dependencies.state deps) + "Group.init: cannot vectorize operation\n"; + None | Some vector_instructions -> - let non_address_arg_count = - match mem_op with - | None -> arg_count - | Some mem_op -> - Dependencies.Memory.Operation.first_memory_arg_index mem_op - in assert (List.length vector_instructions > 0); Some { vector_instructions; @@ -2233,13 +2286,15 @@ end = struct | None -> None | Some op -> ( match op with - | Store (chunk, _, _) -> Some chunk + | Store (chunk, _, _) -> + Some (Vectorize_utils.Width_in_bits.of_memory_chunk chunk) + | Specific s -> Vectorize_specific.is_seed_store s | Alloc _ | Load _ | Move | Reinterpret_cast _ | Static_cast _ | Spill | Reload | Const_int _ | Const_float32 _ | Const_float _ | Const_symbol _ | Const_vec128 _ | Stackoffset _ | Intop _ | Intop_imm _ | Intop_atomic _ | Floatop _ | Csel _ | Probe_is_enabled _ - | Opaque | Begin_region | End_region | Specific _ | Name_for_debugger _ - | Dls_get | Poll -> + | Opaque | Begin_region | End_region | Name_for_debugger _ | Dls_get + | Poll -> None) let from_block (block : Block.t) deps : t list = @@ -2262,8 +2317,7 @@ end = struct DLL.fold_right body ~init:[] ~f:(fun i acc -> let i = Instruction.basic i in match is_store i with - | Some chunk -> - (Vectorize_utils.Width_in_bits.of_memory_chunk chunk, i) :: acc + | Some width -> (width, i) :: acc | None -> acc) in Format.( @@ -2328,12 +2382,16 @@ end = struct type t = { groups : Group.t Instruction.Id.Map.t; - (* [all_instructions] is all the scalar instructions in the computations. - It is an optimization to cache this value here. It is used for ruling - out computations that are invalid or not implementable, and to estimate - cost/benefit of vectorized computations. *) all_scalar_instructions : Instruction.Id.Set.t; - new_positions : int Instruction.Id.Map.t + (** [all_scalar_instructions] is all the scalar instructions in the + computations. It is an optimization to cache this value here. It is used + for ruling out computations that are invalid or not implementable, and to + estimate cost/benefit of vectorized computations. *) + new_positions : int Instruction.Id.Map.t; + (** [new_positions] is used for validation. *) + last_pos : int option + (** [last_pos] the position in the block body of the last scalar instruction, used + for heuristics. [None] for empty computations. *) } let num_groups t = Instruction.Id.Map.cardinal t.groups @@ -2575,19 +2633,31 @@ end = struct && respects_register_order_constraints t deps && not (is_dependency_of_outside_body t block deps) - (** The key is the last instruction id, for now. This is the place - where the vectorized intructions will be inserted. *) - let get_key block instruction_ids = - let last_instruction = Block.find_last_instruction block instruction_ids in - Instruction.id last_instruction + (** The key is the last instruction id, for now. This is the place in the body of the + block where the vectorized instructions will be inserted. *) + let get_key group block = + let id, _pos = + Block.find_last_instruction_id_and_pos block + (Group.scalar_instructions group) + in + id + + let get_last_pos group block = + let _id, pos = + Block.find_last_instruction_id_and_pos block + (Group.scalar_instructions group) + in + pos (** Returns the dependencies of arguments at position [arg_i] of each instruction in [instruction_ids]. Returns None if one of the instruction's dependencies is None for [arg_i]. *) - let get_deps deps ~arg_i instruction_ids = + let get_deps deps ~arg_i group = Misc.Stdlib.List.map_option - (Dependencies.get_direct_dependency_of_arg deps ~arg_i) - instruction_ids + (fun instruction -> + let id = Instruction.id instruction in + Dependencies.get_direct_dependency_of_arg deps ~arg_i id) + (Group.scalar_instructions group) let all_instructions map = Instruction.Id.Map.fold @@ -2617,7 +2687,8 @@ end = struct let empty = { groups = Instruction.Id.Map.empty; all_scalar_instructions = Instruction.Id.Set.empty; - new_positions = Instruction.Id.Map.empty + new_positions = Instruction.Id.Map.empty; + last_pos = None } (* CR gyorsh: if same instruction belongs to two groups, is it handled @@ -2632,10 +2703,7 @@ end = struct match group with | None -> None | Some (group : Group.t) -> ( - let instruction_ids = - Group.scalar_instructions group |> List.map Instruction.id - in - let key = get_key block instruction_ids in + let key = get_key group block in (* Is there another group with the same key already in the tree? If the key instruction of the group is already in another group, and the other group is different from this group, we won't vectorize this for @@ -2657,7 +2725,7 @@ end = struct (* CR-someday gyorsh: refer directly to [Reg.t] instead of positional [arg_i]. Currently, the code assumes that address args are always at the end. *) - match get_deps deps ~arg_i instruction_ids with + match get_deps deps ~arg_i group with | None -> (* At least one of the arguments has a dependency outside the block. Currently, not supported. *) @@ -2689,7 +2757,8 @@ end = struct let t = { groups = map; all_scalar_instructions = all_instructions map; - new_positions = new_positions map block + new_positions = new_positions map block; + last_pos = Some (get_last_pos root block) } in State.dump_debug (Block.state block) @@ -2697,6 +2766,12 @@ end = struct assert (seed_address_does_not_depend_on_tree t block deps seed); if is_valid t block deps then Some t else None + let max_pos o1 o2 = + match o1, o2 with + | Some p1, Some p2 -> Some (Int.max p1 p2) + | None, None -> None + | (Some _ as res), None | None, (Some _ as res) -> res + let join t1 t2 = { groups = Instruction.Id.Map.union @@ -2722,13 +2797,36 @@ end = struct pos2=%d" Instruction.Id.print key pos1 pos2; Some pos1) - t1.new_positions t2.new_positions + t1.new_positions t2.new_positions; + last_pos = max_pos t1.last_pos t2.last_pos } + (** address registers and vectorizable registers of [t] and [t'] are compatible, i.e., + register [r] used as an address argument in [t] is not replaced by a vectorizable + argument in [t'] and vice versa. *) + let register_compatible t t' deps = + let sub t1 t2 = + Instruction.Id.Map.for_all + (fun _key g1 -> + let scalar_instructions = Group.scalar_instructions g1 in + Group.for_all_non_vectorizable_args g1 ~f:(fun ~arg_i -> + List.for_all + (fun i -> + match + Dependencies.get_direct_dependency_of_arg deps + (Instruction.id i) ~arg_i + with + | None -> true + | Some dep -> not (contains_id t2 dep)) + scalar_instructions)) + t1.groups + in + sub t t' && sub t' t + (** [compatible t t'] returns true if for every group [g] in [t], and [g'] in [t'], [g] and [g'] are equal or have disjoint sets of scalar instructions. *) - let compatible t t' = + let instruction_compatible t t' = if Instruction.Id.Set.disjoint t.all_scalar_instructions t'.all_scalar_instructions then true @@ -2747,27 +2845,36 @@ end = struct (* disjoint groups: if the key is not in t2, then all insts are not in t2. *) List.for_all - (fun i -> - not - (Instruction.Id.Set.mem (Instruction.id i) - t2.all_scalar_instructions)) + (fun i -> not (contains t2 i)) (Group.scalar_instructions g1)) t1.groups in sub t t' && sub t' t + let compatible t t' deps = + instruction_compatible t t' && register_compatible t t' deps + let select_and_join trees block deps = match trees with | [] -> None | trees -> (* sort by cost, ascending *) let compare_cost t1 t2 = Int.compare (cost t1) (cost t2) in - let trees = List.sort compare_cost trees in + let compare_cost_and_last_pos t1 t2 = + let c = compare_cost t1 t2 in + if not (c = 0) + then c + else + (* heuristic to prioritize groups that appear later, it reduces the + chance they are a dependency of the rest of the body. *) + Int.neg (Option.compare Int.compare t1.last_pos t2.last_pos) + in + let trees = List.sort compare_cost_and_last_pos trees in let rec loop trees acc = match trees with | [] -> acc | hd :: tl -> - if compatible hd acc + if compatible hd acc deps then let new_acc = join hd acc in if compare_cost new_acc acc < 0 @@ -2821,9 +2928,15 @@ let augment_reg_map reg_map group = match pack with | [] -> () | hd :: tl -> ( + let packed_reg_typ = Vectorize_utils.vectorize_machtypes pack in match Substitution.get_reg_opt reg_map hd with - | None -> Substitution.fresh_reg_for_pack reg_map pack Vec128 + | None -> Substitution.fresh_reg_for_pack reg_map pack packed_reg_typ | Some old_reg_for_hd -> + if not (Cmm.equal_machtype_component old_reg_for_hd.typ packed_reg_typ) + then + Misc.fatal_errorf "Expected %a but got %a for pack %a)" + Printcmm.machtype_component packed_reg_typ Printreg.reg + old_reg_for_hd Printreg.reglist pack; (* other registers in the pack must be mapped in the same way as [hd]. *) List.iter @@ -2839,7 +2952,9 @@ let augment_reg_map reg_map group = Misc.fatal_errorf "augment_reg_map: %a is mapped to %a but %a is mapped to %a" Printreg.reg hd Printreg.reg old_reg_for_hd Printreg.reg reg - Printreg.reg old_reg) + Printreg.reg old_reg; + assert ( + Cmm.equal_machtype_component old_reg_for_hd.typ old_reg.typ)) tl) in (* only some of the args are vectorizable, but all results are vectorizable. *) @@ -2851,7 +2966,9 @@ let augment_reg_map reg_map group = let add_vector_instructions_for_group reg_map state group ~before:cell old_instruction = let vector_instructions = Computation.Group.vector_instructions group in - let key_instruction = Instruction.basic old_instruction in + let first_instruction = + Computation.Group.scalar_instructions group |> List.hd + in let new_regs : Reg.t Numbers.Int.Tbl.t = Numbers.Int.Tbl.create 2 in let get_new_reg n = match Numbers.Int.Tbl.find_opt new_regs n with @@ -2866,15 +2983,15 @@ let add_vector_instructions_for_group reg_map state group ~before:cell let get_register (simd_reg : Vectorize_utils.Vectorized_instruction.register) = match simd_reg with - | New n -> get_new_reg n + | New_Vec128 n -> get_new_reg n | Argument n -> - let original_reg = (Instruction.arguments key_instruction).(n) in + let original_reg = (Instruction.arguments first_instruction).(n) in Substitution.get_reg_exn reg_map original_reg | Result n -> - let original_reg = (Instruction.results key_instruction).(n) in + let original_reg = (Instruction.results first_instruction).(n) in Substitution.get_reg_exn reg_map original_reg | Original n -> - let original_reg = (Instruction.arguments key_instruction).(n) in + let original_reg = (Instruction.arguments first_instruction).(n) in original_reg in let desc = Cfg.Op simd_instruction.operation in diff --git a/backend/cfg_selectgen.ml b/backend/cfg_selectgen.ml index 885e6970c14..bb9e6a92120 100644 --- a/backend/cfg_selectgen.ml +++ b/backend/cfg_selectgen.ml @@ -264,7 +264,7 @@ class virtual selector_generic = | Cstatic_cast cast -> basic_op (Static_cast cast), args | Catomic { op; size } -> ( match op with - | Fetch_and_add -> + | Exchange | Fetch_and_add | Add | Sub | Land | Lor | Lxor -> let src, dst = two_args () in let dst_size = match size with @@ -272,8 +272,8 @@ class virtual selector_generic = | Thirtytwo -> Thirtytwo_signed in let addr, eloc = self#select_addressing dst_size dst in - basic_op (Intop_atomic { op = Fetch_and_add; size; addr }), [src; eloc] - | Compare_and_swap -> + basic_op (Intop_atomic { op; size; addr }), [src; eloc] + | Compare_set | Compare_exchange -> let compare_with, set_to, dst = three_args () in let dst_size = match size with @@ -281,7 +281,7 @@ class virtual selector_generic = | Thirtytwo -> Thirtytwo_signed in let addr, eloc = self#select_addressing dst_size dst in - ( basic_op (Intop_atomic { op = Compare_and_swap; size; addr }), + ( basic_op (Intop_atomic { op; size; addr }), [compare_with; set_to; eloc] )) | Cprobe { name; handler_code_sym; enabled_at_init } -> ( Terminator @@ -695,6 +695,7 @@ class virtual selector_generic = (fun reg -> match reg.Reg.typ with | Addr -> assert false + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" | Val | Int | Float | Vec128 | Float32 -> ()) src; self#insert_moves env src tmp_regs; diff --git a/backend/cmm.ml b/backend/cmm.ml index f055944d92f..6089f21b564 100644 --- a/backend/cmm.ml +++ b/backend/cmm.ml @@ -21,6 +21,7 @@ type machtype_component = Cmx_format.machtype_component = | Float | Vec128 | Float32 + | Valx2 type machtype = machtype_component array @@ -38,7 +39,7 @@ let typ_vec128 = [|Vec128|] (** [machtype_component]s are partially ordered as follows: - Addr Float32 Float Vec128 + Addr Float32 Float Vec128 Valx2 ^ | Val @@ -51,6 +52,7 @@ let typ_vec128 = [|Vec128|] then the result is treated as a derived pointer into the heap (i.e. [Addr]). (Such a result may not be live across any call site or a fatal compiler error will result.) + The order is used only in selection, Valx2 is generated after selection. *) let lub_component comp1 comp2 = @@ -76,6 +78,8 @@ let lub_component comp1 comp2 = Printf.eprintf "%d %d\n%!" (Obj.magic comp1) (Obj.magic comp2); (* Float unboxing code must be sure to avoid this case. *) assert false + | Valx2, _ | _, Valx2 -> + Misc.fatal_errorf "Unexpected machtype_component Valx2" let ge_component comp1 comp2 = match comp1, comp2 with @@ -99,6 +103,8 @@ let ge_component comp1 comp2 = | Float, Float32 -> Printf.eprintf "GE: %d %d\n%!" (Obj.magic comp1) (Obj.magic comp2); assert false + | Valx2, _ | _, Valx2 -> + Misc.fatal_error "Unexpected machtype_component Valx2" type exttype = | XInt @@ -155,7 +161,16 @@ type rec_flag = Nonrecursive | Recursive type prefetch_temporal_locality_hint = Nonlocal | Low | Moderate | High -type atomic_op = Fetch_and_add | Compare_and_swap +type atomic_op = + | Fetch_and_add + | Add + | Sub + | Land + | Lor + | Lxor + | Exchange + | Compare_set + | Compare_exchange type atomic_bitwidth = Thirtytwo | Sixtyfour | Word @@ -570,12 +585,14 @@ let equal_machtype_component (left : machtype_component) (right : machtype_compo | Float, Float -> true | Vec128, Vec128 -> true | Float32, Float32 -> true - | Val, (Addr | Int | Float | Vec128 | Float32) - | Addr, (Val | Int | Float | Vec128 | Float32) - | Int, (Val | Addr | Float | Vec128 | Float32) - | Float, (Val | Addr | Int | Vec128 | Float32) - | Vec128, (Val | Addr | Int | Float | Float32) - | Float32, (Val | Addr | Int | Float | Vec128) -> + | Valx2, Valx2 -> true + | Valx2, (Val | Addr | Int | Float | Vec128 | Float32) + | Val, (Addr | Int | Float | Vec128 | Float32 | Valx2) + | Addr, (Val | Int | Float | Vec128 | Float32 | Valx2) + | Int, (Val | Addr | Float | Vec128 | Float32 | Valx2) + | Float, (Val | Addr | Int | Vec128 | Float32 | Valx2) + | Vec128, (Val | Addr | Int | Float | Float32 | Valx2) + | Float32, (Val | Addr | Int | Float | Vec128 | Valx2) -> false let equal_exttype @@ -742,4 +759,4 @@ let caml_flambda2_invalid = "caml_flambda2_invalid" let is_val (m: machtype_component) = match m with | Val -> true - | Addr | Int | Float | Vec128 | Float32 -> false + | Addr | Int | Float | Vec128 | Float32 | Valx2 -> false diff --git a/backend/cmm.mli b/backend/cmm.mli index cfb84c1ba65..44ff34a53cd 100644 --- a/backend/cmm.mli +++ b/backend/cmm.mli @@ -22,6 +22,7 @@ type machtype_component = Cmx_format.machtype_component = | Float | Vec128 | Float32 + | Valx2 (* - [Val] denotes a valid OCaml value: either a pointer to the beginning of a heap block, an infix pointer if it is preceded by the correct @@ -112,7 +113,16 @@ type rec_flag = Nonrecursive | Recursive type prefetch_temporal_locality_hint = Nonlocal | Low | Moderate | High -type atomic_op = Fetch_and_add | Compare_and_swap +type atomic_op = + | Fetch_and_add + | Add + | Sub + | Land + | Lor + | Lxor + | Exchange + | Compare_set + | Compare_exchange type atomic_bitwidth = Thirtytwo | Sixtyfour | Word diff --git a/backend/cmm_builtins.ml b/backend/cmm_builtins.ml index 2cf1a9d638d..c90446e7202 100644 --- a/backend/cmm_builtins.ml +++ b/backend/cmm_builtins.ml @@ -139,7 +139,7 @@ let ext_pointer_prefetch ~is_write locality arg dbg = prefetch ~is_write locality (int_as_pointer arg dbg) dbg let native_pointer_cas size (arg1, arg2, arg3) dbg = - let op = Catomic { op = Compare_and_swap; size } in + let op = Catomic { op = Compare_set; size } in if_operation_supported op ~f:(fun () -> bind "set_to" arg3 (fun set_to -> bind "compare_with" arg2 (fun compare_with -> @@ -150,7 +150,7 @@ let ext_pointer_cas size (arg1, arg2, arg3) dbg = native_pointer_cas size (int_as_pointer arg1 dbg, arg2, arg3) dbg let bigstring_cas size (arg1, arg2, arg3, arg4) dbg = - let op = Catomic { op = Compare_and_swap; size } in + let op = Catomic { op = Compare_set; size } in if_operation_supported op ~f:(fun () -> bind "set_to" arg4 (fun set_to -> bind "compare_with" arg3 (fun compare_with -> diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 008dccb6706..db73669bde2 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -818,9 +818,10 @@ let box_float32 dbg mode exp = let unbox_float32 dbg = map_tail ~kind:Any (function - | Cop (Calloc _, [Cconst_natint (hdr, _); _ops; c], _) - when Nativeint.equal hdr boxedfloat32_header - || Nativeint.equal hdr boxedfloat32_local_header -> + | Cop (Calloc _, [Cconst_natint (hdr, _); Cconst_symbol (sym, _); c], _) + when (Nativeint.equal hdr boxedfloat32_header + || Nativeint.equal hdr boxedfloat32_local_header) + && String.equal sym.sym_name caml_float32_ops -> c | Cconst_symbol (s, _dbg) as cmm -> ( match Cmmgen_state.structured_constant_of_sym s.sym_name with @@ -1593,6 +1594,7 @@ module Extended_machtype_component = struct | Float -> Float | Vec128 -> Vec128 | Float32 -> Float32 + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" let to_machtype_component t : machtype_component = match t with @@ -1673,6 +1675,7 @@ let machtype_identifier t = | Float32 -> 'S' | Addr -> Misc.fatal_error "[Addr] is forbidden inside arity for generic functions" + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" in String.of_seq (Seq.map char_of_component (Array.to_seq t)) @@ -1778,15 +1781,11 @@ let make_alloc_generic ~block_kind ~mode dbg tag wordsize args fields and memory chunks" in let caml_alloc_func, caml_alloc_args = - match Config.runtime5, block_kind with - | true, Regular_block -> "caml_alloc_shr_check_gc", [wordsize; tag] - | false, Regular_block -> "caml_alloc", [wordsize; tag] - | true, Mixed_block { scannable_prefix } -> + match block_kind with + | Regular_block -> "caml_alloc_shr_check_gc", [wordsize; tag] + | Mixed_block { scannable_prefix } -> Mixed_block_support.assert_mixed_block_support (); "caml_alloc_mixed_shr_check_gc", [wordsize; tag; scannable_prefix] - | false, Mixed_block { scannable_prefix } -> - Mixed_block_support.assert_mixed_block_support (); - "caml_alloc_mixed", [wordsize; tag; scannable_prefix] in Clet ( VP.create id, @@ -3039,6 +3038,7 @@ let machtype_stored_size t = (fun cur c -> match (c : machtype_component) with | Addr -> Misc.fatal_error "[Addr] cannot be stored" + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" | Val | Int -> cur + 1 | Float -> cur + ints_per_float | Float32 -> @@ -3052,6 +3052,7 @@ let machtype_non_scanned_size t = (fun cur c -> match (c : machtype_component) with | Addr -> Misc.fatal_error "[Addr] cannot be stored" + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" | Val -> cur | Int -> cur + 1 | Float -> cur + ints_per_float @@ -3073,6 +3074,7 @@ let value_slot_given_machtype vs = match (c : machtype_component) with | Int | Float | Float32 | Vec128 -> true | Val -> false + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" | Addr -> assert false) vs in @@ -3100,6 +3102,7 @@ let read_from_closure_given_machtype t clos base_offset dbg = ( (non_scanned_pos + ints_per_vec128, scanned_pos), load Onetwentyeight_unaligned non_scanned_pos ) | Val -> (non_scanned_pos, scanned_pos + 1), load Word_val scanned_pos + | Valx2 -> Misc.fatal_error "Unexpected machtype_component Valx2" | Addr -> Misc.fatal_error "[Addr] cannot be read") (base_offset, base_offset + machtype_non_scanned_size t) (Array.to_list t) @@ -4108,7 +4111,7 @@ let atomic_load ~dbg (imm_or_ptr : Lambda.immediate_or_pointer) atomic = in Cop (mk_load_atomic memory_chunk, [atomic], dbg) -let atomic_exchange ~dbg atomic new_value = +let atomic_exchange_extcall ~dbg atomic ~new_value = Cop ( Cextcall { func = "caml_atomic_exchange"; @@ -4123,25 +4126,65 @@ let atomic_exchange ~dbg atomic new_value = [atomic; new_value], dbg ) +let atomic_exchange ~dbg (imm_or_ptr : Lambda.immediate_or_pointer) atomic + ~new_value = + match imm_or_ptr with + | Immediate -> + let op = Catomic { op = Exchange; size = Word } in + if Proc.operation_supported op + then Cop (op, [new_value; atomic], dbg) + else atomic_exchange_extcall ~dbg atomic ~new_value + | Pointer -> atomic_exchange_extcall ~dbg atomic ~new_value + +let atomic_arith ~dbg ~op ~untag ~ext_name atomic i = + let i = if untag then decr_int i dbg else i in + let op = Catomic { op; size = Word } in + if Proc.operation_supported op + then (* input is a tagged integer *) + Cop (op, [i; atomic], dbg) + else + Cop + ( Cextcall + { func = ext_name; + builtin = false; + returns = true; + effects = Arbitrary_effects; + coeffects = Has_coeffects; + ty = typ_int; + ty_args = []; + alloc = false + }, + [atomic; i], + dbg ) + let atomic_fetch_and_add ~dbg atomic i = - Cop - ( Cextcall - { func = "caml_atomic_fetch_add"; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty = typ_int; - ty_args = []; - alloc = false - }, - [atomic; i], - dbg ) + atomic_arith ~dbg ~untag:true ~op:Fetch_and_add + ~ext_name:"caml_atomic_fetch_add" atomic i -let atomic_compare_and_set ~dbg atomic ~old_value ~new_value = +let atomic_add ~dbg atomic i = + atomic_arith ~dbg ~untag:true ~op:Add ~ext_name:"caml_atomic_add" atomic i + |> return_unit dbg + +let atomic_sub ~dbg atomic i = + atomic_arith ~dbg ~untag:true ~op:Sub ~ext_name:"caml_atomic_sub" atomic i + |> return_unit dbg + +let atomic_land ~dbg atomic i = + atomic_arith ~dbg ~untag:false ~op:Land ~ext_name:"caml_atomic_land" atomic i + |> return_unit dbg + +let atomic_lor ~dbg atomic i = + atomic_arith ~dbg ~untag:false ~op:Lor ~ext_name:"caml_atomic_lor" atomic i + |> return_unit dbg + +let atomic_lxor ~dbg atomic i = + atomic_arith ~dbg ~untag:true ~op:Lxor ~ext_name:"caml_atomic_lxor" atomic i + |> return_unit dbg + +let atomic_compare_and_set_extcall ~dbg atomic ~old_value ~new_value = Cop ( Cextcall - { func = "caml_atomic_cas"; + { func = "caml_atomic_compare_set"; builtin = false; returns = true; effects = Arbitrary_effects; @@ -4153,7 +4196,21 @@ let atomic_compare_and_set ~dbg atomic ~old_value ~new_value = [atomic; old_value; new_value], dbg ) -let atomic_compare_exchange ~dbg atomic ~old_value ~new_value = +let atomic_compare_and_set ~dbg (imm_or_ptr : Lambda.immediate_or_pointer) + atomic ~old_value ~new_value = + match imm_or_ptr with + | Immediate -> + let op = Catomic { op = Compare_set; size = Word } in + if Proc.operation_supported op + then + (* Use a bind to ensure [tag_int] gets optimised. *) + bind "res" + (Cop (op, [old_value; new_value; atomic], dbg)) + (fun a2 -> tag_int a2 dbg) + else atomic_compare_and_set_extcall ~dbg atomic ~old_value ~new_value + | Pointer -> atomic_compare_and_set_extcall ~dbg atomic ~old_value ~new_value + +let atomic_compare_exchange_extcall ~dbg atomic ~old_value ~new_value = Cop ( Cextcall { func = "caml_atomic_compare_exchange"; @@ -4168,6 +4225,16 @@ let atomic_compare_exchange ~dbg atomic ~old_value ~new_value = [atomic; old_value; new_value], dbg ) +let atomic_compare_exchange ~dbg (imm_or_ptr : Lambda.immediate_or_pointer) + atomic ~old_value ~new_value = + match imm_or_ptr with + | Immediate -> + let op = Catomic { op = Compare_exchange; size = Word } in + if Proc.operation_supported op + then Cop (op, [old_value; new_value; atomic], dbg) + else atomic_compare_exchange_extcall ~dbg atomic ~old_value ~new_value + | Pointer -> atomic_compare_exchange_extcall ~dbg atomic ~old_value ~new_value + type even_or_odd = | Even | Odd diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index 76137bbcb56..d37fab4353d 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -982,13 +982,29 @@ val apply_function : val atomic_load : dbg:Debuginfo.t -> Lambda.immediate_or_pointer -> expression -> expression -val atomic_exchange : dbg:Debuginfo.t -> expression -> expression -> expression +val atomic_exchange : + dbg:Debuginfo.t -> + Lambda.immediate_or_pointer -> + expression -> + new_value:expression -> + expression val atomic_fetch_and_add : dbg:Debuginfo.t -> expression -> expression -> expression +val atomic_add : dbg:Debuginfo.t -> expression -> expression -> expression + +val atomic_sub : dbg:Debuginfo.t -> expression -> expression -> expression + +val atomic_land : dbg:Debuginfo.t -> expression -> expression -> expression + +val atomic_lor : dbg:Debuginfo.t -> expression -> expression -> expression + +val atomic_lxor : dbg:Debuginfo.t -> expression -> expression -> expression + val atomic_compare_and_set : dbg:Debuginfo.t -> + Lambda.immediate_or_pointer -> expression -> old_value:expression -> new_value:expression -> @@ -996,6 +1012,7 @@ val atomic_compare_and_set : val atomic_compare_exchange : dbg:Debuginfo.t -> + Lambda.immediate_or_pointer -> expression -> old_value:expression -> new_value:expression -> diff --git a/backend/debug/available_regs.ml b/backend/debug/available_regs.ml index a53675afebe..de8be5b6cc2 100644 --- a/backend/debug/available_regs.ml +++ b/backend/debug/available_regs.ml @@ -271,7 +271,7 @@ let rec available_regs (instr : M.instruction) ~all_regs_that_might_be_named let reg_is_of_type_addr = match (RD.reg reg).typ with | Addr -> true - | Val | Int | Float | Vec128 | Float32 -> false + | Val | Int | Float | Vec128 | Float32 | Valx2 -> false in if remains_available || (not (extend_live ())) diff --git a/backend/debug/reg_with_debug_info.ml b/backend/debug/reg_with_debug_info.ml index cb6d83a99d6..1315818e009 100644 --- a/backend/debug/reg_with_debug_info.ml +++ b/backend/debug/reg_with_debug_info.ml @@ -106,7 +106,7 @@ let location t = t.reg.loc let holds_pointer t = match t.reg.typ with - | Addr | Val -> true + | Addr | Val | Valx2 -> true | Int | Float | Float32 | Vec128 -> false let holds_non_pointer t = not (holds_pointer t) diff --git a/backend/dune b/backend/dune index a066b4b4b72..b131c0b5de0 100644 --- a/backend/dune +++ b/backend/dune @@ -12,29 +12,15 @@ ;* * ;************************************************************************** -(rule - (targets arch.ml arch.mli cfg_selection.ml CSE.ml proc.ml regalloc_stack_operands.ml reload.ml - selection.ml selection_utils.ml simd.ml simd_selection.ml simd_reload.ml simd_proc.ml - stack_check.ml - vectorize_specific.ml - ) - (mode fallback) - (deps (glob_files amd64/*.ml) - (glob_files amd64/*.mli) - (glob_files arm64/*.ml) - (glob_files arm64/*.mli)) - (action (bash "cp %{env:ARCH=amd64}/*.ml %{env:ARCH=amd64}/*.mli ."))) +(copy_files# "%{env:ARCH=amd64}/*.ml{,i}") (rule + (enabled_if (= %{env:ARCH=amd64} "arm64")) (targets emit.ml) (mode fallback) - (deps amd64/emit.mlp - arm64/emit.mlp) + (deps arm64/emit.mlp) (action (progn - (with-stdout-to contains-input-name - (bash "echo %{env:ARCH=amd64}/emit.mlp")) + (copy# arm64/emit.mlp contains-input-name) (with-stdout-to %{targets} - (progn - (bash "echo \\# 1 \\\"`cat contains-input-name`\\\"") - (bash "%{dep:../tools/cvt_emit.exe} < `cat contains-input-name`")))))) + (bash "cat contains-input-name | %{dep:../tools/cvt_emit.exe} "))))) diff --git a/backend/emitaux.ml b/backend/emitaux.ml index f1bc66e8bee..5aaf5241a2c 100644 --- a/backend/emitaux.ml +++ b/backend/emitaux.ml @@ -143,6 +143,11 @@ let is_long n = if n > 0x3FFF_FFFF then raise (Error (Stack_frame_way_too_large n)); n >= !Flambda_backend_flags.long_frames_threshold +let is_long_stack_index n = + let is_reg n = n land 1 = 1 in + (* allows negative reg offsets in runtime4 *) + if is_reg n && not Config.runtime5 then false else is_long n + let record_frame_descr ~label ~frame_size ~live_offset debuginfo = assert (frame_size land 3 = 0); let fd_long = @@ -150,7 +155,7 @@ let record_frame_descr ~label ~frame_size ~live_offset debuginfo = (* The checks below are redundant (if they fail, then frame size check above should have failed), but they make the safety of [emit_frame] clear. *) || is_long (List.length live_offset) - || List.exists is_long live_offset + || List.exists is_long_stack_index live_offset in if fd_long && not !Flambda_backend_flags.allow_long_frames then raise (Error (Stack_frame_too_large frame_size)); diff --git a/backend/interf.ml b/backend/interf.ml index 6de371f8926..d434d1a5670 100644 --- a/backend/interf.ml +++ b/backend/interf.ml @@ -23,7 +23,7 @@ let assert_no_collisions set = Misc.fatal_error "live set has physical register collisions" let assert_compatible src dst = - if not (Reg.types_are_compatible src dst) then + if not (Proc.types_are_compatible src dst) then Misc.fatal_errorf "found move between registers of incompatible types (%a to %a)" Printreg.reg src Printreg.reg dst diff --git a/backend/operation.ml b/backend/operation.ml index 5efe110eaab..d3f17a5cec6 100644 --- a/backend/operation.ml +++ b/backend/operation.ml @@ -123,9 +123,6 @@ let intcomp (comp : Simple_operation.integer_comparison) = | Isigned c -> Printf.sprintf " %ss " (Printcmm.integer_comparison c) | Iunsigned c -> Printf.sprintf " %su " (Printcmm.integer_comparison c) -let intop_atomic (op : Cmm.atomic_op) = - match op with Fetch_and_add -> " += " | Compare_and_swap -> " cas " - let intop (op : Simple_operation.integer_operation) = match op with | Iadd -> " + " @@ -173,7 +170,7 @@ let dump ppf op = | Intop op -> Format.fprintf ppf "intop %s" (intop op) | Intop_imm (op, n) -> Format.fprintf ppf "intop %s %d" (intop op) n | Intop_atomic { op; size = _; addr = _ } -> - Format.fprintf ppf "intop atomic %s" (intop_atomic op) + Format.fprintf ppf "intop atomic %s" (Printcmm.atomic_op op) | Floatop (Float64, op) -> Format.fprintf ppf "floatop %a" floatop op | Floatop (Float32, op) -> Format.fprintf ppf "float32op %a" floatop op | Csel _ -> Format.fprintf ppf "csel" diff --git a/backend/printcmm.ml b/backend/printcmm.ml index f7252048da1..dda568684e2 100644 --- a/backend/printcmm.ml +++ b/backend/printcmm.ml @@ -37,6 +37,7 @@ let machtype_component ppf (ty : machtype_component) = | Float -> fprintf ppf "float" | Vec128 -> fprintf ppf "vec128" | Float32 -> fprintf ppf "float32" + | Valx2 -> fprintf ppf "valx2" let machtype ppf mty = match Array.length mty with @@ -132,8 +133,15 @@ let temporal_locality = function | High -> "high" let atomic_op = function - | Fetch_and_add -> "fetch_and_add" - | Compare_and_swap -> "compare_and_swap" + | Fetch_and_add -> "xadd" + | Add -> "+=" + | Sub -> "-=" + | Land -> "&=" + | Lor -> "|=" + | Lxor -> "^=" + | Exchange -> "exchange" + | Compare_set -> "compare_set" + | Compare_exchange -> "compare_exchange" let phantom_defining_expr ppf defining_expr = match defining_expr with diff --git a/backend/printcmm.mli b/backend/printcmm.mli index f289c98bd1d..ea9f17b8680 100644 --- a/backend/printcmm.mli +++ b/backend/printcmm.mli @@ -27,6 +27,7 @@ val integer_comparison : Cmm.integer_comparison -> string val float_comparison : Cmm.float_comparison -> string val trap_action_list : formatter -> Cmm.trap_action list -> unit val chunk : Cmm.memory_chunk -> string +val atomic_op : Cmm.atomic_op -> string val atomic_bitwidth : Cmm.atomic_bitwidth -> string val operation : Debuginfo.t -> Cmm.operation -> string val expression : formatter -> Cmm.expression -> unit @@ -36,4 +37,4 @@ val phrase : formatter -> Cmm.phrase -> unit val temporal_locality : Cmm.prefetch_temporal_locality_hint -> string val print_codegen_options : formatter -> Cmm.codegen_option list -> unit val reinterpret_cast : Cmm.reinterpret_cast -> string -val static_cast : Cmm.static_cast -> string \ No newline at end of file +val static_cast : Cmm.static_cast -> string diff --git a/backend/printmach.ml b/backend/printmach.ml index 433b8ff5f1c..df60a6545bf 100644 --- a/backend/printmach.ml +++ b/backend/printmach.ml @@ -92,16 +92,28 @@ let operation' ?(print_reg = Printreg.reg) op arg ppf res = fprintf ppf "%a%s%a" reg arg.(0) (Simple_operation.string_of_integer_operation op) reg arg.(1) end | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (Simple_operation.string_of_integer_operation op) n - | Iintop_atomic {op = Compare_and_swap; size; addr} -> - fprintf ppf "lock cas %s[%a] ?%a %a" + | Iintop_atomic {op = Compare_set; size; addr} -> + fprintf ppf "lock compare_set %s[%a] ?%a %a" (Printcmm.atomic_bitwidth size) (Arch.print_addressing reg addr) (Array.sub arg 2 (Array.length arg - 2)) reg arg.(0) reg arg.(1) - | Iintop_atomic {op = Fetch_and_add; size; addr} -> - fprintf ppf "lock %s[%a] += %a" + | Iintop_atomic {op = Compare_exchange; size; addr} -> + fprintf ppf "lock compare_exchange %s[%a] ?%a %a" + (Printcmm.atomic_bitwidth size) + (Arch.print_addressing reg addr) (Array.sub arg 2 (Array.length arg - 2)) + reg arg.(0) reg arg.(1) + | Iintop_atomic {op = Exchange; size; addr} -> + fprintf ppf "lock exchange %s[%a] %a" (Printcmm.atomic_bitwidth size) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) + | Iintop_atomic {op = (Fetch_and_add | Add | Sub | Land | Lor | Lxor) as op; size; addr} -> + fprintf ppf "lock %s[%a] %s %a" + (Printcmm.atomic_bitwidth size) + (Arch.print_addressing reg addr) + (Array.sub arg 1 (Array.length arg - 1)) + (Printcmm.atomic_op op) + reg arg.(0) | Ifloatop (_, (Icompf _ | Iaddf | Isubf | Imulf | Idivf as op)) -> fprintf ppf "%a %a %a" reg arg.(0) Simple_operation.format_float_operation op reg arg.(1) | Ifloatop (_, (Inegf | Iabsf as op)) -> diff --git a/backend/printoperation.ml b/backend/printoperation.ml index cf7f0284906..66692ad7644 100644 --- a/backend/printoperation.ml +++ b/backend/printoperation.ml @@ -55,14 +55,28 @@ let operation ?(print_reg = Printreg.reg) (op : Operation.t) arg ppf res = fprintf ppf "%a%s%i" reg arg.(0) (Simple_operation.string_of_integer_operation op) n - | Intop_atomic { op = Compare_and_swap; size; addr } -> - fprintf ppf "lock cas %s[%a] ?%a %a" + | Intop_atomic { op = Compare_set; size; addr } -> + fprintf ppf "lock compare_set %s[%a] ?%a %a" (Printcmm.atomic_bitwidth size) (Arch.print_addressing reg addr) (Array.sub arg 2 (Array.length arg - 2)) reg arg.(0) reg arg.(1) - | Intop_atomic { op = Fetch_and_add; size; addr } -> - fprintf ppf "lock %s[%a] += %a" + | Intop_atomic + { op = (Fetch_and_add | Add | Sub | Land | Lor | Lxor) as op; size; addr } + -> + fprintf ppf "lock %s[%a] %s %a" + (Printcmm.atomic_bitwidth size) + (Arch.print_addressing reg addr) + (Array.sub arg 1 (Array.length arg - 1)) + (Printcmm.atomic_op op) reg arg.(0) + | Intop_atomic { op = Compare_exchange; size; addr } -> + fprintf ppf "lock compare_exchange %s[%a] ?%a %a" + (Printcmm.atomic_bitwidth size) + (Arch.print_addressing reg addr) + (Array.sub arg 2 (Array.length arg - 2)) + reg arg.(0) reg arg.(1) + | Intop_atomic { op = Exchange; size; addr } -> + fprintf ppf "lock exchange %s[%a] %a" (Printcmm.atomic_bitwidth size) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) diff --git a/backend/printreg.ml b/backend/printreg.ml index 68f7e51d670..36f7db868ee 100644 --- a/backend/printreg.ml +++ b/backend/printreg.ml @@ -43,6 +43,7 @@ let reg ppf r = | Int -> "I" | Float -> "F" | Vec128 -> "X" + | Valx2 -> "VV" | Float32 -> "S"); fprintf ppf "/%i" r.stamp; loc @@ -63,6 +64,8 @@ let regs' ?(print_reg = reg) ppf v = let regs ppf v = regs' ppf v +let reglist ppf l = Format.pp_print_list ~pp_sep:pp_print_space reg ppf l + let regset ppf s = let first = ref true in Set.iter diff --git a/backend/printreg.mli b/backend/printreg.mli index fa1979970b8..9857dcaf8a9 100644 --- a/backend/printreg.mli +++ b/backend/printreg.mli @@ -37,6 +37,8 @@ val regs : Format.formatter -> Reg.t array -> unit val regset : Format.formatter -> Reg.Set.t -> unit +val reglist : Format.formatter -> Reg.t list -> unit + val regsetaddr' : ?print_reg:(Format.formatter -> Reg.t -> unit) -> Format.formatter -> diff --git a/backend/proc.mli b/backend/proc.mli index 1727730d40e..25076a05566 100644 --- a/backend/proc.mli +++ b/backend/proc.mli @@ -25,6 +25,7 @@ val num_available_registers: int array val first_available_register: int array val register_name: Cmm.machtype_component -> int -> string val phys_reg: Cmm.machtype_component -> int -> Reg.t +val gc_regs_offset : Reg.t -> int val rotate_registers: bool val precolored_regs : unit -> Reg.Set.t @@ -35,6 +36,14 @@ val num_stack_slot_classes: int val stack_slot_class: Cmm.machtype_component -> int val stack_class_tag: int -> string +(* If two registers have compatible types then we allow moves between them. + Note that we never allow moves between different register classes or + stack slot classes, so the following must hold: + if [machtypes_are_compatible r1 r2] = true then + [register_class r1] = [register_class r2] + and [stack_class r1.typ] = [stack_class r2.typ]. *) +val types_are_compatible : Reg.t -> Reg.t -> bool + (* Calling conventions *) val loc_arguments: Cmm.machtype -> Reg.t array * int val loc_results_call: Cmm.machtype -> Reg.t array * int diff --git a/backend/reg.ml b/backend/reg.ml index 78077b04e78..a80f6211c68 100644 --- a/backend/reg.ml +++ b/backend/reg.ml @@ -193,18 +193,6 @@ let is_reg t = | Reg _ -> true | _ -> false -let size_of_contents_in_bytes t = - match t.typ with - | Vec128 -> Arch.size_vec128 - | Float -> Arch.size_float - | Float32 -> - assert (Arch.size_float = 8); - Arch.size_float / 2 - | Addr -> - assert (Arch.size_addr = Arch.size_int); - Arch.size_addr - | Int | Val -> Arch.size_int - let reset() = (* When reset() is called for the first time, the current stamp reflects all hard pseudo-registers that have been allocated by Proc, so @@ -346,15 +334,3 @@ let same left right = let compare left right = Int.compare left.stamp right.stamp - -(* Two registers have compatible types if we allow moves between them. - Note that we never allow moves between different register classes, so this - condition must be at least as strict as [class left = class right]. *) -let types_are_compatible left right = - match left.typ, right.typ with - | (Int | Val | Addr), (Int | Val | Addr) - | Float, Float - | Float32, Float32 - | Vec128, Vec128 -> - true - | (Int | Val | Addr | Float | Float32 | Vec128), _ -> false diff --git a/backend/reg.mli b/backend/reg.mli index 328f4e7e7a1..665132e1e4d 100644 --- a/backend/reg.mli +++ b/backend/reg.mli @@ -102,8 +102,6 @@ val name : t -> string val is_reg : t -> bool val is_stack : t -> bool -val size_of_contents_in_bytes : t -> int - module Set: Set.S with type elt = t module Map: Map.S with type key = t module Tbl: Hashtbl.S with type key = t @@ -124,7 +122,6 @@ val mark_visited : t -> unit val is_visited : t -> bool val clear_visited_marks : unit -> unit -val types_are_compatible : t -> t -> bool val same_phys_reg : t -> t -> bool val same_loc : t -> t -> bool val same : t -> t -> bool diff --git a/backend/regalloc/regalloc_irc_state.ml b/backend/regalloc/regalloc_irc_state.ml index 10bb8b23501..210462fa412 100644 --- a/backend/regalloc/regalloc_irc_state.ml +++ b/backend/regalloc/regalloc_irc_state.ml @@ -473,7 +473,7 @@ let[@inline] rec find_alias state reg = let[@inline] add_alias _state v u = (* We should never generate moves between registers of different types. Bit-casting operations have specific instructions. *) - if not (Reg.types_are_compatible v u) + if not (Proc.types_are_compatible v u) then fatal "trying to create an alias between %a and %a but they have incompatible \ diff --git a/backend/select_utils.ml b/backend/select_utils.ml index 6b56f570f3d..c3bc851ed43 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -156,7 +156,10 @@ let oper_result_type = function | Cstore (_c, _) -> typ_void | Cdls_get -> typ_val | Cprefetch _ -> typ_void - | Catomic _ -> typ_int + | Catomic + { op = Fetch_and_add | Compare_set | Exchange | Compare_exchange; _ } -> + typ_int + | Catomic { op = Add | Sub | Land | Lor | Lxor; _ } -> typ_void | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ | Ccmpi _ | Ccmpa _ | Ccmpf _ -> @@ -208,15 +211,22 @@ let oper_result_type = function (* Infer the size in bytes of the result of an expression whose evaluation may be deferred (cf. [emit_parts]). *) +(* [size_component] is placed here and not in [Cmm] to avoid cyclic + dependencies, because it uses [Arch]. *) let size_component : machtype_component -> int = function | Val | Addr -> Arch.size_addr - | Int -> Arch.size_int + | Int -> + assert (Int.equal Arch.size_int Arch.size_addr); + Arch.size_int | Float -> Arch.size_float | Float32 -> (* CR layouts v5.1: reconsider when float32 fields are efficiently packed. Note that packed float32# arrays are handled via a separate path. *) Arch.size_float | Vec128 -> Arch.size_vec128 + | Valx2 -> + assert (Int.equal (Arch.size_addr * 2) Arch.size_vec128); + Arch.size_vec128 let size_machtype mty = let size = ref 0 in @@ -784,6 +794,8 @@ class virtual ['env, 'op, 'instr] common_selector = (big)array operations are handled separately via cmm. *) Onetwentyeight_unaligned | Val | Addr | Int -> Word_val + | Valx2 -> + Misc.fatal_error "Unexpected machtype_component Valx2" in self#insert_debug env (self#make_store kind !a false) diff --git a/backend/selectgen.ml b/backend/selectgen.ml index ceaa15e626d..b14bca9c518 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -241,23 +241,28 @@ class virtual selector_generic = | Cdivf w, _ -> Ifloatop (w, Idivf), args | Creinterpret_cast cast, _ -> Ireinterpret_cast cast, args | Cstatic_cast cast, _ -> Istatic_cast cast, args - | Catomic { op = Fetch_and_add; size }, [src; dst] -> + | ( Catomic + { op = + (Exchange | Fetch_and_add | Add | Sub | Land | Lor | Lxor) as op; + size + }, + [src; dst] ) -> let dst_size = match size with | Word | Sixtyfour -> Word_int | Thirtytwo -> Thirtytwo_signed in let addr, eloc = self#select_addressing dst_size dst in - Iintop_atomic { op = Fetch_and_add; size; addr }, [src; eloc] - | Catomic { op = Compare_and_swap; size }, [compare_with; set_to; dst] -> + Iintop_atomic { op; size; addr }, [src; eloc] + | ( Catomic { op = (Compare_set | Compare_exchange) as op; size }, + [compare_with; set_to; dst] ) -> let dst_size = match size with | Word | Sixtyfour -> Word_int | Thirtytwo -> Thirtytwo_signed in let addr, eloc = self#select_addressing dst_size dst in - ( Iintop_atomic { op = Compare_and_swap; size; addr }, - [compare_with; set_to; eloc] ) + Iintop_atomic { op; size; addr }, [compare_with; set_to; eloc] | Cprobe { name; handler_code_sym; enabled_at_init }, _ -> Iprobe { name; handler_code_sym; enabled_at_init }, args | Cprobe_is_enabled { name }, _ -> Iprobe_is_enabled { name }, [] diff --git a/backend/vectorize_utils.ml b/backend/vectorize_utils.ml index f119306bbe8..7b0db469322 100644 --- a/backend/vectorize_utils.ml +++ b/backend/vectorize_utils.ml @@ -1,3 +1,5 @@ +[@@@ocaml.warning "+a-40-42"] + open Arch module Width_in_bits = struct @@ -72,11 +74,17 @@ module Memory_access = struct let desc t = t.desc let first_memory_arg_index t = t.first_memory_arg_index + + let alignment_in_bytes _t = + (* CR-someday gyorsh: propagate alignment of base address (such as + bigarray). Can be used to emit more efficient vector sequences, for + example, arithmetic operations with memory arguments (not stack). *) + Arch.size_int end module Vectorized_instruction = struct type register = - | New of int + | New_Vec128 of int | Argument of int | Result of int | Original of int @@ -95,3 +103,47 @@ module Vectorized_instruction = struct results = Array.init res_count (fun i -> Result i) } end + +let vectorizable_machtypes (r1 : Reg.t) (r2 : Reg.t) = + match r1.typ, r2.typ with + | Addr, _ | _, Addr -> + (* Register of type [Addr] can point into the middle of a heap block. It + must not be live across a GC as the pointer can be invalidated if the GC + moves the block. This information would be lost if we combined [Addr] + with another non-scannable type into [Vec128]. To correctly vectorize + [Addr], we could generalize [machtype], but for simplicity do not + vectorize [Addr]. *) + false + | (Vec128 | Valx2), (Val | Int | Float | Float32 | Vec128 | Valx2) + | (Val | Int | Float | Float32), (Vec128 | Valx2) -> + Misc.fatal_errorf "Unexpected vector machtype Vec128 or Valx2: %a %a" + Printreg.reg r1 Printreg.reg r2 + | Val, Val -> true + | Val, (Int | Float | Float32) | (Int | Float | Float32), Val -> false + | (Int | Float | Float32), (Int | Float | Float32) -> + (* It is safe to mix Float32, Float, and Int for the purpose of GC, because + they are not scannable. It may not be possible to vectorize the + operation. *) + true + +let vectorize_machtypes (pack : Reg.t list) : Cmm.machtype_component = + match pack with + | [] -> assert false + | hd :: tl -> ( + let can_vectorize = List.for_all (vectorizable_machtypes hd) tl in + if not can_vectorize + then + Misc.fatal_errorf "register pack with incompatible mach types:" + Printreg.reglist pack; + match hd.typ, List.length pack with + | Addr, _ -> Misc.fatal_errorf "Unexpected machtype for %a" Printreg.reg hd + | Float, 2 | Float32, 4 -> Vec128 + | Int, _ -> + (* [Int] may be used for int32, width should be correct by construction of + [Group]. *) + Vec128 + | Val, 2 -> Valx2 + | (Val | Float | Float32), n -> + Misc.fatal_errorf "Unexpected pack size %d for %a" n Printreg.reglist pack + | Vec128, _ | Valx2, _ -> + Misc.fatal_errorf "Unexpected machtype for %a" Printreg.reg hd) diff --git a/backend/vectorize_utils.mli b/backend/vectorize_utils.mli index 43e6961f35a..c32c0cf4365 100644 --- a/backend/vectorize_utils.mli +++ b/backend/vectorize_utils.mli @@ -53,13 +53,17 @@ module Memory_access : sig val desc : t -> desc val first_memory_arg_index : t -> int + + (** Base address of memory access [t] is guaranteed to be aligned to + at least [alignment_in_bytes t]. *) + val alignment_in_bytes : t -> int end module Vectorized_instruction : sig (** Registers used in vectorized instructions of one scalar instruction group. *) type register = - | New of int + | New_Vec128 of int (** The n-th new temporary register used in the vectorized instructions *) | Argument of int (** Vector version of the n-th argument's register of the scalar @@ -81,3 +85,13 @@ module Vectorized_instruction : sig val make_default : arg_count:int -> res_count:int -> Operation.t -> t end + +(** Given two registers of non-vector types, return true iff there exist a vector type + that can contain both of them. Currently distinguishes between [Val] and other + types. Mixing [Val] with non-Val in a vector is not yet supported. *) +val vectorizable_machtypes : Reg.t -> Reg.t -> bool + +val vectorize_machtypes : Reg.t list -> Cmm.machtype_component +(* CR-someday gyorsh: [vectorizable_machtypes] should take a [Reg.t list] + instead of a pair, to handle longer vectors, and to present a uniform + interface with [vectorize_machtypes]. *) diff --git a/backend/x86_ast.mli b/backend/x86_ast.mli index 2ed1d8d157d..659ea59cfac 100644 --- a/backend/x86_ast.mli +++ b/backend/x86_ast.mli @@ -331,6 +331,11 @@ type instruction = | LEA of arg * arg | LOCK_CMPXCHG of arg * arg | LOCK_XADD of arg * arg + | LOCK_ADD of arg * arg + | LOCK_SUB of arg * arg + | LOCK_AND of arg * arg + | LOCK_OR of arg * arg + | LOCK_XOR of arg * arg | LEAVE | MAXSD of arg * arg | MINSD of arg * arg diff --git a/backend/x86_binary_emitter.ml b/backend/x86_binary_emitter.ml index 2a694853b9d..9770e7906e7 100644 --- a/backend/x86_binary_emitter.ml +++ b/backend/x86_binary_emitter.ml @@ -1623,29 +1623,25 @@ let emit_LEA b dst src = Format.eprintf "lea src=%a dst=%a@." print_old_arg src print_old_arg dst; assert false -let emit_lock_cmpxchg b dst src = +let emit_lock_op ~ops b dst src = let rex, rm, reg = match (dst, src) with | ((Mem _ | Mem64_RIP _) as rm), Reg64 reg -> rexw, rm, rd_of_reg64 reg | ((Mem _ | Mem64_RIP _) as rm), Reg32 reg -> no_rex, rm, rd_of_reg64 reg | _ -> - Misc.fatal_errorf "lock cmpxchg src=%a dst=%a@." print_old_arg src print_old_arg dst + Misc.fatal_errorf "lock op src=%a dst=%a@." print_old_arg src print_old_arg dst in buf_int8 b 0xF0; - emit_mod_rm_reg b rex [ 0x0F; 0xB1 ] rm reg + emit_mod_rm_reg b rex ops rm reg -let emit_lock_xadd b dst src = - let rex, rm, reg = match (dst, src) with - | ((Mem _ | Mem64_RIP _) as rm), Reg64 reg -> - rexw, rm, rd_of_reg64 reg - | ((Mem _ | Mem64_RIP _) as rm), Reg32 reg -> - no_rex, rm, rd_of_reg64 reg - | _ -> - Misc.fatal_errorf "lock cmpxchg src=%a dst=%a@." print_old_arg src print_old_arg dst - in - buf_int8 b 0xF0; - emit_mod_rm_reg b rex [ 0x0F; 0xC1 ] rm reg +let emit_lock_cmpxchg = emit_lock_op ~ops:[ 0x0F; 0xB1 ] +let emit_lock_xadd = emit_lock_op ~ops:[ 0x0F; 0xC1 ] +let emit_lock_add = emit_lock_op ~ops:[ 0x01 ] +let emit_lock_sub = emit_lock_op ~ops:[ 0x29 ] +let emit_lock_and = emit_lock_op ~ops:[ 0x21 ] +let emit_lock_or = emit_lock_op ~ops:[ 0x09 ] +let emit_lock_xor = emit_lock_op ~ops:[ 0x31 ] let emit_stack_reg b opcode dst = match dst with @@ -1900,6 +1896,11 @@ let assemble_instr b loc = function | LEA (src, dst) -> emit_LEA b dst src | LOCK_CMPXCHG (src, dst) -> emit_lock_cmpxchg b dst src | LOCK_XADD (src, dst) -> emit_lock_xadd b dst src + | LOCK_ADD (src, dst) -> emit_lock_add b dst src + | LOCK_SUB (src, dst) -> emit_lock_sub b dst src + | LOCK_AND (src, dst) -> emit_lock_and b dst src + | LOCK_OR (src, dst) -> emit_lock_or b dst src + | LOCK_XOR (src, dst) -> emit_lock_xor b dst src | MAXSD (src, dst) -> emit_maxsd b ~dst ~src | MINSD (src, dst) -> emit_minsd b ~dst ~src | MOV (src, dst) -> emit_MOV b dst src diff --git a/backend/x86_dsl.ml b/backend/x86_dsl.ml index b8fc6aa16be..083d06f6aef 100644 --- a/backend/x86_dsl.ml +++ b/backend/x86_dsl.ml @@ -154,6 +154,11 @@ module I = struct let lea x y = emit (LEA (x, y)) let lock_cmpxchg x y = emit (LOCK_CMPXCHG (x, y)) let lock_xadd x y = emit (LOCK_XADD (x, y)) + let lock_add x y = emit (LOCK_ADD (x, y)) + let lock_sub x y = emit (LOCK_SUB (x, y)) + let lock_and x y = emit (LOCK_AND (x, y)) + let lock_or x y = emit (LOCK_OR (x, y)) + let lock_xor x y = emit (LOCK_XOR (x, y)) let maxsd x y = emit (MAXSD (x,y)) let minsd x y = emit (MINSD (x,y)) let mov x y = emit (MOV (x, y)) diff --git a/backend/x86_dsl.mli b/backend/x86_dsl.mli index 9016c47d052..5f205ad453d 100644 --- a/backend/x86_dsl.mli +++ b/backend/x86_dsl.mli @@ -158,6 +158,11 @@ module I : sig val lea: arg -> arg -> unit val lock_cmpxchg: arg -> arg -> unit val lock_xadd: arg -> arg -> unit + val lock_add: arg -> arg -> unit + val lock_sub: arg -> arg -> unit + val lock_and: arg -> arg -> unit + val lock_or: arg -> arg -> unit + val lock_xor: arg -> arg -> unit val maxsd: arg -> arg -> unit val minsd: arg -> arg -> unit val mov: arg -> arg -> unit diff --git a/backend/x86_gas.ml b/backend/x86_gas.ml index 102c2bda269..fa90d9ee69c 100644 --- a/backend/x86_gas.ml +++ b/backend/x86_gas.ml @@ -158,6 +158,11 @@ let print_instr b = function | LEA (arg1, arg2) -> i2_s b "lea" arg1 arg2 | LOCK_CMPXCHG (arg1, arg2) -> i2_sx b "lock cmpxchg" arg1 arg2 | LOCK_XADD (arg1, arg2) -> i2_sx b "lock xadd" arg1 arg2 + | LOCK_ADD (arg1, arg2) -> i2_sx b "lock add" arg1 arg2 + | LOCK_SUB (arg1, arg2) -> i2_sx b "lock sub" arg1 arg2 + | LOCK_AND (arg1, arg2) -> i2_sx b "lock and" arg1 arg2 + | LOCK_OR (arg1, arg2) -> i2_sx b "lock or" arg1 arg2 + | LOCK_XOR (arg1, arg2) -> i2_sx b "lock xor" arg1 arg2 | LEAVE -> i0 b "leave" | MAXSD (arg1, arg2) -> i2 b "maxsd" arg1 arg2 | MINSD (arg1, arg2) -> i2 b "minsd" arg1 arg2 diff --git a/backend/x86_masm.ml b/backend/x86_masm.ml index f0476999a7b..13e9c2b2760 100644 --- a/backend/x86_masm.ml +++ b/backend/x86_masm.ml @@ -157,6 +157,11 @@ let print_instr b = function | LEA (arg1, arg2) -> i2 b "lea" arg1 arg2 | LOCK_CMPXCHG (arg1, arg2) -> i2 b "lock cmpxchg" arg1 arg2 | LOCK_XADD (arg1, arg2) -> i2 b "lock xadd" arg1 arg2 + | LOCK_ADD (arg1, arg2) -> i2 b "lock add" arg1 arg2 + | LOCK_SUB (arg1, arg2) -> i2 b "lock sub" arg1 arg2 + | LOCK_AND (arg1, arg2) -> i2 b "lock and" arg1 arg2 + | LOCK_OR (arg1, arg2) -> i2 b "lock or" arg1 arg2 + | LOCK_XOR (arg1, arg2) -> i2 b "lock xor" arg1 arg2 | LEAVE -> i0 b "leave" | MAXSD (arg1, arg2) -> i2 b "maxsd" arg1 arg2 | MINSD (arg1, arg2) -> i2 b "minsd" arg1 arg2 diff --git a/build-aux/ocaml_version.m4 b/build-aux/ocaml_version.m4 index 4f1ec972e6f..ffed958f2e7 100644 --- a/build-aux/ocaml_version.m4 +++ b/build-aux/ocaml_version.m4 @@ -97,7 +97,7 @@ m4_define([OCAML__RELEASE_EXTRA], # - A 3-bytes version number m4_define([MAGIC_NUMBER__PREFIX], [Caml1999]) -m4_define([MAGIC_NUMBER__VERSION], [554]) +m4_define([MAGIC_NUMBER__VERSION], [555]) # The following macro is used to define all our magic numbers # Its first argument is the name of the file type described by that diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 3766aa0315d..07d8b3aeded 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -158,6 +158,7 @@ let preserve_tailcall_for_prim = function | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pufloatfield _ | Psetufloatfield _ | Pmixedfield _ | Psetmixedfield _ | Pmake_unboxed_product _ | Punboxed_product_field _ + | Parray_element_size_in_bytes _ | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat _ @@ -195,10 +196,12 @@ let preserve_tailcall_for_prim = function | Pbigstring_set_64 _ | Pbigstring_set_128 _ | Pprobe_is_enabled _ | Pobj_dup | Pctconst _ | Pbswap16 | Pbbswap _ | Pint_as_pointer _ - | Patomic_exchange | Patomic_compare_exchange - | Patomic_cas | Patomic_fetch_add | Patomic_load _ + | Patomic_exchange _ | Patomic_compare_exchange _ + | Patomic_compare_set _ | Patomic_fetch_add | Patomic_add + | Patomic_sub | Patomic_land | Patomic_lor + | Patomic_lxor | Patomic_load _ | Pdls_get | Preinterpret_tagged_int63_as_unboxed_int64 - | Preinterpret_unboxed_int64_as_tagged_int63 | Ppoll -> + | Preinterpret_unboxed_int64_as_tagged_int63 | Ppoll | Ppeek _ | Ppoke _ -> false (* Add a Kpop N instruction in front of a continuation *) @@ -415,6 +418,8 @@ let comp_primitive stack_info p sz args = | Pcompare_bints bi -> comp_bint_primitive bi "compare" args | Pfield (n, _ptr, _sem) -> Kgetfield n | Punboxed_product_field (n, _layouts) -> Kgetfield n + | Parray_element_size_in_bytes _array_kind -> + Kconst (Const_base (Const_int (Sys.word_size / 8))) | Pfield_computed _sem -> Kgetvectitem | Psetfield(n, _ptr, _init) -> Ksetfield n | Psetfield_computed(_ptr, _init) -> Ksetvectitem @@ -589,7 +594,6 @@ let comp_primitive stack_info p sz args = | Runtime5 -> "runtime5" in Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1) | Pisint _ -> Kisint - | Pisnull -> Misc.fatal_error "null not implemented in bytecode" (* CR layouts v3: support null in bytecode *) | Pisout -> Kisout | Pbintofint (bi,_) -> comp_bint_primitive bi "of_int" args | Pintofbint bi -> comp_bint_primitive bi "to_int" args @@ -653,12 +657,18 @@ let comp_primitive stack_info p sz args = | Pget_header _ -> Kccall("caml_get_header", 1) | Pobj_dup -> Kccall("caml_obj_dup", 1) | Patomic_load _ -> Kccall("caml_atomic_load", 1) - | Patomic_exchange -> Kccall("caml_atomic_exchange", 2) - | Patomic_compare_exchange -> Kccall("caml_atomic_compare_exchange", 3) - | Patomic_cas -> Kccall("caml_atomic_cas", 3) + | Patomic_exchange _ -> Kccall("caml_atomic_exchange", 2) + | Patomic_compare_exchange _ -> Kccall("caml_atomic_compare_exchange", 3) + | Patomic_compare_set _ -> Kccall("caml_atomic_compare_set", 3) | Patomic_fetch_add -> Kccall("caml_atomic_fetch_add", 2) + | Patomic_add -> Kccall("caml_atomic_add", 2) + | Patomic_sub -> Kccall("caml_atomic_sub", 2) + | Patomic_land -> Kccall("caml_atomic_land", 2) + | Patomic_lor -> Kccall("caml_atomic_lor", 2) + | Patomic_lxor -> Kccall("caml_atomic_lxor", 2) | Pdls_get -> Kccall("caml_domain_dls_get", 1) | Ppoll -> Kccall("caml_process_pending_actions_with_root", 1) + | Pisnull -> Kccall("caml_is_null", 1) | Pstring_load_128 _ | Pbytes_load_128 _ | Pbytes_set_128 _ | Pbigstring_load_128 _ | Pbigstring_set_128 _ | Pfloatarray_load_128 _ | Pfloat_array_load_128 _ | Pint_array_load_128 _ @@ -685,7 +695,10 @@ let comp_primitive stack_info p sz args = "Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \ targets"; Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1) - | Pmakearray_dynamic(kind, locality) -> + | Pmakearray_dynamic(kind, locality, With_initializer) -> + if List.compare_length_with args 2 <> 0 then + fatal_error "Bytegen.comp_primitive: Pmakearray_dynamic takes two \ + arguments for [With_initializer]"; (* CR layouts v4.0: This is "wrong" for unboxed types. It should construct blocks that can't be marshalled. We've decided to ignore that problem in the short term, as it's unlikely to cause issues - see the internal arrays @@ -701,8 +714,8 @@ let comp_primitive stack_info p sz args = | Alloc_heap -> Kccall("caml_make_vect", 2) | Alloc_local -> Kccall("caml_make_local_vect", 2) end - | Parrayblit(kind) -> - begin match kind with + | Parrayblit { src_mutability = _; dst_array_set_kind } -> + begin match dst_array_set_kind with | Punboxedvectorarray_set _ -> fatal_error "SIMD is not supported in bytecode mode." | Pgenarray_set _ | Pintarray_set | Paddrarray_set _ @@ -710,6 +723,9 @@ let comp_primitive stack_info p sz args = | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _ -> () end; Kccall("caml_array_blit", 5) + | Pmakearray_dynamic(_, _, Uninitialized) -> + Misc.fatal_error "Pmakearray_dynamic Uninitialized should have been \ + translated to Pmakearray_dynamic Initialized earlier on" (* The cases below are handled in [comp_expr] before the [comp_primitive] call (in the order in which they appear below), so they should never be reached in this function. *) @@ -728,6 +744,8 @@ let comp_primitive stack_info p sz args = | Punbox_float _ | Pbox_float (_, _) | Punbox_int _ | Pbox_int _ -> fatal_error "Bytegen.comp_primitive" + | Ppeek _ | Ppoke _ -> + fatal_error "Bytegen.comp_primitive: Ppeek/Ppoke not supported in bytecode" let is_immed n = immed_min <= n && n <= immed_max @@ -1011,6 +1029,54 @@ and comp_expr stack_info env exp sz cont = (Kreperformterm(sz + nargs) :: discard_dead_code cont) else fatal_error "Reperform used in non-tail position" + | Lprim (Pmakearray_dynamic (kind, locality, Uninitialized), [len], loc) -> + (* Use a dummy initializer to implement the "uninitialized" primitive *) + let init = + match kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray + | Pgcscannableproductarray _ -> + Misc.fatal_errorf "Array kind %s should have been ruled out by \ + the frontend for %%makearray_dynamic_uninit" + (Printlambda.array_kind kind) + | Punboxedfloatarray Unboxed_float32 -> + Lconst (Const_base (Const_float32 "0.0")) + | Punboxedfloatarray Unboxed_float64 -> + Lconst (Const_base (Const_float "0.0")) + | Punboxedintarray Unboxed_int32 -> + Lconst (Const_base (Const_int32 0l)) + | Punboxedintarray Unboxed_int64 -> + Lconst (Const_base (Const_int64 0L)) + | Punboxedintarray Unboxed_nativeint -> + Lconst (Const_base (Const_nativeint 0n)) + | Punboxedvectorarray _ -> + fatal_error "SIMD is not supported in bytecode mode." + | Pgcignorableproductarray ignorables -> + let rec convert_ignorable + (ign : Lambda.ignorable_product_element_kind) = + match ign with + | Pint_ignorable -> Lconst (Const_base (Const_int 0)) + | Punboxedfloat_ignorable Unboxed_float32 -> + Lconst (Const_base (Const_float32 "0.0")) + | Punboxedfloat_ignorable Unboxed_float64 -> + Lconst (Const_base (Const_float "0.0")) + | Punboxedint_ignorable Unboxed_int32 -> + Lconst (Const_base (Const_int32 0l)) + | Punboxedint_ignorable Unboxed_int64 -> + Lconst (Const_base (Const_int64 0L)) + | Punboxedint_ignorable Unboxed_nativeint -> + Lconst (Const_base (Const_nativeint 0n)) + | Pproduct_ignorable ignorables -> + let fields = List.map convert_ignorable ignorables in + Lprim (Pmakeblock (0, Immutable, None, alloc_heap), fields, + loc) + in + convert_ignorable (Pproduct_ignorable ignorables) + in + comp_expr stack_info env + (Lprim (Pmakearray_dynamic (kind, locality, With_initializer), + [len; init], loc)) sz cont + | Lprim (Pmakearray_dynamic (_, _, Uninitialized), _, _loc) -> + Misc.fatal_error "Pmakearray_dynamic takes one arg when [Uninitialized]" | Lprim (Pduparray (kind, mutability), [Lprim (Pmakearray (kind',_,m),args,_)], loc) -> assert (kind = kind'); diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 9e43ec781eb..9a72a086eb3 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -272,6 +272,8 @@ let patch_object buff patchlist = external float32_is_stage1 : unit -> bool = "caml_float32_is_stage1" external float32_of_string : string -> Obj.t = "caml_float32_of_string" +external int_as_pointer : int -> Obj.t = "%int_as_pointer" + let rec transl_const = function Const_base(Const_int i) -> Obj.repr i | Const_base(Const_char c) -> Obj.repr c @@ -308,8 +310,7 @@ let rec transl_const = function List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f)) fields; Obj.repr res - | Const_null -> Misc.fatal_error "[Const_null] not supported in bytecode." - (* CR layouts v3: add bytecode support. *) + | Const_null -> int_as_pointer 0 (* Build the initial table of globals *) diff --git a/configure.ac b/configure.ac index 4bc8e5f0c32..ce7de2cc9d7 100644 --- a/configure.ac +++ b/configure.ac @@ -357,8 +357,6 @@ AC_SUBST([mkexe_ldflags_exp]) AC_SUBST([PACKLD]) AC_SUBST([build_libraries_manpages]) AC_SUBST([compute_deps]) -AC_SUBST([naked_pointers]) -AC_SUBST([naked_pointers_checker]) AC_SUBST([intel_jcc_bug_cflags]) AC_SUBST([stack_allocation]) AC_SUBST([poll_insertion]) @@ -585,9 +583,10 @@ AC_ARG_ENABLE([cpp-mangling], [AS_HELP_STRING([--enable-cpp-mangling], [use cpp mangling for exported symbols])]) -AC_ARG_ENABLE([naked-pointers], - [AS_HELP_STRING([--disable-naked-pointers], - [do not allow naked pointers])]) +AC_ARG_ENABLE([naked-pointers], [], + [AS_IF([test "x$enableval" != 'xno'], + [AC_MSG_ERROR([Naked pointers were prohibited in OCaml 5.0.])])], + []) AC_ARG_ENABLE([naked-pointers-checker], [], [AS_IF([test "x$enableval" != 'xno'], @@ -2640,30 +2639,6 @@ AS_IF([test x"$enable_cpp_mangling" = "xyes"], AC_DEFINE([WITH_CPP_MANGLING])], [cpp_mangling=false]) -## No naked pointers - -AS_IF([test x"$enable_naked_pointers" = "xno" ], - [naked_pointers=false - AC_DEFINE([NO_NAKED_POINTERS])], - [naked_pointers=true]) - -AS_IF([test x"$enable_naked_pointers_checker" = "xyes" ], - [AS_IF([test x"$enable_naked_pointers" = "xno" ], - [AC_MSG_ERROR(m4_normalize([ - --enable-naked-pointers-checker and --disable-naked-pointers - are incompatible]))]) - AS_CASE(["$arch","$system"], - [amd64,linux|amd64,macosx \ - |amd64,openbsd|amd64,win64 \ - |amd64,freebsd|amd64,solaris \ - |arm64,linux|arm64,macosx], - [naked_pointers_checker=true - AC_DEFINE([NAKED_POINTERS_CHECKER])], - [*], - [AC_MSG_ERROR([naked pointers checker not supported on this platform])] - )], - [naked_pointers_checker=false]) - ## Check for mmap support for huge pages and contiguous heap OCAML_MMAP_SUPPORTS_HUGE_PAGES diff --git a/driver/compile_common.ml b/driver/compile_common.ml index 5aa113d4b32..94d95a581ae 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -31,6 +31,7 @@ type compilation_unit_or_inferred = let with_info ~native ~tool_name ~source_file ~output_prefix ~compilation_unit ~dump_ext k = Compmisc.init_path (); + Compmisc.init_parameters (); let target = Unit_info.make ~source_file output_prefix in let compilation_unit = match compilation_unit with diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 3be9cbe8e8a..623b06254c8 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -55,6 +55,18 @@ let init_path ?(auto_include=auto_include) ?(dir="") () = Load_path.init ~auto_include ~visible ~hidden; Env.reset_cache ~preserve_persistent_env:false +(* Read any [-parameters] flags. Important to do this before [initial_env ()] + because someone might [-open] a parameterised module *) +let init_parameters () = + let param_names = !Clflags.parameters in + List.iter + (fun param_name -> + (* We don't (yet!) support parameterised parameters *) + let param = Global_module.Name.create_no_args param_name in + Env.register_parameter param + ) + param_names + (* Return the initial environment in which compilation proceeds. *) (* Note: do not do init_path() in initial_env, this breaks diff --git a/driver/compmisc.mli b/driver/compmisc.mli index 39669dcfcba..2415bfab8ed 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -15,6 +15,7 @@ val init_path : ?auto_include:Load_path.auto_include_callback -> ?dir:string -> unit -> unit +val init_parameters : unit -> unit val initial_env : unit -> Env.t (* Support for flags that can also be set from an environment variable *) diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml index 44ade683f79..1e2458562dd 100644 --- a/driver/flambda_backend_args.ml +++ b/driver/flambda_backend_args.ml @@ -1365,6 +1365,7 @@ module Extra_params = struct | "regalloc-param" -> add_string Flambda_backend_flags.regalloc_params | "regalloc-validate" -> set' Flambda_backend_flags.regalloc_validate | "vectorize" -> set' Flambda_backend_flags.vectorize + | "dump-vectorize" -> set' Flambda_backend_flags.dump_vectorize | "vectorize-max-block-size" -> set_int' Flambda_backend_flags.vectorize_max_block_size | "cfg-selection" -> set' Flambda_backend_flags.cfg_selection | "cfg-peephole-optimize" -> set' Flambda_backend_flags.cfg_peephole_optimize diff --git a/driver/main_args.ml b/driver/main_args.ml index 4c91a64bf60..1cfa5767114 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -480,6 +480,11 @@ let mk_runtime_variant f = "-runtime-variant", Arg.String f, " Use the variant of the run-time system" +let mk_ocamlrunparam f = + "-ocamlrunparam", Arg.String f, + " Use the given OCAMLRUNPARAM settings as the default (ignored \ + except when linking an executable)" + let mk_with_runtime f = "-with-runtime", Arg.Unit f, "Include the runtime system in the generated program (default)" @@ -1050,6 +1055,7 @@ module type Compiler_options = sig val _no_principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _ocamlrunparam : string -> unit val _with_runtime : unit -> unit val _without_runtime : unit -> unit val _short_paths : unit -> unit @@ -1542,6 +1548,7 @@ struct mk_remove_unused_arguments F._remove_unused_arguments; mk_rounds F._rounds; mk_runtime_variant F._runtime_variant; + mk_ocamlrunparam F._ocamlrunparam; mk_with_runtime F._with_runtime; mk_without_runtime F._without_runtime; mk_S F._S; @@ -2091,6 +2098,7 @@ module Default = struct let _plugin _p = plugin := true let _pp s = preprocessor := (Some s) let _runtime_variant s = runtime_variant := s + let _ocamlrunparam s = ocamlrunparam := s let _stop_after pass = let module P = Compiler_pass in match P.of_string pass with diff --git a/driver/main_args.mli b/driver/main_args.mli index be6e7d751f5..451e8c4a627 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -128,6 +128,7 @@ module type Compiler_options = sig val _no_principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _ocamlrunparam : string -> unit val _with_runtime : unit -> unit val _without_runtime : unit -> unit val _short_paths : unit -> unit diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli index 58a20a23a04..d5adad2771c 100644 --- a/file_formats/cmx_format.mli +++ b/file_formats/cmx_format.mli @@ -32,7 +32,7 @@ open Misc of these infos *) (* Declare machtype here to avoid depending on [Cmm]. *) -type machtype_component = Val | Addr | Int | Float | Vec128 | Float32 +type machtype_component = Val | Addr | Int | Float | Vec128 | Float32 | Valx2 type machtype = machtype_component array (* [alloc_mode] should be isomorphic to [Cmm.Alloc_mode.t], diff --git a/flambda-backend/tests/backend/vectorizer/.ocamlformat-ignore b/flambda-backend/tests/backend/vectorizer/.ocamlformat-ignore new file mode 100644 index 00000000000..7ddec40dced --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/.ocamlformat-ignore @@ -0,0 +1,4 @@ +test_int64_unboxed.ml +test_float_unboxed.ml +test_int32_unboxed.ml +test_float32_unboxed.ml diff --git a/flambda-backend/tests/backend/vectorizer/dune.inc b/flambda-backend/tests/backend/vectorizer/dune.inc index 64efbe74dc1..1673ef0acb7 100644 --- a/flambda-backend/tests/backend/vectorizer/dune.inc +++ b/flambda-backend/tests/backend/vectorizer/dune.inc @@ -4,7 +4,7 @@ (enabled_if (= %{context_name} "main")) (targets test1_runner.exe test1.cmx.dump) (deps test1.mli test1.ml) - (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -no-vectorize -o test1_runner.exe))) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test1_runner.exe))) (rule (alias runtest) @@ -37,7 +37,7 @@ (enabled_if (= %{context_name} "main")) (targets test1_vectorized_runner.exe test1_vectorized.cmx.dump) (deps test1_vectorized.mli test1_vectorized.ml) - (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize -o test1_vectorized_runner.exe))) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test1_vectorized_runner.exe))) (rule (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) @@ -46,7 +46,8 @@ (action (with-outputs-to %{target} - (run %{deps})))) + (with-accepted-exit-codes 0 + (run %{deps}))))) (rule (alias runtest) @@ -73,3 +74,687 @@ (enabled_if (= %{context_name} "main")) (action (diff test1_vectorized.expected test1_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_arrays_runner.exe test_arrays.cmx.dump) + (deps test_arrays.mli test_arrays.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_arrays_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_arrays.output + (run ./test_arrays_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_arrays.expected test_arrays.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_arrays.ml test_arrays_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_arrays.mli test_arrays_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_arrays_vectorized_runner.exe test_arrays_vectorized.cmx.dump) + (deps test_arrays_vectorized.mli test_arrays_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_arrays_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_arrays_vectorized.cmx.dump.output) + (deps ./filter.sh test_arrays_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_arrays_vectorized.cmx.dump.expected test_arrays_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_arrays_vectorized.output + (run ./test_arrays_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_arrays.expected test_arrays_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_arrays_vectorized.expected test_arrays_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_int64_unboxed_runner.exe test_int64_unboxed.cmx.dump) + (deps test_int64_unboxed.mli test_int64_unboxed.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_int64_unboxed_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_int64_unboxed.output + (run ./test_int64_unboxed_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_int64_unboxed.expected test_int64_unboxed.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int64_unboxed.ml test_int64_unboxed_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int64_unboxed.mli test_int64_unboxed_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_int64_unboxed_vectorized_runner.exe test_int64_unboxed_vectorized.cmx.dump) + (deps test_int64_unboxed_vectorized.mli test_int64_unboxed_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_int64_unboxed_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_int64_unboxed_vectorized.cmx.dump.output) + (deps ./filter.sh test_int64_unboxed_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_int64_unboxed_vectorized.cmx.dump.expected test_int64_unboxed_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_int64_unboxed_vectorized.output + (run ./test_int64_unboxed_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int64_unboxed.expected test_int64_unboxed_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_int64_unboxed_vectorized.expected test_int64_unboxed_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_float_unboxed_runner.exe test_float_unboxed.cmx.dump) + (deps test_float_unboxed.mli test_float_unboxed.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_float_unboxed_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_float_unboxed.output + (run ./test_float_unboxed_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_float_unboxed.expected test_float_unboxed.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_float_unboxed.ml test_float_unboxed_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_float_unboxed.mli test_float_unboxed_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_float_unboxed_vectorized_runner.exe test_float_unboxed_vectorized.cmx.dump) + (deps test_float_unboxed_vectorized.mli test_float_unboxed_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_float_unboxed_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_float_unboxed_vectorized.cmx.dump.output) + (deps ./filter.sh test_float_unboxed_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_float_unboxed_vectorized.cmx.dump.expected test_float_unboxed_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_float_unboxed_vectorized.output + (run ./test_float_unboxed_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_float_unboxed.expected test_float_unboxed_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_float_unboxed_vectorized.expected test_float_unboxed_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_int64_runner.exe test_int64.cmx.dump) + (deps test_int64.mli test_int64.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_int64_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_int64.output + (run ./test_int64_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_int64.expected test_int64.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int64.ml test_int64_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int64.mli test_int64_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_int64_vectorized_runner.exe test_int64_vectorized.cmx.dump) + (deps test_int64_vectorized.mli test_int64_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_int64_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_int64_vectorized.cmx.dump.output) + (deps ./filter.sh test_int64_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_int64_vectorized.cmx.dump.expected test_int64_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_int64_vectorized.output + (run ./test_int64_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int64.expected test_int64_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_int64_vectorized.expected test_int64_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_float_runner.exe test_float.cmx.dump) + (deps test_float.mli test_float.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_float_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_float.output + (run ./test_float_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_float.expected test_float.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_float.ml test_float_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_float.mli test_float_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_float_vectorized_runner.exe test_float_vectorized.cmx.dump) + (deps test_float_vectorized.mli test_float_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_float_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_float_vectorized.cmx.dump.output) + (deps ./filter.sh test_float_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_float_vectorized.cmx.dump.expected test_float_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_float_vectorized.output + (run ./test_float_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_float.expected test_float_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_float_vectorized.expected test_float_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (targets test_float32_unboxed_runner.exe test_float32_unboxed.cmx.dump) + (deps test_float32_unboxed.mli test_float32_unboxed.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_float32_unboxed_runner.exe))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (with-outputs-to + test_float32_unboxed.output + (run ./test_float32_unboxed_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_float32_unboxed.expected test_float32_unboxed.output))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (copy test_float32_unboxed.ml test_float32_unboxed_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (copy test_float32_unboxed.mli test_float32_unboxed_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (targets test_float32_unboxed_vectorized_runner.exe test_float32_unboxed_vectorized.cmx.dump) + (deps test_float32_unboxed_vectorized.mli test_float32_unboxed_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_float32_unboxed_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_float32_unboxed_vectorized.cmx.dump.output) + (deps ./filter.sh test_float32_unboxed_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_float32_unboxed_vectorized.cmx.dump.expected test_float32_unboxed_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (with-outputs-to + test_float32_unboxed_vectorized.output + (run ./test_float32_unboxed_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (copy test_float32_unboxed.expected test_float32_unboxed_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_float32_unboxed_vectorized.expected test_float32_unboxed_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_int32_unboxed_runner.exe test_int32_unboxed.cmx.dump) + (deps test_int32_unboxed.mli test_int32_unboxed.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_int32_unboxed_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_int32_unboxed.output + (run ./test_int32_unboxed_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_int32_unboxed.expected test_int32_unboxed.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int32_unboxed.ml test_int32_unboxed_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int32_unboxed.mli test_int32_unboxed_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_int32_unboxed_vectorized_runner.exe test_int32_unboxed_vectorized.cmx.dump) + (deps test_int32_unboxed_vectorized.mli test_int32_unboxed_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_int32_unboxed_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_int32_unboxed_vectorized.cmx.dump.output) + (deps ./filter.sh test_int32_unboxed_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_int32_unboxed_vectorized.cmx.dump.expected test_int32_unboxed_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_int32_unboxed_vectorized.output + (run ./test_int32_unboxed_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_int32_unboxed.expected test_int32_unboxed_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_int32_unboxed_vectorized.expected test_int32_unboxed_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_spill_valx2_runner.exe test_spill_valx2.cmx.dump) + (deps test_spill_valx2.mli test_spill_valx2.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_spill_valx2_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_spill_valx2.output + (run ./test_spill_valx2_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_spill_valx2.expected test_spill_valx2.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_spill_valx2.ml test_spill_valx2_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_spill_valx2.mli test_spill_valx2_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_spill_valx2_vectorized_runner.exe test_spill_valx2_vectorized.cmx.dump) + (deps test_spill_valx2_vectorized.mli test_spill_valx2_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_spill_valx2_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_spill_valx2_vectorized.cmx.dump.output) + (deps ./filter.sh test_spill_valx2_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 0 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_spill_valx2_vectorized.cmx.dump.expected test_spill_valx2_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_spill_valx2_vectorized.output + (run ./test_spill_valx2_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_spill_valx2.expected test_spill_valx2_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_spill_valx2_vectorized.expected test_spill_valx2_vectorized.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_register_compatible_runner.exe test_register_compatible.cmx.dump) + (deps test_register_compatible.mli test_register_compatible.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -no-vectorize -o test_register_compatible_runner.exe))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_register_compatible.output + (run ./test_register_compatible_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_register_compatible.expected test_register_compatible.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_register_compatible.ml test_register_compatible_vectorized.ml))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_register_compatible.mli test_register_compatible_vectorized.mli))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (targets test_register_compatible_vectorized_runner.exe test_register_compatible_vectorized.cmx.dump) + (deps test_register_compatible_vectorized.mli test_register_compatible_vectorized.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc cfg -extension simd -vectorize-max-block-size 1000 -vectorize -o test_register_compatible_vectorized_runner.exe))) + +(rule + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (target test_register_compatible_vectorized.cmx.dump.output) + (deps ./filter.sh test_register_compatible_vectorized.cmx.dump) + (action + (with-outputs-to + %{target} + (with-accepted-exit-codes 1 + (run %{deps}))))) + +(rule + (alias runtest) + (enabled_if (and (= %{context_name} "main") (= %{architecture} "amd64")) ) + (action + (diff test_register_compatible_vectorized.cmx.dump.expected test_register_compatible_vectorized.cmx.dump.output))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (with-outputs-to + test_register_compatible_vectorized.output + (run ./test_register_compatible_vectorized_runner.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (copy test_register_compatible.expected test_register_compatible_vectorized.expected))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action + (diff test_register_compatible_vectorized.expected test_register_compatible_vectorized.output))) diff --git a/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml b/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml index 54784707a27..f6f4e7dc47f 100644 --- a/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml +++ b/flambda-backend/tests/backend/vectorizer/gen/gen_dune.ml @@ -5,7 +5,7 @@ let enabled_if_main_amd64 = let flags = "-S -O3 -g -dump-into-file -dcfg -dvectorize -dsel -dlinear -dlive -regalloc \ - cfg -extension simd" + cfg -extension simd -vectorize-max-block-size 1000" let runner name = name ^ "_runner.exe" @@ -98,9 +98,10 @@ let copy_file ~enabled_if name new_name = (copy ${source} ${target}))) |} -let filter_dump ~enabled_if name = +let filter_dump ~enabled_if ~exit_code name = let subst = function | "enabled_if" -> enabled_if + | "exit_code" -> string_of_int exit_code | "dump" -> name |> cmx_dump | "filtered" -> name |> cmx_dump |> output | _ -> assert false @@ -114,55 +115,64 @@ let filter_dump ~enabled_if name = (action (with-outputs-to %{target} - (run %{deps})))) + (with-accepted-exit-codes ${exit_code} + (run %{deps}))))) |} -let copy_source_to_vectorize name = - copy_file ~enabled_if:enabled_if_main (name |> impl) - (name |> vectorized |> impl); - copy_file ~enabled_if:enabled_if_main (name |> intf) - (name |> vectorized |> intf) +let copy_source_to_vectorize ~enabled_if name = + copy_file ~enabled_if (name |> impl) (name |> vectorized |> impl); + copy_file ~enabled_if (name |> intf) (name |> vectorized |> intf) -let compile_no_vectorizer name = - compile ~enabled_if:enabled_if_main ~extra_flags:"-no-vectorize" name +let compile_no_vectorizer ~enabled_if name = + compile ~enabled_if ~extra_flags:"-no-vectorize" name -let compile_with_vectorizer name = - compile ~enabled_if:enabled_if_main ~extra_flags:"-vectorize" - (vectorized name) +let compile_with_vectorizer ~enabled_if name = + compile ~enabled_if ~extra_flags:"-vectorize" (vectorized name) -let filter_vectorizer_dump ~enabled_if name = - filter_dump ~enabled_if (name |> vectorized) +let filter_vectorizer_dump ~enabled_if ~exit_code name = + filter_dump ~enabled_if ~exit_code (name |> vectorized) let diff_vectorizer_dump ~enabled_if name = diff_output ~enabled_if (name |> vectorized |> cmx_dump) -let run_no_vectorizer name = run ~enabled_if:enabled_if_main name +let run_no_vectorizer ~enabled_if name = run ~enabled_if name -let run_vectorized name = run ~enabled_if:enabled_if_main (name |> vectorized) +let run_vectorized ~enabled_if name = run ~enabled_if (name |> vectorized) -let diff_output_no_vectorizer name = - diff_output ~enabled_if:enabled_if_main name +let diff_output_no_vectorizer ~enabled_if name = diff_output ~enabled_if name -let diff_output_vectorized name = - diff_output ~enabled_if:enabled_if_main (name |> vectorized) +let diff_output_vectorized ~enabled_if name = + diff_output ~enabled_if (name |> vectorized) -let copy_expected_output name = - copy_file ~enabled_if:enabled_if_main (name |> expected) - (name |> vectorized |> expected) +let copy_expected_output ~enabled_if name = + copy_file ~enabled_if (name |> expected) (name |> vectorized |> expected) -let print_test name = +let print_test ?(enabled_if = enabled_if_main) ?(filter_exit_code = 0) name = (* check expected test output is up to date *) - compile_no_vectorizer name; - run_no_vectorizer name; - diff_output_no_vectorizer name; + compile_no_vectorizer ~enabled_if name; + run_no_vectorizer ~enabled_if name; + diff_output_no_vectorizer ~enabled_if name; (* vectorizer *) - copy_source_to_vectorize name; - compile_with_vectorizer name; - filter_vectorizer_dump name ~enabled_if:enabled_if_main_amd64; + copy_source_to_vectorize ~enabled_if name; + compile_with_vectorizer ~enabled_if name; + filter_vectorizer_dump name ~exit_code:filter_exit_code + ~enabled_if:enabled_if_main_amd64; diff_vectorizer_dump name ~enabled_if:enabled_if_main_amd64; - run_vectorized name; - copy_expected_output name; - diff_output_vectorized name; + run_vectorized ~enabled_if name; + copy_expected_output ~enabled_if name; + diff_output_vectorized ~enabled_if name; () -let () = print_test "test1" +let () = + print_test "test1"; + print_test "test_arrays"; + print_test "test_int64_unboxed"; + print_test "test_float_unboxed"; + print_test "test_int64"; + print_test "test_float"; + print_test ~enabled_if:enabled_if_main_amd64 "test_float32_unboxed"; + print_test "test_int32_unboxed"; + print_test "test_spill_valx2"; + (* can't vectorize *) + print_test ~filter_exit_code:1 "test_register_compatible"; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_arrays.expected b/flambda-backend/tests/backend/vectorizer/test_arrays.expected new file mode 100644 index 00000000000..e86cd1806ce --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_arrays.expected @@ -0,0 +1,9 @@ +add_arrays_unrolled_manually 17 18 19 20 21 22 23 24 25 26 +add_arrays_unrolled_safe 17 18 19 20 21 22 23 24 25 26 +add_arrays_rec_unrolled_attribute 17 18 19 20 21 22 23 24 25 26 +add_arrays_for 17 18 19 20 21 22 23 24 25 26 +add_arrays_rec 17 18 19 20 21 22 23 24 25 26 +initialize_array_const_unrolled_manually 0 0 0 0 0 0 0 0 0 0 +initialize_arrays_const_unrolled_manually 0 0 0 0 0 0 0 0 0 0 +initialize_array_unrolled_manually 17 17 17 17 17 17 17 17 17 17 +initialize_floatarray_unrolled_manually 7.700000 7.700000 7.700000 7.700000 7.700000 7.700000 7.700000 7.700000 7.700000 7.700000 diff --git a/flambda-backend/tests/backend/vectorizer/test_arrays.ml b/flambda-backend/tests/backend/vectorizer/test_arrays.ml new file mode 100644 index 00000000000..106eaa5e5df --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_arrays.ml @@ -0,0 +1,141 @@ +let[@inline never] [@local never] [@specialize never] add_arrays_unrolled_manually + a b c n = + for i = 0 to (n / 2) - 1 do + Array.unsafe_set c (i * 2) + (Array.unsafe_get a (i * 2) + Array.unsafe_get b (i * 2)); + Array.unsafe_set c + ((i * 2) + 1) + (Array.unsafe_get a ((i * 2) + 1) + Array.unsafe_get b ((i * 2) + 1)) + done; + if Int.rem n 2 = 1 + then + Array.unsafe_set c (n - 1) + (Array.unsafe_get a (n - 1) + Array.unsafe_get b (n - 1)) + +(* Currently won't be vectorized. Can vectorize it but it's not worth it + according to our cost model. It will be vectorized when we add vectors beyond + 128 or arrays of elements smaller than 64-bit. *) +let[@inline never] [@local never] [@specialize never] initialize_array_const_unrolled_manually + arr n = + let i = ref 0 in + while !i < n do + Array.unsafe_set arr !i 0; + Array.unsafe_set arr (!i + 1) 0; + i := !i + 2 + done + +(* Currently, won't be vectorized. If different groups can reuse the new + register that holds the constants, this will be worth vectorizing even with + 128-bit vectors. *) +let[@inline never] [@local never] [@specialize never] initialize_arrays_const_unrolled_manually + a b c n = + let i = ref 0 in + while !i < n do + Array.unsafe_set a !i 0; + Array.unsafe_set a (!i + 1) 0; + Array.unsafe_set b !i 0; + Array.unsafe_set b (!i + 1) 0; + Array.unsafe_set c !i 0; + Array.unsafe_set c (!i + 1) 0; + i := !i + 2 + done + +(* Currently, won't be vectorized. Shuffling values into a vector is not yet + supported, only vector loads are. Also not worth it unless the shuffle is + outside the loop (loop invariant detection/motion would be needed for it). *) +let[@inline never] [@local never] [@specialize never] initialize_array_unrolled_manually + arr n (v : int) = + let i = ref 0 in + while !i < n do + Array.unsafe_set arr !i v; + Array.unsafe_set arr (!i + 1) v; + i := !i + 2 + done + +(* same as [initialize_array_unrolled_manually] except needs movddup. *) +let[@inline never] [@local never] [@specialize never] initialize_floatarray_unrolled_manually + arr n (v : float) = + let i = ref 0 in + while !i < n do + Array.unsafe_set arr !i v; + Array.unsafe_set arr (!i + 1) v; + i := !i + 2 + done + +(* cannot vectorize across basic blocks *) +let[@inline never] [@local never] [@specialize never] add_arrays_unrolled_safe a + b c n = + for i = 0 to n - 1 do + Array.set c (i * 2) (Array.get a (i * 2) + Array.get b (i * 2)); + Array.set c + ((i * 2) + 1) + (Array.get a ((i * 2) + 1) + Array.get b ((i * 2) + 1)) + done + +(* cannot vectorize across basic blocks. unroll attribute is not sufficient to + eliminate the loop condition from the unrolled body (e.g., we would need to + track the fact that the bound is even. *) +let[@inline never] [@local never] [@specialize never] add_arrays_rec_unrolled_attribute + a b c n = + let[@loop never] rec loop i a b c n = + if i < n + then ( + Array.unsafe_set c i (Array.unsafe_get a i + Array.unsafe_get b i); + (loop [@unrolled 1]) (i + 1) a b c n) + in + loop 0 a b c (2 * n) + +(* cannot vectorize for-loops *) +let[@inline never] [@local never] [@specialize never] add_arrays_for a b c n = + for i = 0 to n - 1 do + Array.unsafe_set c i (Array.unsafe_get a i + Array.unsafe_get b i) + done + +(* cannot vectorize loops expressed using recursion *) +let[@inline never] [@local never] [@specialize never] add_arrays_rec a b c n = + let rec loop i = + if i < n + then ( + Array.unsafe_set c i (Array.unsafe_get a i + Array.unsafe_get b i); + loop (i + 1)) + in + loop 0 + +let print_array ppf a = + let count = Array.length a in + for i = 0 to count - 1 do + Format.fprintf ppf "%d " a.(i) + done + +let print_floatarray ppf a = + let count = Array.length a in + for i = 0 to count - 1 do + Format.fprintf ppf "%f " a.(i) + done + +let () = + let n = Sys.opaque_identity 10 in + let a = Array.init n (fun i -> i) in + let b = Array.make n 17 in + let c = Array.make n 0 in + let d = Array.make n 0.0 in + add_arrays_unrolled_manually a b c (Sys.opaque_identity n); + Format.printf "add_arrays_unrolled_manually %a\n" print_array c; + add_arrays_unrolled_safe a b c (Sys.opaque_identity (n / 2)); + Format.printf "add_arrays_unrolled_safe %a\n" print_array c; + add_arrays_rec_unrolled_attribute a b c (n / 2); + Format.printf "add_arrays_rec_unrolled_attribute %a\n" print_array c; + add_arrays_for a b c n; + Format.printf "add_arrays_for %a\n" print_array c; + add_arrays_rec a b c n; + Format.printf "add_arrays_rec %a\n" print_array c; + initialize_array_const_unrolled_manually c n; + Format.printf "initialize_array_const_unrolled_manually %a\n" print_array c; + initialize_arrays_const_unrolled_manually a b c n; + Format.printf "initialize_arrays_const_unrolled_manually %a\n" print_array c; + initialize_array_unrolled_manually c n (Sys.opaque_identity 17); + Format.printf "initialize_array_unrolled_manually %a\n" print_array c; + initialize_floatarray_unrolled_manually d n (Sys.opaque_identity 7.7); + Format.printf "initialize_floatarray_unrolled_manually %a\n" print_floatarray + d; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_arrays.mli b/flambda-backend/tests/backend/vectorizer/test_arrays.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_arrays.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_arrays_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_arrays_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..182c1cc7309 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_arrays_vectorized.cmx.dump.expected @@ -0,0 +1 @@ +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 7 vector instructions, cost = -1 (Test_arrays_vectorized.add_arrays_unrolled_manually) diff --git a/flambda-backend/tests/backend/vectorizer/test_float.expected b/flambda-backend/tests/backend/vectorizer/test_float.expected new file mode 100644 index 00000000000..00ffe66d5e1 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float.expected @@ -0,0 +1,7 @@ +add_mutable_record { d0 = 88.000000 ; d1 = 110.000000 } +copy_mutable_record { d0 = 88.000000 ; d1 = 110.000000 } +add_mutable_record_fresh { d0 = 88.000000 ; d1 = 110.000000 } +copy_mutable_record_fresh { d0 = 88.000000 ; d1 = 110.000000 } +add_mutable_record_t4 { d0 = 88.000000 ; d1 = 110.000000; d2 = 88.000000 ; d3 = 110.000000 } +copy_mutable_record_t4 { d0 = 8.000000 ; d1 = 96.000000; d2 = 80.000000 ; d3 = 14.000000 } +dup_mutable_record_t4 { d0 = 8.000000 ; d1 = 96.000000; d2 = 8.000000 ; d3 = 96.000000 } diff --git a/flambda-backend/tests/backend/vectorizer/test_float.ml b/flambda-backend/tests/backend/vectorizer/test_float.ml new file mode 100644 index 00000000000..1e36c686ceb --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float.ml @@ -0,0 +1,75 @@ +[@@@ocaml.warnerror "+a-40-41-42"] + +type t1 = + { mutable d0 : float; + mutable d1 : float + } + +let[@inline never] [@local never] [@specialize never] add_mutable_record + (a : t1) (b : t1) (c : t1) : t1 = + c.d0 <- Float.add a.d0 b.d0; + c.d1 <- Float.add a.d1 b.d1; + c + +let[@inline never] [@local never] [@specialize never] copy_mutable_record + (a : t1) (b : t1) : t1 = + b.d0 <- a.d0; + b.d1 <- a.d1; + b + +let[@inline never] [@local never] [@specialize never] add_mutable_record_fresh + (a : t1) (b : t1) : t1 = + { d0 = Float.add a.d0 b.d0; d1 = Float.add a.d1 b.d1 } + +let[@inline never] [@local never] [@specialize never] copy_mutable_record_fresh + (a : t1) : t1 = + { d0 = a.d0; d1 = a.d1 } + +type t4 = + { mutable d0 : float; + mutable d1 : float; + mutable d2 : float; + mutable d3 : float + } + +let[@inline never] [@local never] [@specialize never] add_mutable_record_t4 + (a : t1) (b : t1) (c : t4) : t4 = + c.d0 <- Float.add a.d0 b.d0; + c.d1 <- Float.add a.d1 b.d1; + c.d2 <- Float.add a.d0 b.d0; + c.d3 <- Float.add a.d1 b.d1; + c + +let[@inline never] [@local never] [@specialize never] copy_mutable_record_t4 + (a : t1) (b : t1) : t4 = + { d0 = a.d0; d1 = a.d1; d2 = b.d0; d3 = b.d1 } + +let[@inline never] [@local never] [@specialize never] dup_mutable_record_t4 + (a : t1) : t4 = + { d0 = a.d0; d1 = a.d1; d2 = a.d0; d3 = a.d1 } + +let print_t1 ppf (t1 : t1) = + Format.fprintf ppf "{ d0 = %f ; d1 = %f }" t1.d0 t1.d1 + +let print_t4 ppf (t4 : t4) = + Format.fprintf ppf "{ d0 = %f ; d1 = %f; d2 = %f ; d3 = %f }" t4.d0 t4.d1 + t4.d2 t4.d3 + +let () = + let a = { d0 = 8.; d1 = 96. } in + let b = { d0 = 80.; d1 = 14. } in + let c = { d0 = 10.; d1 = -10. } in + let t4 = { d0 = 10.; d1 = -10.; d2 = 199.; d3 = 18. } in + let res = { d0 = 0.; d1 = -0. } in + Format.printf "add_mutable_record %a\n" print_t1 (add_mutable_record a b c); + Format.printf "copy_mutable_record %a\n" print_t1 (copy_mutable_record c res); + Format.printf "add_mutable_record_fresh %a\n" print_t1 + (add_mutable_record_fresh a b); + Format.printf "copy_mutable_record_fresh %a\n" print_t1 + (copy_mutable_record_fresh c); + Format.printf "add_mutable_record_t4 %a\n" print_t4 + (add_mutable_record_t4 a b t4); + Format.printf "copy_mutable_record_t4 %a\n" print_t4 + (copy_mutable_record_t4 a b); + Format.printf "dup_mutable_record_t4 %a\n" print_t4 (dup_mutable_record_t4 a); + () diff --git a/flambda-backend/tests/backend/vectorizer/test_float.mli b/flambda-backend/tests/backend/vectorizer/test_float.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.expected b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.expected new file mode 100644 index 00000000000..92c4b798f9d --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.expected @@ -0,0 +1,5 @@ +add_unboxed_pairs_mutable_record { d0 = 88. ; d1 = 110.; d2 = 0. ; d3 = -1. } +copy_unboxed_pairs_mutable_record { d0 = 88. ; d1 = 110.; d2 = 0. ; d3 = -1. } +copy_bytes 10. 10. 10. 10. +copy_bytes_pos 10. 10. 10. 10. +copy_bytes_pos_v2 10. 10. 10. 10. diff --git a/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.ml b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.ml new file mode 100644 index 00000000000..ea552f169e2 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.ml @@ -0,0 +1,225 @@ +[@@@ocaml.warnerror "+a-40-41-42"] + +module Float32 = struct + type t = float32 + + external add : (t[@local_opt]) -> (t[@local_opt]) -> (t[@local_opt]) + = "%addfloat32" + + external format : string -> t -> string = "caml_format_float32" + + let to_string f = Stdlib.valid_float_lexem (format "%.9g" f) + + module Bytes = struct + external get : bytes -> pos:int -> float32 = "%caml_bytes_getf32" + external unsafe_get : bytes -> pos:int -> float32 = "%caml_bytes_getf32u" + external set : bytes -> pos:int -> float32 -> unit = "%caml_bytes_setf32" + + external unsafe_set : bytes -> pos:int -> float32 -> unit + = "%caml_bytes_setf32u" + end +end + +module Float32_u = struct + type t = float32# + + external to_float32 : t -> (float32[@local_opt]) = "%box_float32" [@@warning "-187"] + + external of_float32 : (float32[@local_opt]) -> t = "%unbox_float32" [@@warning "-187"] + + let[@inline always] add x y = of_float32 (Float32.add (to_float32 x) (to_float32 y)) + + module Bytes = struct + let get bytes ~pos = of_float32 (Float32.Bytes.get bytes ~pos) + let unsafe_get bytes ~pos = of_float32 (Float32.Bytes.unsafe_get bytes ~pos) + let set bytes ~pos x = Float32.Bytes.set bytes ~pos (to_float32 x) + let unsafe_set bytes ~pos x = Float32.Bytes.unsafe_set bytes ~pos (to_float32 x) + end +end + +type t1 = { mutable d0 : float32# ; + mutable d1: float32#; mutable d2: float32#; mutable d3: float32# } + +(* Not vectorized because float32 fields are not adjacent in a record, they are padded +to 64-bits. *) +let[@inline never] [@local never][@specialize never] copy_mutable_record (a : t1) (b: t1) : unit = + b.d0 <- a.d0; + b.d1 <- a.d1; + b.d2 <- a.d2; + b.d3 <- a.d3; + () + +(* Not vectorized because float32 fields are not adjacent in a record, they are padded +to 64-bits. *) +let[@inline never] [@local never][@specialize never] add_mutable_record (a : t1) (b: t1) (c : t1) : t1 = + c.d0 <- Float32_u.add a.d0 b.d0; + c.d1 <- Float32_u.add a.d1 b.d1; + c.d2 <- Float32_u.add a.d2 b.d2; + c.d3 <- Float32_u.add a.d3 b.d3; + c + +(* [Float32_u.Bytes] contain packed float32_u, can vectorize. *) +let[@inline never] [@local never] [@specialize never] copy_bytes a b = + let pos = 0 in + let x = Float32_u.Bytes.unsafe_get a ~pos in + Float32_u.Bytes.unsafe_set b ~pos x; + let pos = pos + 4 in + let x = Float32_u.Bytes.unsafe_get a ~pos in + Float32_u.Bytes.unsafe_set b ~pos x; + let pos = pos + 4 in + let x = Float32_u.Bytes.unsafe_get a ~pos in + Float32_u.Bytes.unsafe_set b ~pos x; + let pos = pos + 4 in + let x = Float32_u.Bytes.unsafe_get a ~pos in + Float32_u.Bytes.unsafe_set b ~pos x; + () + +let[@inline never] [@local never] [@specialize never] init_bytes b x = + let pos = 0 in + Float32_u.Bytes.unsafe_set b ~pos x; + let pos = pos + 4 in + Float32_u.Bytes.unsafe_set b ~pos x; + let pos = pos + 4 in + Float32_u.Bytes.unsafe_set b ~pos x; + let pos = pos + 4 in + Float32_u.Bytes.unsafe_set b ~pos x; + () + +let[@inline always] copy_float32_unboxed_pos a b ~pos = + let x = Float32_u.Bytes.unsafe_get a ~pos in + Float32_u.Bytes.unsafe_set b ~pos x; + () + +(* Currently can't vectorize because [pos] untagging is repeated and the current + heuristic for detecting relations between pointers is not strong enough to + handle this case. *) +let[@inline never] [@local never] [@specialize never] copy_bytes_pos a b pos = + copy_float32_unboxed_pos a b ~pos; + copy_float32_unboxed_pos a b ~pos:(pos+1*4); + copy_float32_unboxed_pos a b ~pos:(pos+2*4); + copy_float32_unboxed_pos a b ~pos:(pos+3*4); + () + +(* 128: + * (id:3) a:V/61 := R:I/0[%rax] + * (id:4) b:V/62 := R:I/1[%rbx] + * (id:5) pos:I/63 := R:I/2[%rdi] + * (id:6) prim:I/64 := pos:I/63 + * (id:7) prim:I/64 := prim:I/64 >>s 1 + * (id:8) S/65 := float32 mut[a:V/61 + prim:I/64] + * (id:9) float32[b:V/62 + prim:I/64] := S/65 (assign) + * (id:10) Pbytes_set_f32:I/66 := 1 + * (id:11) I/67 := pos:I/63 + * (id:12) I/67 := I/67 + 8 + * (id:13) prim:I/68 := I/67 + * (id:14) prim:I/68 := prim:I/68 >>s 1 + * (id:15) S/69 := float32 mut[a:V/61 + prim:I/68] + * (id:16) float32[b:V/62 + prim:I/68] := S/69 (assign) + * (id:17) Pbytes_set_f32:I/70 := 1 + * (id:18) I/71 := pos:I/63 + * (id:19) I/71 := I/71 + 16 + * (id:20) prim:I/72 := I/71 + * (id:21) prim:I/72 := prim:I/72 >>s 1 + * (id:22) S/73 := float32 mut[a:V/61 + prim:I/72] + * (id:23) float32[b:V/62 + prim:I/72] := S/73 (assign) + * (id:24) Pbytes_set_f32:I/74 := 1 + * (id:25) I/75 := pos:I/63 + * (id:26) I/75 := I/75 + 24 + * (id:27) prim:I/76 := I/75 + * (id:28) prim:I/76 := prim:I/76 >>s 1 + * (id:29) S/77 := float32 mut[a:V/61 + prim:I/76] + * (id:30) float32[b:V/62 + prim:I/76] := S/77 (assign) + * (id:31) Pbytes_set_f32:I/78 := 1 + * (id:32) I/79 := 1 + * (id:33) R:I/0[%rax] := I/79 + * (id:34) Return R:I/0[%rax] *) + +(* Currently, can't vectorize because the index is untagged before every memory access, + instead of operating on untagged indexes throughout. *) +let[@inline never] [@local never] [@specialize never] copy_bytes_pos_v2 a b pos = + let i0 = pos in + copy_float32_unboxed_pos a b ~pos:i0; + let i1 = i0 + 4 in + copy_float32_unboxed_pos a b ~pos:i1; + let i2 = i1 + 4 in + copy_float32_unboxed_pos a b ~pos:i2; + let i3 = i2 + 4 in + copy_float32_unboxed_pos a b ~pos:i3; + () + +(* 177: + * (id:3) a:V/61 := R:I/0[%rax] + * (id:4) b:V/62 := R:I/1[%rbx] + * (id:5) pos:I/63 := R:I/2[%rdi] + * (id:6) prim:I/64 := pos:I/63 + * (id:7) prim:I/64 := prim:I/64 >>s 1 + * (id:8) S/65 := float32 mut[a:V/61 + prim:I/64] + * (id:9) float32[b:V/62 + prim:I/64] := S/65 (assign) + * (id:10) Pbytes_set_f32:I/66 := 1 + * (id:11) i1:I/67 := pos:I/63 + * (id:12) i1:I/67 := i1:I/67 + 8 + * (id:13) prim:I/68 := i1:I/67 + * (id:14) prim:I/68 := prim:I/68 >>s 1 + * (id:15) S/69 := float32 mut[a:V/61 + prim:I/68] + * (id:16) float32[b:V/62 + prim:I/68] := S/69 (assign) + * (id:17) Pbytes_set_f32:I/70 := 1 + * (id:18) i2:I/71 := i1:I/67 + * (id:19) i2:I/71 := i2:I/71 + 8 + * (id:20) prim:I/72 := i2:I/71 + * (id:21) prim:I/72 := prim:I/72 >>s 1 + * (id:22) S/73 := float32 mut[a:V/61 + prim:I/72] + * (id:23) float32[b:V/62 + prim:I/72] := S/73 (assign) + * (id:24) Pbytes_set_f32:I/74 := 1 + * (id:25) I/75 := i2:I/71 + * (id:26) I/75 := I/75 + 8 + * (id:27) prim:I/76 := I/75 + * (id:28) prim:I/76 := prim:I/76 >>s 1 + * (id:29) S/77 := float32 mut[a:V/61 + prim:I/76] + * (id:30) float32[b:V/62 + prim:I/76] := S/77 (assign) + * (id:31) Pbytes_set_f32:I/78 := 1 + * (id:32) I/79 := 1 + * (id:33) R:I/0[%rax] := I/79 + * (id:34) Return R:I/0[%rax] *) + + +let print_t1 ppf (t1 : t1) = + (* CR gyorsh: how to print Float32? *) + let to_string f = (Float32_u.to_float32 f |> Float32.to_string) in + Format.fprintf ppf "{ d0 = %s ; d1 = %s; d2 = %s ; d3 = %s }" + (to_string t1.d0) + (to_string t1.d1) + (to_string t1.d2) + (to_string t1.d3) + +let create_s length = + String.init length (fun i -> i * 7 mod 256 |> char_of_int) +;; + +let create_b length = create_s length |> Bytes.of_string + +let print_b ~len ppf b = + for i = 0 to len-1 do + Format.fprintf ppf "%s " + (Float32_u.to_float32 (Float32_u.Bytes.get b ~pos:(i*4)) |> Float32.to_string) + done + +let () = + let a = { d0 = #8.s; d1 = #96.s; d2 = #0.s; d3 = -#0.5s } in + let b = { d0 = #80.s; d1 = #14.s; d2 = #0.s; d3 = -#0.5s } in + let c = { d0 = #8.s; d1 = #96.s; d2 = #0.s; d3 = -#0.s } in + let res = { d0 = #0.s; d1 = -#10.s; d2 = #1.s; d3 = -#1.s } in + Format.printf "add_unboxed_pairs_mutable_record %a\n" print_t1 + (add_mutable_record a b c); + copy_mutable_record c res; + Format.printf "copy_unboxed_pairs_mutable_record %a\n" print_t1 res; + let b1 = create_b 16 in + let b2 = create_b 16 in + init_bytes b1 #10.s; + init_bytes b2 #0.s; + copy_bytes b1 b2; + Format.printf "copy_bytes %a\n" (print_b ~len:4) b2; + copy_bytes_pos b2 b1 (Sys.opaque_identity 0); + Format.printf "copy_bytes_pos %a\n" (print_b ~len:4) b2; + copy_bytes_pos_v2 b1 b2 (Sys.opaque_identity 0); + Format.printf "copy_bytes_pos_v2 %a\n" (print_b ~len:4) b2; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.mli b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_float32_unboxed_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..3178ac03fb8 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float32_unboxed_vectorized.cmx.dump.expected @@ -0,0 +1 @@ +**** Vectorize selected computation: 2 groups, 8 scalar instructions, 2 vector instructions, cost = -6 (Test_float32_unboxed_vectorized.copy_bytes) diff --git a/flambda-backend/tests/backend/vectorizer/test_float_unboxed.expected b/flambda-backend/tests/backend/vectorizer/test_float_unboxed.expected new file mode 100644 index 00000000000..bfea42ed769 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float_unboxed.expected @@ -0,0 +1,2 @@ +add_mutable_record { d0 = 88.000000 ; d1 = 110.000000; d2 = 0.000000 ; d3 = -1.000000 } +copy_mutable_record { d0 = 88.000000 ; d1 = 110.000000; d2 = 1.000000 ; d3 = -1.000000 } diff --git a/flambda-backend/tests/backend/vectorizer/test_float_unboxed.ml b/flambda-backend/tests/backend/vectorizer/test_float_unboxed.ml new file mode 100644 index 00000000000..a49aaf0b841 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float_unboxed.ml @@ -0,0 +1,80 @@ +[@@@ocaml.warnerror "+a-40-41-42"] + +module Float_u = struct + type t = float# + + external to_float : t -> (float[@local_opt]) = "%box_float" [@@warning "-187"] + + external of_float : (float[@local_opt]) -> t = "%unbox_float" [@@warning "-187"] + + let[@inline always] add x y = of_float (Float.add (to_float x) (to_float y)) +end + +type t1 = { mutable d0: float#; + mutable d1: float#; + mutable d2: float#; + mutable d3: float# + } + + +let[@inline never] [@local never][@specialize never] copy_mutable_record (a : t1) (b: t1) : unit = + b.d0 <- a.d0; + b.d1 <- a.d1; + () + +(* Currently, can't vectorize because of the specific floatmem operation (looks like + it is treated overly conservatively. *) +let[@inline never] [@local never][@specialize never] add_mutable_record (a : t1) (b: t1) (c : t1) : t1 = + c.d0 <- Float_u.add a.d0 b.d0; + c.d1 <- Float_u.add a.d1 b.d1; + c.d2 <- Float_u.add a.d2 b.d2; + c.d3 <- Float_u.add a.d3 b.d3; + c + +(* +102: +(id:3) a:V/61 := R:I/0[%rax] +(id:4) b:V/62 := R:I/1[%rbx] +(id:5) c:V/63 := R:I/2[%rdi] +(id:6) F/64 := float64 mut[a:V/61] +(id:7) F/65 := F/64 +(id:8) F/65 := F/65 +f float64[b:V/62] +(id:9) float64[c:V/63] := F/65 (assign) +(id:10) Psetufloatfield:I/66 := 1 +(id:11) F/67 := float64 mut[a:V/61 + 8] +(id:12) F/68 := F/67 +(id:13) F/68 := F/68 +f float64[b:V/62 + 8] +(id:14) float64[c:V/63 + 8] := F/68 (assign) +(id:15) Psetufloatfield:I/69 := 1 +(id:16) F/70 := float64 mut[a:V/61 + 16] +(id:17) F/71 := F/70 +(id:18) F/71 := F/71 +f float64[b:V/62 + 16] +(id:19) float64[c:V/63 + 16] := F/71 (assign) +(id:20) Psetufloatfield:I/72 := 1 +(id:21) F/73 := float64 mut[a:V/61 + 24] +(id:22) F/74 := F/73 +(id:23) F/74 := F/74 +f float64[b:V/62 + 24] +(id:24) float64[c:V/63 + 24] := F/74 (assign) +(id:25) Psetufloatfield:I/75 := 1 +(id:26) R:I/0[%rax] := c:V/63 +(id:27) Return R:I/0[%rax] + +*) + +let print_t1 ppf (t1 : t1) = + Format.fprintf ppf "{ d0 = %f ; d1 = %f; d2 = %f ; d3 = %f }" + (Float_u.to_float t1.d0) + (Float_u.to_float t1.d1) + (Float_u.to_float t1.d2) + (Float_u.to_float t1.d3) + +let () = + let a = { d0 = #8.; d1 = #96.; d2 = #0.; d3 = -#0.5 } in + let b = { d0 = #80.; d1 = #14.; d2 = #0.; d3 = -#0.5 } in + let c = { d0 = #8.; d1 = #96.; d2 = #0.; d3 = -#0. } in + let res = { d0 = #0.; d1 = -#10.; d2 = #1.; d3 = -#1. } in + Format.printf "add_mutable_record %a\n" print_t1 + (add_mutable_record a b c); + copy_mutable_record c res; + Format.printf "copy_mutable_record %a\n" print_t1 res; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_float_unboxed.mli b/flambda-backend/tests/backend/vectorizer/test_float_unboxed.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float_unboxed.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_float_unboxed_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_float_unboxed_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..357dba19d99 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float_unboxed_vectorized.cmx.dump.expected @@ -0,0 +1,2 @@ +**** Vectorize selected computation: 2 groups, 4 scalar instructions, 2 vector instructions, cost = -2 (Test_float_unboxed_vectorized.copy_mutable_record) +**** Vectorize selected computation: 8 groups, 16 scalar instructions, 10 vector instructions, cost = -6 (Test_float_unboxed_vectorized.add_mutable_record) diff --git a/flambda-backend/tests/backend/vectorizer/test_float_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_float_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..dc486848738 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_float_vectorized.cmx.dump.expected @@ -0,0 +1,7 @@ +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 5 vector instructions, cost = -3 (Test_float_vectorized.add_mutable_record) +**** Vectorize selected computation: 2 groups, 4 scalar instructions, 2 vector instructions, cost = -2 (Test_float_vectorized.copy_mutable_record) +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 5 vector instructions, cost = -3 (Test_float_vectorized.add_mutable_record_fresh) +**** Vectorize selected computation: 2 groups, 4 scalar instructions, 2 vector instructions, cost = -2 (Test_float_vectorized.copy_mutable_record_fresh) +**** Vectorize selected computation: 8 groups, 16 scalar instructions, 10 vector instructions, cost = -6 (Test_float_vectorized.add_mutable_record_t4) +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 4 vector instructions, cost = -4 (Test_float_vectorized.copy_mutable_record_t4) +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 4 vector instructions, cost = -4 (Test_float_vectorized.dup_mutable_record_t4) diff --git a/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.expected b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.expected new file mode 100644 index 00000000000..0207ed6b915 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.expected @@ -0,0 +1,7 @@ +add_mutable_record { d0 = 88 ; d1 = 110; d2 = -40 ; d3 = -100 } +copy_array_four 30 30 30 30 +copy_array_index_four 30 30 30 30 +add_array_from_start 60 60 60 60 +copy_array_index_from_start 60 60 60 60 +copy_array_from_start 60 60 60 60 +copy_array_from_start_v2 60 60 60 60 diff --git a/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.ml b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.ml new file mode 100644 index 00000000000..b45eaa57769 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.ml @@ -0,0 +1,229 @@ +[@@@ocaml.warnerror "+a-40-41-42"] + +module Int32_u = struct + type t = int32# + + external to_int32 : t -> (int32[@local_opt]) = "%box_int32" [@@warning "-187"] + + external of_int32 : (int32[@local_opt]) -> t = "%unbox_int32" [@@warning "-187"] + + let[@inline always] add x y = of_int32 (Int32.add (to_int32 x) (to_int32 y)) + + module Array = struct + external unsafe_create : ('a : bits32). int -> 'a array = + "caml_make_unboxed_int32_vect_bytecode" "caml_make_unboxed_int32_vect" + external unsafe_get: ('a : bits32). 'a array -> int -> 'a = "%array_unsafe_get" + external unsafe_set: ('a : bits32). 'a array -> int -> 'a -> unit = "%array_unsafe_set" + + module Index = struct + external unsafe_get + : ('a : bits32). + ('a array) -> t -> 'a + = "%array_unsafe_get_indexed_by_int32#" + + external unsafe_set + : ('a : bits32). + 'a array -> t -> 'a -> unit + = "%array_unsafe_set_indexed_by_int32#" + end + end + +end + +type t1 = { mutable d0 : int32# ; mutable d1: int32#; mutable d2: int32#; mutable d3: int32# } + +(* Currently, can't vectorize because not adjacent and have an unnecessary sign extension. *) +let[@inline never] [@local never][@specialize never] add_mutable_record (a : t1) (b: t1) (c : t1) : t1 = + c.d0 <- Int32_u.add a.d0 b.d0; + c.d1 <- Int32_u.add a.d1 b.d1; + c.d2 <- Int32_u.add a.d2 b.d2; + c.d3 <- Int32_u.add a.d3 b.d3; + c + +let[@inline always] copy_array_one (a : Int32_u.t array) + (b : Int32_u.t array) pos = + let x = Int32_u.Array.unsafe_get a pos in + Int32_u.Array.unsafe_set b pos x + +(* The accesses are adjacent but the use of [int] typed index results in a convoluted + index computation that is not yet handled by the current heuristics. *) +let[@inline never] [@local never][@specialize never] copy_array_four (a : Int32_u.t array) + (b : Int32_u.t array) ~pos = + copy_array_one a b pos; + copy_array_one a b (pos+1); + copy_array_one a b (pos+2); + copy_array_one a b (pos+3); + () + +(* + +114: +(id:3) a:V/61 := R:I/0[%rax] +(id:4) b:V/62 := R:I/1[%rbx] +(id:5) pos:I/63 := R:I/2[%rdi] +(id:6) new_value:I/64 := signed int32 mut[a:V/61 + pos:I/63 * 2 + 6] +(id:7) signed int32[b:V/62 + pos:I/63 * 2 + 6] := new_value:I/64 (assign) +(id:8) Parraysetu:I/65 := 1 +(id:9) Paddint:I/66 := pos:I/63 +(id:10) Paddint:I/66 := Paddint:I/66 + 2 +(id:11) new_value:I/67 := signed int32 mut[a:V/61 + Paddint:I/66 * 2 + 6] +(id:12) signed int32[b:V/62 + Paddint:I/66 * 2 + 6] := new_value:I/67 (assign) +(id:13) Parraysetu:I/68 := 1 +(id:14) Paddint:I/69 := pos:I/63 +(id:15) Paddint:I/69 := Paddint:I/69 + 4 +(id:16) new_value:I/70 := signed int32 mut[a:V/61 + Paddint:I/69 * 2 + 6] +(id:17) signed int32[b:V/62 + Paddint:I/69 * 2 + 6] := new_value:I/70 (assign) +(id:18) Parraysetu:I/71 := 1 +(id:19) Paddint:I/72 := pos:I/63 +(id:20) Paddint:I/72 := Paddint:I/72 + 6 +(id:21) new_value:I/73 := signed int32 mut[a:V/61 + Paddint:I/72 * 2 + 6] +(id:22) signed int32[b:V/62 + Paddint:I/72 * 2 + 6] := new_value:I/73 (assign) +(id:23) Parraysetu:I/74 := 1 +(id:24) I/75 := 1 +(id:25) R:I/0[%rax] := I/75 +(id:26) Return R:I/0[%rax] + +*) + +let[@inline never] [@local never][@specialize never] copy_array_four_v2 (a : Int32_u.t array) + (b : Int32_u.t array) ~pos = + let i0 = pos in + copy_array_one a b i0; + let i1 = i0 + 1 in + copy_array_one a b i1; + let i2 = i1 + 1 in + copy_array_one a b i2; + let i3 = i2 + 1 in + copy_array_one a b i3; + () + +let[@inline always] copy_array_index_one (a : Int32_u.t array) + (b : Int32_u.t array) (pos : Int32_u.t) = + let x = Int32_u.Array.Index.unsafe_get a pos in + Int32_u.Array.Index.unsafe_set b pos x + +(* Can't vectorize it! The accesses are adjacent and we use [Int32_u.t] as index, + but the compiler tags the index before using it! This index computation is not + yet handled by the vectorizer's heuristics. *) +let[@inline never] [@local never][@specialize never] copy_array_index_four (a : Int32_u.t array) + (b : Int32_u.t array) ~pos = + copy_array_index_one a b pos; + copy_array_index_one a b (Int32_u.add pos #1l); + copy_array_index_one a b (Int32_u.add pos #2l); + copy_array_index_one a b (Int32_u.add pos #3l); + () + +let[@inline never] [@local never][@specialize never] copy_array_index_from_start (a : Int32_u.t array) + (b : Int32_u.t array) = + let pos = #0l in + copy_array_index_one a b pos; + copy_array_index_one a b (Int32_u.add pos #1l); + copy_array_index_one a b (Int32_u.add pos #2l); + copy_array_index_one a b (Int32_u.add pos #3l); + () + + let[@inline never] [@local never][@specialize never] copy_array_from_start (a : Int32_u.t array) + (b : Int32_u.t array) = + let[@inline always] copy pos = + let x = Int32_u.Array.unsafe_get a pos in + Int32_u.Array.unsafe_set b pos x + in + let pos = 0 in + copy pos; + copy (pos+1); + copy (pos+2); + copy (pos+3); + () + +(* Can't vectorize because of an unnecessary sign extension. The heuristics in the + vectorizer can be extended to handle this case. *) +let[@inline never] [@local never][@specialize never] add_array_from_start (a : Int32_u.t array) (b : Int32_u.t array) = + let[@inline always] add pos = + let x = Int32_u.Array.unsafe_get a pos in + let y = Int32_u.Array.unsafe_get b pos in + Int32_u.Array.unsafe_set b pos (Int32_u.add x y) + in + let pos = 0 in + add pos; + add (pos+1); + add (pos+2); + add (pos+3); + () + +(* +camlTest7__add_array_from_start_7_22_code(R:I/0[%rax] R:I/1[%rbx]) {test7.ml:112,74-379} + a:V/61 := R:I/0[%rax] + b:V/62 := R:I/1[%rbx] + I/63 := signed int32 mut[b:V/62 + 8]{test7.ml:119,2-9;test7.ml:115,12-42} + I/64 := signed int32 mut[a:V/61 + 8]{test7.ml:119,2-9;test7.ml:114,12-42} + I/65 := I/64 + I/65 := I/65 + I/63{test7.ml:119,2-9;test7.ml:116,35-52;test7.ml:10,41-78} + new_value:I/66 := sextend32 I/65{test7.ml:119,2-9;test7.ml:116,35-52;test7.ml:10,41-78} + signed int32[b:V/62 + 8] := new_value:I/66 (assign){test7.ml:119,2-9;test7.ml:116,4-52} + Parraysetu:I/67 := 1 + I/68 := signed int32 mut[b:V/62 + 12]{test7.ml:120,2-13;test7.ml:115,12-42} + I/69 := signed int32 mut[a:V/61 + 12]{test7.ml:120,2-13;test7.ml:114,12-42} + I/70 := I/69 + I/70 := I/70 + I/68{test7.ml:120,2-13;test7.ml:116,35-52;test7.ml:10,41-78} + new_value:I/71 := sextend32 I/70{test7.ml:120,2-13;test7.ml:116,35-52;test7.ml:10,41-78} + signed int32[b:V/62 + 12] := new_value:I/71 (assign){test7.ml:120,2-13;test7.ml:116,4-52} + Parraysetu:I/72 := 1 + I/73 := signed int32 mut[b:V/62 + 16]{test7.ml:121,2-13;test7.ml:115,12-42} + I/74 := signed int32 mut[a:V/61 + 16]{test7.ml:121,2-13;test7.ml:114,12-42} + I/75 := I/74 + I/75 := I/75 + I/73{test7.ml:121,2-13;test7.ml:116,35-52;test7.ml:10,41-78} + new_value:I/76 := sextend32 I/75{test7.ml:121,2-13;test7.ml:116,35-52;test7.ml:10,41-78} + signed int32[b:V/62 + 16] := new_value:I/76 (assign){test7.ml:121,2-13;test7.ml:116,4-52} + Parraysetu:I/77 := 1 + I/78 := signed int32 mut[b:V/62 + 20]{test7.ml:122,2-13;test7.ml:115,12-42} + I/79 := signed int32 mut[a:V/61 + 20]{test7.ml:122,2-13;test7.ml:114,12-42} + I/80 := I/79 + I/80 := I/80 + I/78{test7.ml:122,2-13;test7.ml:116,35-52;test7.ml:10,41-78} + new_value:I/81 := sextend32 I/80{test7.ml:122,2-13;test7.ml:116,35-52;test7.ml:10,41-78} + signed int32[b:V/62 + 20] := new_value:I/81 (assign){test7.ml:122,2-13;test7.ml:116,4-52} + Parraysetu:I/82 := 1 + I/83 := 1 + R:I/0[%rax] := I/83 + return R:I/0[%rax] +*) +let print_t1 ppf (t1 : t1) = + Format.fprintf ppf "{ d0 = %ld ; d1 = %ld; d2 = %ld ; d3 = %ld }" + (Int32_u.to_int32 t1.d0) + (Int32_u.to_int32 t1.d1) + (Int32_u.to_int32 t1.d2) + (Int32_u.to_int32 t1.d3) + +let print_array ~len ppf ( a : Int32_u.t array)= + for i = 0 to len - 1 do + let x = Int32_u.Array.unsafe_get a i in + Format.fprintf ppf "%ld " (x |> Int32_u.to_int32) + done + +let create_array ~len ~init = + let arr = Int32_u.Array.unsafe_create len in + for i = 0 to len-1 do + Int32_u.Array.unsafe_set arr i init + done; + arr + +let () = + let a = { d0 = #8l; d1 = #96l; d2 = -#10l; d3 = #0l } in + let b = { d0 = #80l; d1 = #14l; d2 = -#30l; d3 = -#100l } in + let c = { d0 = #8l; d1 = #96l; d2 = #0l; d3 = #0l } in + Format.printf "add_mutable_record %a\n" print_t1 + (add_mutable_record a b c); + let ar1 = create_array ~len:4 ~init:#30l in + let ar2 = create_array ~len:4 ~init:#0l in + copy_array_four ar1 ar2 ~pos:0; + Format.printf "copy_array_four %a\n" (print_array ~len:4) ar2; + copy_array_index_four ar2 ar1 ~pos:#0l; + Format.printf "copy_array_index_four %a\n" (print_array ~len:4) ar1; + add_array_from_start ar1 ar2; + Format.printf "add_array_from_start %a\n" (print_array ~len:4) ar2; + copy_array_index_from_start ar2 ar1; + Format.printf "copy_array_index_from_start %a\n" (print_array ~len:4) ar1; + copy_array_from_start ar1 ar2; + Format.printf "copy_array_from_start %a\n" (print_array ~len:4) ar2; + copy_array_four_v2 ar1 ar2 ~pos:0; + Format.printf "copy_array_from_start_v2 %a\n" (print_array ~len:4) ar2; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.mli b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_int32_unboxed_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..fef3d590f81 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int32_unboxed_vectorized.cmx.dump.expected @@ -0,0 +1,3 @@ +**** Vectorize selected computation: 2 groups, 8 scalar instructions, 2 vector instructions, cost = -6 (Test_int32_unboxed_vectorized.copy_array_four_v2) +**** Vectorize selected computation: 2 groups, 8 scalar instructions, 2 vector instructions, cost = -6 (Test_int32_unboxed_vectorized.copy_array_index_from_start) +**** Vectorize selected computation: 2 groups, 8 scalar instructions, 2 vector instructions, cost = -6 (Test_int32_unboxed_vectorized.copy_array_from_start) diff --git a/flambda-backend/tests/backend/vectorizer/test_int64.expected b/flambda-backend/tests/backend/vectorizer/test_int64.expected new file mode 100644 index 00000000000..21d3934339d --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64.expected @@ -0,0 +1,7 @@ +add_mutable_record { d0 = 88 ; d1 = 110 } +copy_mutable_record { d0 = 88 ; d1 = 110 } +add_mutable_record_fresh { d0 = 88 ; d1 = 110 } +copy_mutable_record_fresh { d0 = 88 ; d1 = 110 } +add_mutable_record_t4 { d0 = 88 ; d1 = 110; d2 = 88 ; d3 = 110 } +copy_mutable_record_t4 { d0 = 8 ; d1 = 96; d2 = 80 ; d3 = 14 } +dup_mutable_record_t4 { d0 = 8 ; d1 = 96; d2 = 8 ; d3 = 96 } diff --git a/flambda-backend/tests/backend/vectorizer/test_int64.ml b/flambda-backend/tests/backend/vectorizer/test_int64.ml new file mode 100644 index 00000000000..95603dd7773 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64.ml @@ -0,0 +1,79 @@ +[@@@ocaml.warnerror "+a-40-41-42"] + +type t1 = + { mutable d0 : int64; + mutable d1 : int64 + } + +(* Can't vectorize because int64 are boxed. *) +let[@inline never] [@local never] [@specialize never] add_mutable_record + (a : t1) (b : t1) (c : t1) : t1 = + c.d0 <- Int64.add a.d0 b.d0; + c.d1 <- Int64.add a.d1 b.d1; + c + +(* Can't vectorize because memory write requires [caml_modify]. *) +let[@inline never] [@local never] [@specialize never] copy_mutable_record + (a : t1) (b : t1) : t1 = + b.d0 <- a.d0; + b.d1 <- a.d1; + b + +(* Can't vectorize because int64 are boxed *) +let[@inline never] [@local never] [@specialize never] add_mutable_record_fresh + (a : t1) (b : t1) : t1 = + { d0 = Int64.add a.d0 b.d0; d1 = Int64.add a.d1 b.d1 } + +let[@inline never] [@local never] [@specialize never] copy_mutable_record_fresh + (a : t1) : t1 = + { d0 = a.d0; d1 = a.d1 } + +type t4 = + { mutable d0 : int64; + mutable d1 : int64; + mutable d2 : int64; + mutable d3 : int64 + } + +(* Can't vectorize because int64 are boxed. *) +let[@inline never] [@local never] [@specialize never] add_mutable_record_t4 + (a : t1) (b : t1) (c : t4) : t4 = + c.d0 <- Int64.add a.d0 b.d0; + c.d1 <- Int64.add a.d1 b.d1; + c.d2 <- Int64.add a.d0 b.d0; + c.d3 <- Int64.add a.d1 b.d1; + c + +let[@inline never] [@local never] [@specialize never] copy_mutable_record_t4 + (a : t1) (b : t1) : t4 = + { d0 = a.d0; d1 = a.d1; d2 = b.d0; d3 = b.d1 } + +let[@inline never] [@local never] [@specialize never] dup_mutable_record_t4 + (a : t1) : t4 = + { d0 = a.d0; d1 = a.d1; d2 = a.d0; d3 = a.d1 } + +let print_t1 ppf (t1 : t1) = + Format.fprintf ppf "{ d0 = %Ld ; d1 = %Ld }" t1.d0 t1.d1 + +let print_t4 ppf (t4 : t4) = + Format.fprintf ppf "{ d0 = %Ld ; d1 = %Ld; d2 = %Ld ; d3 = %Ld }" t4.d0 t4.d1 + t4.d2 t4.d3 + +let () = + let a = { d0 = 8L; d1 = 96L } in + let b = { d0 = 80L; d1 = 14L } in + let c = { d0 = 10L; d1 = -10L } in + let t4 = { d0 = 10L; d1 = -10L; d2 = 199L; d3 = 18L } in + let res = { d0 = 0L; d1 = -0L } in + Format.printf "add_mutable_record %a\n" print_t1 (add_mutable_record a b c); + Format.printf "copy_mutable_record %a\n" print_t1 (copy_mutable_record c res); + Format.printf "add_mutable_record_fresh %a\n" print_t1 + (add_mutable_record_fresh a b); + Format.printf "copy_mutable_record_fresh %a\n" print_t1 + (copy_mutable_record_fresh c); + Format.printf "add_mutable_record_t4 %a\n" print_t4 + (add_mutable_record_t4 a b t4); + Format.printf "copy_mutable_record_t4 %a\n" print_t4 + (copy_mutable_record_t4 a b); + Format.printf "dup_mutable_record_t4 %a\n" print_t4 (dup_mutable_record_t4 a); + () diff --git a/flambda-backend/tests/backend/vectorizer/test_int64.mli b/flambda-backend/tests/backend/vectorizer/test_int64.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.expected b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.expected new file mode 100644 index 00000000000..68b6515c901 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.expected @@ -0,0 +1,3 @@ +add_mutable_record { d0 = 88 ; d1 = 110 } +copy_mutable_record { d0 = 88 ; d1 = 110 } +add_fours_mutable_record { d0 = 88 ; d1 = 110; d2 = 88 ; d3 = 110 } diff --git a/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.ml b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.ml new file mode 100644 index 00000000000..d9371e65e8f --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.ml @@ -0,0 +1,61 @@ +[@@@ocaml.warnerror "+a-40-41-42"] + +module Int64_u = struct + type t = int64# + + external to_int64 : t -> (int64[@local_opt]) = "%box_int64" [@@warning "-187"] + + external of_int64 : (int64[@local_opt]) -> t = "%unbox_int64" [@@warning "-187"] + + let[@inline always] add x y = of_int64 (Int64.add (to_int64 x) (to_int64 y)) +end + +type t1 = { mutable d0 : int64# ; mutable d1: int64# } + +let[@inline never] [@local never][@specialize never] add_mutable_record (a : t1) (b: t1) (c : t1) : t1 = + c.d0 <- Int64_u.add a.d0 b.d0; + c.d1 <- Int64_u.add a.d1 b.d1; + c + +let[@inline never] [@local never][@specialize never] copy_mutable_record (a : t1) (b: t1) : unit = + b.d0 <- a.d0; + b.d1 <- a.d1; + () + +type t2 = { + mutable d0 : int64# ; + mutable d1: int64# ; + mutable d2: int64# ; + mutable d3: int64# } + +let[@inline never] [@local never][@specialize never] add_fours_mutable_record (a : t1) (b: t1) (c : t2) : unit = + c.d0 <- Int64_u.add a.d0 b.d0; + c.d1 <- Int64_u.add a.d1 b.d1; + c.d2 <- Int64_u.add a.d0 b.d0; + c.d3 <- Int64_u.add a.d1 b.d1; + () + +let print_t1 ppf (t1 : t1) = + Format.fprintf ppf "{ d0 = %Ld ; d1 = %Ld }" (Int64_u.to_int64 t1.d0) + (Int64_u.to_int64 t1.d1) + +let print_t4 ppf (t2 : t2) = + Format.fprintf ppf "{ d0 = %Ld ; d1 = %Ld; d2 = %Ld ; d3 = %Ld }" + (Int64_u.to_int64 t2.d0) + (Int64_u.to_int64 t2.d1) + (Int64_u.to_int64 t2.d2) + (Int64_u.to_int64 t2.d3) + +let () = + let a = { d0 = #8L; d1 = #96L } in + let b = { d0 = #80L; d1 = #14L } in + let c = { d0 = #8L; d1 = #96L } in + let d = { d0 = #0L; d1 = #0L; d2 = #0L; d3 = #0L } in + let res = { d0 = #0L; d1 = -#10L } in + Format.printf "add_mutable_record %a\n" print_t1 + (add_mutable_record a b c); + copy_mutable_record c res; + Format.printf "copy_mutable_record %a\n" print_t1 res; + add_fours_mutable_record a b d; + Format.printf "add_fours_mutable_record %a\n" print_t4 d; + () diff --git a/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.mli b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_int64_unboxed_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..61eea8dffce --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64_unboxed_vectorized.cmx.dump.expected @@ -0,0 +1,3 @@ +**** Vectorize selected computation: 5 groups, 10 scalar instructions, 5 vector instructions, cost = -5 (Test_int64_unboxed_vectorized.add_mutable_record) +**** Vectorize selected computation: 2 groups, 4 scalar instructions, 2 vector instructions, cost = -2 (Test_int64_unboxed_vectorized.copy_mutable_record) +**** Vectorize selected computation: 10 groups, 20 scalar instructions, 10 vector instructions, cost = -10 (Test_int64_unboxed_vectorized.add_fours_mutable_record) diff --git a/flambda-backend/tests/backend/vectorizer/test_int64_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_int64_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..6db1b67d70d --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_int64_vectorized.cmx.dump.expected @@ -0,0 +1,3 @@ +**** Vectorize selected computation: 2 groups, 4 scalar instructions, 2 vector instructions, cost = -2 (Test_int64_vectorized.copy_mutable_record_fresh) +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 4 vector instructions, cost = -4 (Test_int64_vectorized.copy_mutable_record_t4) +**** Vectorize selected computation: 4 groups, 8 scalar instructions, 4 vector instructions, cost = -4 (Test_int64_vectorized.dup_mutable_record_t4) diff --git a/flambda-backend/tests/backend/vectorizer/test_register_compatible.expected b/flambda-backend/tests/backend/vectorizer/test_register_compatible.expected new file mode 100644 index 00000000000..033dec12b51 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_register_compatible.expected @@ -0,0 +1 @@ +make 8 8 diff --git a/flambda-backend/tests/backend/vectorizer/test_register_compatible.ml b/flambda-backend/tests/backend/vectorizer/test_register_compatible.ml new file mode 100644 index 00000000000..479f326d936 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_register_compatible.ml @@ -0,0 +1,70 @@ +(* Cannot vectorize this example because different candidate computations use + the same register as both address and non-address arguments. *) +type s = + | A + | B + +type fn = int -> int + +type r = + { c1 : fn; + c2 : fn + } + +type t = + { d1 : int; + d2 : int; + d3 : int; + d4 : r; + d5 : r; + d6 : int + } + +type r' = + { b0 : s; + b1 : r; + b2 : r + } + +type t' = + { a1 : fn; + a2 : fn; + a3 : fn; + a4 : fn; + a5 : s; + a6 : r; + a7 : r; + a8 : r' + } + +let b0 = Sys.opaque_identity A + +let[@inline never] [@local never] [@specialize never] make t = + let d4 = t.d4 in + let d5 = t.d5 in + let r' = { b1 = d4; b2 = d5; b0 } in + { a1 = d4.c1; + a2 = d4.c2; + a3 = d5.c1; + a4 = d5.c2; + a5 = Sys.opaque_identity A; + a6 = d4; + a7 = d5; + a8 = r' + } + +let print ppf t' = Format.fprintf ppf "%d %d" + +let () = + let t = + { d1 = 1; + d2 = 2; + d3 = 3; + d4 = { c1 = Int.add 1; c2 = Int.mul 3 }; + d5 = { c1 = Int.add 2; c2 = Int.mul 4 }; + d6 = 6 + } + in + let res = make t in + let i = Sys.opaque_identity 7 in + Format.printf "make %d %d\n" (res.a1 i) (res.a6.c1 i) diff --git a/flambda-backend/tests/backend/vectorizer/test_register_compatible.mli b/flambda-backend/tests/backend/vectorizer/test_register_compatible.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_register_compatible.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/examples.expected b/flambda-backend/tests/backend/vectorizer/test_spill_valx2.expected similarity index 100% rename from flambda-backend/tests/backend/vectorizer/examples.expected rename to flambda-backend/tests/backend/vectorizer/test_spill_valx2.expected diff --git a/flambda-backend/tests/backend/vectorizer/test_spill_valx2.ml b/flambda-backend/tests/backend/vectorizer/test_spill_valx2.ml new file mode 100644 index 00000000000..2120c1fe2a0 --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_spill_valx2.ml @@ -0,0 +1,709 @@ +(* Test that spilled registers of type [Valx2] are correctly registered with the + GC. + + Need at least 16 registers of 128 bit to trigger the spill on amd64. + + Allocate enough to defeat comballoc that moves allocations to the beginning + of the block and out of the live range of the register that this test is + aiming to spill. Raise [vectorize-max-block-size] to force the resulting very + long block to be vectorized. *) +type s = + { mutable f0 : int64; + mutable f1 : int64; + mutable f2 : int64; + mutable f3 : int64; + mutable f4 : int64; + mutable f5 : int64; + mutable f6 : int64; + mutable f7 : int64; + mutable f8 : int64; + mutable f9 : int64; + mutable f10 : int64; + mutable f11 : int64; + mutable f12 : int64; + mutable f13 : int64; + mutable f14 : int64; + mutable f15 : int64; + mutable f16 : int64; + mutable f17 : int64; + mutable f18 : int64; + mutable f19 : int64; + mutable f20 : int64; + mutable f21 : int64; + mutable f22 : int64; + mutable f23 : int64; + mutable f24 : int64; + mutable f25 : int64; + mutable f26 : int64; + mutable f27 : int64; + mutable f28 : int64; + mutable f29 : int64; + mutable f30 : int64; + mutable f31 : int64; + mutable f32 : int64; + mutable f33 : int64; + mutable f34 : int64; + mutable f35 : int64 + } + +let ( + ) = Int64.add + +let[@inline never] [@local never] foo a = + let f0 = a.f0 in + let f1 = a.f1 in + let f2 = a.f2 in + let f3 = a.f3 in + let f4 = a.f4 in + let f5 = a.f5 in + let f6 = a.f6 in + let f7 = a.f7 in + let f8 = a.f8 in + let f9 = a.f9 in + let f10 = a.f10 in + let f11 = a.f11 in + let f12 = a.f12 in + let f13 = a.f13 in + let f14 = a.f14 in + let f15 = a.f15 in + let f16 = a.f16 in + let f17 = a.f17 in + let f18 = a.f18 in + let f19 = a.f19 in + let f20 = a.f20 in + let f21 = a.f21 in + let f22 = a.f22 in + let f23 = a.f23 in + let f24 = a.f24 in + let f25 = a.f25 in + let f26 = a.f26 in + let f27 = a.f27 in + let f28 = a.f28 in + let f29 = a.f29 in + let f30 = a.f30 in + let f31 = a.f31 in + let f32 = a.f32 in + let f33 = a.f33 in + let f34 = a.f34 in + let f35 = a.f35 in + let d0 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d1 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d2 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d3 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d4 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d5 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d6 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d7 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d8 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + let d9 = + { f0; + f1; + f2; + f3; + f4; + f5; + f6; + f7; + f8; + f9; + f10; + f11; + f12; + f13; + f14; + f15; + f16; + f17; + f18; + f19; + f20; + f21; + f22; + f23; + f24; + f25; + f26; + f27; + f28; + f29; + f30; + f31; + f32; + f33; + f34; + f35 + } + in + d0, d1, d2, d3, d4, d5, d6, d7, d8, d9 + +let () = + let a = + { f0 = 0L; + f1 = 1L; + f2 = 2L; + f3 = 3L; + f4 = 4L; + f5 = 5L; + f6 = 6L; + f7 = 7L; + f8 = 8L; + f9 = 9L; + f10 = 10L; + f11 = 11L; + f12 = 12L; + f13 = 13L; + f14 = 14L; + f15 = 15L; + f16 = 16L; + f17 = 17L; + f18 = 18L; + f19 = 19L; + f20 = 20L; + f21 = 21L; + f22 = 22L; + f23 = 23L; + f24 = 24L; + f25 = 25L; + f26 = 26L; + f27 = 27L; + f28 = 28L; + f29 = 29L; + f30 = 30L; + f31 = 31L; + f32 = 32L; + f33 = 0L; + f34 = 0L; + f35 = 0L + } + in + (* Gc.set { (Gc.get()) with Gc.verbose = 0xd }; *) + let rec loop n = + if n = 0 + then () + else + (* try to trigger GC inside foo *) + let d0, d1, d2, d3, d4, d5, d6, d7, d8, d9 = foo a in + assert (d0.f0 = d1.f0); + assert (d0.f1 = d1.f1); + assert (d0.f2 = d1.f2); + assert (d0.f3 = d1.f3); + assert (d0.f4 = d1.f4); + assert (d0.f5 = d1.f5); + assert (d0.f6 = d1.f6); + assert (d0.f7 = d1.f7); + assert (d0.f8 = d1.f8); + assert (d0.f9 = d1.f9); + assert (d0.f10 = d1.f10); + assert (d0.f11 = d1.f11); + assert (d0.f12 = d1.f12); + assert (d0.f13 = d1.f13); + assert (d0.f14 = d1.f14); + assert (d0.f15 = d1.f15); + assert (d0.f16 = d1.f16); + assert (d0.f17 = d1.f17); + assert (d0.f18 = d1.f18); + assert (d0.f19 = d1.f19); + assert (d0.f20 = d1.f20); + assert (d0.f21 = d1.f21); + assert (d0.f22 = d1.f22); + assert (d0.f23 = d1.f23); + assert (d0.f24 = d1.f24); + assert (d0.f25 = d1.f25); + assert (d0.f26 = d1.f26); + assert (d0.f27 = d1.f27); + assert (d0.f28 = d1.f28); + assert (d0.f29 = d1.f29); + assert (d0.f30 = d1.f30); + assert (d0.f31 = d1.f31); + assert (d0.f32 = d1.f32); + assert (d0.f33 = d1.f33); + assert (d0.f34 = d1.f34); + assert (d0.f35 = d1.f35); + assert (d0.f0 = d2.f0); + assert (d0.f1 = d2.f1); + assert (d0.f2 = d2.f2); + assert (d0.f3 = d2.f3); + assert (d0.f4 = d2.f4); + assert (d0.f5 = d2.f5); + assert (d0.f6 = d2.f6); + assert (d0.f7 = d2.f7); + assert (d0.f8 = d2.f8); + assert (d0.f9 = d2.f9); + assert (d0.f10 = d2.f10); + assert (d0.f11 = d2.f11); + assert (d0.f12 = d2.f12); + assert (d0.f13 = d2.f13); + assert (d0.f14 = d2.f14); + assert (d0.f15 = d2.f15); + assert (d0.f16 = d2.f16); + assert (d0.f17 = d2.f17); + assert (d0.f18 = d2.f18); + assert (d0.f19 = d2.f19); + assert (d0.f20 = d2.f20); + assert (d0.f21 = d2.f21); + assert (d0.f22 = d2.f22); + assert (d0.f23 = d2.f23); + assert (d0.f24 = d2.f24); + assert (d0.f25 = d2.f25); + assert (d0.f26 = d2.f26); + assert (d0.f27 = d2.f27); + assert (d0.f28 = d2.f28); + assert (d0.f29 = d2.f29); + assert (d0.f30 = d2.f30); + assert (d0.f31 = d2.f31); + assert (d0.f32 = d2.f32); + assert (d0.f33 = d2.f33); + assert (d0.f34 = d2.f34); + assert (d0.f35 = d2.f35); + assert (d0.f0 = d3.f0); + assert (d0.f1 = d3.f1); + assert (d0.f2 = d3.f2); + assert (d0.f3 = d3.f3); + assert (d0.f4 = d3.f4); + assert (d0.f5 = d3.f5); + assert (d0.f6 = d3.f6); + assert (d0.f7 = d3.f7); + assert (d0.f8 = d3.f8); + assert (d0.f9 = d3.f9); + assert (d0.f10 = d3.f10); + assert (d0.f11 = d3.f11); + assert (d0.f12 = d3.f12); + assert (d0.f13 = d3.f13); + assert (d0.f14 = d3.f14); + assert (d0.f15 = d3.f15); + assert (d0.f16 = d3.f16); + assert (d0.f17 = d3.f17); + assert (d0.f18 = d3.f18); + assert (d0.f19 = d3.f19); + assert (d0.f20 = d3.f20); + assert (d0.f21 = d3.f21); + assert (d0.f22 = d3.f22); + assert (d0.f23 = d3.f23); + assert (d0.f24 = d3.f24); + assert (d0.f25 = d3.f25); + assert (d0.f26 = d3.f26); + assert (d0.f27 = d3.f27); + assert (d0.f28 = d3.f28); + assert (d0.f29 = d3.f29); + assert (d0.f30 = d3.f30); + assert (d0.f31 = d3.f31); + assert (d0.f32 = d3.f32); + assert (d0.f33 = d3.f33); + assert (d0.f34 = d3.f34); + assert (d0.f35 = d3.f35); + assert (d1.f0 = d8.f0); + assert (d1.f1 = d8.f1); + assert (d1.f2 = d8.f2); + assert (d1.f3 = d8.f3); + assert (d1.f4 = d8.f4); + assert (d1.f5 = d8.f5); + assert (d1.f6 = d8.f6); + assert (d1.f7 = d8.f7); + assert (d1.f8 = d8.f8); + assert (d0.f9 = d8.f9); + assert (d0.f10 = d8.f10); + assert (d0.f11 = d8.f11); + assert (d0.f12 = d8.f12); + assert (d0.f13 = d8.f13); + assert (d0.f14 = d8.f14); + assert (d0.f15 = d8.f15); + assert (d0.f16 = d8.f16); + assert (d0.f17 = d8.f17); + assert (d0.f18 = d8.f18); + assert (d0.f19 = d8.f19); + assert (d0.f20 = d8.f20); + assert (d0.f21 = d8.f21); + assert (d0.f22 = d8.f22); + assert (d0.f23 = d8.f23); + assert (d0.f24 = d8.f24); + assert (d0.f25 = d8.f25); + assert (d0.f26 = d8.f26); + assert (d0.f27 = d8.f27); + assert (d0.f28 = d8.f28); + assert (d0.f29 = d8.f29); + assert (d0.f30 = d8.f30); + assert (d0.f31 = d8.f31); + assert (d0.f32 = d8.f32); + assert (d0.f33 = d8.f33); + assert (d0.f34 = d8.f34); + assert (d0.f35 = d8.f35); + assert (d0.f0 = d9.f0); + assert (d0.f1 = d9.f1); + assert (d0.f2 = d9.f2); + assert (d0.f3 = d9.f3); + assert (d0.f4 = d9.f4); + assert (d0.f5 = d9.f5); + assert (d0.f6 = d9.f6); + assert (d0.f7 = d9.f7); + assert (d0.f8 = d9.f8); + assert (d0.f9 = d9.f9); + assert (d0.f10 = d9.f10); + assert (d0.f11 = d9.f11); + assert (d0.f12 = d9.f12); + assert (d0.f13 = d9.f13); + assert (d0.f14 = d9.f14); + assert (d0.f15 = d9.f15); + assert (d0.f16 = d9.f16); + assert (d0.f17 = d9.f17); + assert (d0.f18 = d9.f18); + assert (d0.f19 = d9.f19); + assert (d0.f20 = d9.f20); + assert (d0.f21 = d9.f21); + assert (d0.f22 = d9.f22); + assert (d0.f23 = d9.f23); + assert (d0.f24 = d9.f24); + assert (d0.f25 = d9.f25); + assert (d0.f26 = d9.f26); + assert (d0.f27 = d9.f27); + assert (d0.f28 = d9.f28); + assert (d0.f29 = d9.f29); + assert (d0.f30 = d9.f30); + assert (d0.f31 = d9.f31); + assert (d0.f32 = d9.f32); + assert (d0.f33 = d9.f33); + assert (d0.f34 = d9.f34); + assert (d0.f35 = d9.f35); + loop (n - 1) + in + loop 1_000_000 diff --git a/flambda-backend/tests/backend/vectorizer/test_spill_valx2.mli b/flambda-backend/tests/backend/vectorizer/test_spill_valx2.mli new file mode 100644 index 00000000000..5b909d90a8c --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_spill_valx2.mli @@ -0,0 +1 @@ +(* blank, make sure all the functions are called from top-level *) diff --git a/flambda-backend/tests/backend/vectorizer/test_spill_valx2_vectorized.cmx.dump.expected b/flambda-backend/tests/backend/vectorizer/test_spill_valx2_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..9f75a15662f --- /dev/null +++ b/flambda-backend/tests/backend/vectorizer/test_spill_valx2_vectorized.cmx.dump.expected @@ -0,0 +1 @@ +**** Vectorize selected computation: 198 groups, 396 scalar instructions, 198 vector instructions, cost = -198 (Test_spill_valx2_vectorized.foo) diff --git a/flambda-backend/tests/intrinsics/atomics.ml b/flambda-backend/tests/intrinsics/atomics.ml new file mode 100644 index 00000000000..796dec01c53 --- /dev/null +++ b/flambda-backend/tests/intrinsics/atomics.ml @@ -0,0 +1,67 @@ + +let r = Atomic.make 1 +let () = assert (Atomic.get r = 1) + +let () = Atomic.set r 2 +let () = assert (Atomic.get r = 2) + +let () = assert (Atomic.exchange r 3 = 2) + +let () = assert (Atomic.compare_and_set r 3 4 = true) +let () = assert (Atomic.get r = 4) + +let () = assert (Atomic.compare_and_set r 3 (-4) = false) +let () = assert (Atomic.get r = 4 ) + +let () = assert (Atomic.compare_and_set r 3 4 = false) + +let () = assert (Atomic.fetch_and_add r 2 = 4) +let () = assert (Atomic.get r = 6) + +let () = assert (Atomic.fetch_and_add r (-2) = 6) +let () = assert (Atomic.get r = 4) + +let () = assert ((Atomic.incr r; Atomic.get r) = 5) + +let () = assert ((Atomic.decr r; Atomic.get r) = 4) + +let () = assert ((Atomic.add r 3; Atomic.get r) = 7) +let () = assert ((Atomic.sub r 3; Atomic.get r) = 4) +let () = assert ((Atomic.logand r 2; Atomic.get r) = 0) +let () = assert ((Atomic.logor r 2; Atomic.get r) = 2) +let () = assert ((Atomic.logxor r 3; Atomic.get r) = 1) + +let () = + let r = Atomic.make 0 in + let cur = Atomic.get r in + ignore (Atomic.set r (cur + 1), Atomic.set r (cur - 1)); + assert (Atomic.get r <> cur) + +let () = + let r = Atomic.make 0 in + let cur = Atomic.get r in + ignore (Atomic.incr r, Atomic.decr r); + assert (Atomic.get r = cur) + +(* Test primitives with non-immediate types *) + +let a = ref 1 +let r = Atomic.make a +let () = assert (Atomic.get r == a) + +let b = ref 2 +let () = Atomic.set r b +let () = assert (Atomic.get r == b) + +let c = ref 3 +let () = assert (Atomic.exchange r c == b) + +let d = ref 4 +let () = assert (Atomic.compare_and_set r c d = true) +let () = assert (Atomic.get r == d) + +let e = ref (-4) +let () = assert (Atomic.compare_and_set r c e = false) +let () = assert (Atomic.get r == d) + +let () = assert (Atomic.compare_and_set r c d = false) diff --git a/flambda-backend/tests/intrinsics/dune b/flambda-backend/tests/intrinsics/dune index 025997d3eb1..efd593ae57f 100644 --- a/flambda-backend/tests/intrinsics/dune +++ b/flambda-backend/tests/intrinsics/dune @@ -1,5 +1,45 @@ (rule - (alias runtest) - (enabled_if (= %{context_name} "main")) + (alias runtest) + (enabled_if + (= %{context_name} "main")) (deps select_float.ml) - (action (run %{bin:ocamlopt.opt} %{deps} -c))) + (action + (run %{bin:ocamlopt.opt} %{deps} -c))) + +; Test atomics with binary emitter - not supported on macOS + +(executables + (names atomics) + (modules atomics) + (enabled_if + (and + (= %{context_name} "main") + (= %{architecture} "amd64") + (<> %{system} macosx))) + (ocamlopt_flags + (:standard -internal-assembler))) + +(rule + (enabled_if + (and + (= %{context_name} "main") + (= %{architecture} "amd64") + (<> %{system} macosx))) + (targets atomics.out) + (deps atomics.exe) + (action + (progn + (with-outputs-to + atomics.out + (run ./atomics.exe))))) + +(rule + (alias runtest) + (enabled_if + (and + (= %{context_name} "main") + (= %{architecture} "amd64") + (<> %{system} macosx))) + (action + (progn + (diff empty.expected atomics.out)))) diff --git a/flambda-backend/tests/intrinsics/empty.expected b/flambda-backend/tests/intrinsics/empty.expected new file mode 100644 index 00000000000..e69de29bb2d diff --git a/flambda-backend/testsuite/tools/expect.ml b/flambda-backend/testsuite/tools/expect.ml index f0772c1866c..694a3cb0920 100644 --- a/flambda-backend/testsuite/tools/expect.ml +++ b/flambda-backend/testsuite/tools/expect.ml @@ -385,6 +385,9 @@ let usage = "Usage: expect_test [script-file [arguments]]\n\ options are:" let () = + (* Some tricky typing tests cause stack overflows in the compiler. + Bounding the compiler's stack size makes that happen faster. *) + Gc.set {(Gc.get ()) with stack_limit = 1_000_000}; (* Early disabling of colors in any output *) let () = Clflags.color := Some Misc.Color.Never; diff --git a/jane/doc/extensions/modes/reference.md b/jane/doc/extensions/modes/reference.md new file mode 100644 index 00000000000..0df097c5056 --- /dev/null +++ b/jane/doc/extensions/modes/reference.md @@ -0,0 +1,42 @@ +The goal of this document is to be a reasonably complete reference to the mode system in +OCaml. + + + +The mode system in the compiler tracks various properties of values, so that certain +performance-enhancing operations can be performed safely. For example: +- Locality tracks escaping. See [the local allocations reference](../local/reference.md) +- Uniqueness and linearity tracks aliasing. See [the uniqueness reference](../uniqueness/reference.md) +- Portability and contention tracks inter-thread sharing. + + +# Lazy +`lazy e` contains a thunk that evaluates `e`, as well as a mutable cell to store the +result of `e`. Upon construction, the mode of `lazy e` cannot be stronger than `e`. For +example, if `e` is `nonportable`, then `lazy e` cannot be `portable`. Upon destruction +(forcing a lazy value), the result cannot be stronger than the mode of lazy value. For +example, forcing a `nonportable` lazy value cannot give a `portable` result. Additionally, +forcing a lazy value involves accessing the mutable cell and thus requires the lazy value +to be `uncontended`. + +Currently, the above rules don't apply to the locality axis, because both the result and +the lazy value are heap-allocated, so they are always `global`. + +Additionally, upon construction, the comonadic fragment of `lazy e` cannot be stronger +than the thunk. The thunk is checked as `fun () -> e`, potentially closing over variables, +which weakens its comonadic fragment. This rule doesn't apply to several axes: +- The thunk is always heap-allocated so always `global`. +- Since the thunk is only evaluated if the lazy value is `uncontended`, one can construct +a lazy value at `portable` even if the thunk is `nonportable` (e.g., closing over +`uncontended` or `nonportable` values). For example, the following is allowed: +```ocaml +let r = ref 0 in +let l @ portable = lazy (r := 42) in +``` +- Since the thunk runs at most once even if the lazy value is forced multiple times, one +can construct the lazy value at `many` even if the thunk is `once` (e.g., closing over +`unique` or `once` values). For example, the following is allowed: +```ocaml +let r = { x = 0 } in +let l @ many = lazy (overwrite_ r with { x = 42 }) +``` diff --git a/jane/doc/extensions/unboxed-types/index.md b/jane/doc/extensions/unboxed-types/index.md index 2680d92a41e..27b7c30a7ec 100644 --- a/jane/doc/extensions/unboxed-types/index.md +++ b/jane/doc/extensions/unboxed-types/index.md @@ -225,31 +225,52 @@ modules in the `janestreet_shims` library.) The unboxed product layout describes types that work like normal products (e.g., tuples or records), but which are represented without a box. -In OCaml, a tuple is a pointer to a block containg the elements of the tuple. If +In OCaml, a tuple is a pointer to a block containing the elements of the tuple. If you pass a tuple to a function, it is passed by reference in one register. The -function can access the tuple's elements through the pointer. By contrast, an +function can access the tuple's elements through the pointer. Records and +their fields are treated similarly. By contrast, an unboxed product does not refer to a block at all. When used as a function argument or return type, its elements are passed separately in their own -registers, with no indirection (or on the call stack, if the tuple has more +registers, with no indirection (or on the call stack, if the product has more elements than there are available registers). -Currently the only types that have unboxed product layouts are *unboxed tuples*. -Unboxed tuples are written `#(...)`. So, for example, you can write: +Currently, types that have unboxed product layouts are *unboxed tuples* and +*unboxed records*. + +Unboxed tuples are written `#(...)`, and may have labels just like normal tuples. +So, for example, you can write: ```ocaml module Flipper : sig - val flip : #(int * float# * string) -> #(string * float# * int) + val flip : #(int * float# * lbl:string) -> #(lbl:string * float# * int) end = struct - let flip #(x,y,z) = #(z,y,x) + let flip #(x,y,~lbl:z) = #(~lbl:z,y,x) end ``` -Unboxed tuples may have labels just like normal tuples. There are no limitations -on the layouts of the elements of unboxed tuples, and they may be nested within -themselves. - -*Limitations and future plans*: Unboxed tuples may not currently placed in -blocks. We plan to lift this restriction in the near future. We also plan to add -other types with unboxed product layouts (e.g., unboxed records and interior -pointers). + +Unboxed records are defined, constructed, and matched on like normal records, but with +a leading hash. For example: +```ocaml +type t = #{ f : float# ; s : string } +let inc #{ f ; s } = #{ f = Float_u.add f #1.0 ; s } +``` + +The field names of unboxed records occupy a different namespace from the +field names of "normal" (including `[@@unboxed]`) records. + +Unboxed tuples and records may be nested within other unboxed tuples and records. +There are no limitations on the layouts of the elements of unboxed tuples, but the fields +of unboxed records must be representable. + +*Limitations and future plans*: +- Unboxed products may not currently placed in blocks. + We plan to lift this restriction in the near future. +- Unboxed record fields may not be mutable. + We plan to allow mutating unboxed records within boxed records + (the design will differ from boxed record mutability, as unboxed types don't have the + same notion of identity). +- Unboxed record fields must be representable. + We plan to lift this restriction in the future. +- We plan to add other types with unboxed product layouts (e.g., interior pointers). # The `any` layout diff --git a/lambda/lambda.ml b/lambda/lambda.ml index a151ee51b1d..c08d76005a3 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -43,6 +43,10 @@ type field_read_semantics = | Reads_agree | Reads_vary +type has_initializer = + | With_initializer + | Uninitialized + include (struct type locality_mode = @@ -149,6 +153,7 @@ type primitive = (* Unboxed products *) | Pmake_unboxed_product of layout list | Punboxed_product_field of int * layout list + | Parray_element_size_in_bytes of array_kind (* Context switches *) | Prunstack | Pperform @@ -189,9 +194,12 @@ type primitive = | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag * locality_mode - | Pmakearray_dynamic of array_kind * locality_mode + | Pmakearray_dynamic of array_kind * locality_mode * has_initializer | Pduparray of array_kind * mutable_flag - | Parrayblit of array_set_kind (* Kind of the dest array. *) + | Parrayblit of { + src_mutability : mutable_flag; + dst_array_set_kind : array_set_kind; + } | Parraylength of array_kind | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag | Parraysetu of array_set_kind * array_index_kind @@ -303,10 +311,15 @@ type primitive = | Pint_as_pointer of locality_mode (* Atomic operations *) | Patomic_load of {immediate_or_pointer : immediate_or_pointer} - | Patomic_exchange - | Patomic_compare_exchange - | Patomic_cas + | Patomic_exchange of {immediate_or_pointer : immediate_or_pointer} + | Patomic_compare_exchange of {immediate_or_pointer : immediate_or_pointer} + | Patomic_compare_set of {immediate_or_pointer : immediate_or_pointer} | Patomic_fetch_add + | Patomic_add + | Patomic_sub + | Patomic_land + | Patomic_lor + | Patomic_lxor (* Inhibition of optimisation *) | Popaque of layout (* Statically-defined probes *) @@ -326,6 +339,8 @@ type primitive = | Parray_to_iarray | Parray_of_iarray | Pget_header of locality_mode + | Ppeek of peek_or_poke + | Ppoke of peek_or_poke (* Fetching domain-local state *) | Pdls_get (* Poll for runtime actions *) @@ -482,6 +497,14 @@ and boxed_integer = Primitive.boxed_integer = and boxed_vector = Primitive.boxed_vector = | Boxed_vec128 +and peek_or_poke = + | Ppp_tagged_immediate + | Ppp_unboxed_float32 + | Ppp_unboxed_float + | Ppp_unboxed_int32 + | Ppp_unboxed_int64 + | Ppp_unboxed_nativeint + and bigarray_kind = Pbigarray_unknown | Pbigarray_float16 @@ -944,6 +967,10 @@ let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region = let lambda_unit = Lconst const_unit +let of_bool = function + | true -> Lconst (const_int 1) + | false -> Lconst (const_int 0) + (* CR vlaviron: review the following cases *) let non_null_value raw_kind = Pvalue { raw_kind; nullable = Non_nullable } @@ -1819,7 +1846,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None | Pmakearray (_, _, m) -> Some m - | Pmakearray_dynamic (_, m) -> Some m + | Pmakearray_dynamic (_, m, _) -> Some m | Pduparray _ -> Some alloc_heap | Parraylength _ -> None | Parrayblit _ @@ -1923,12 +1950,19 @@ let primitive_may_allocate : primitive -> locality_mode option = function | Ppoll -> Some alloc_heap | Patomic_load _ - | Patomic_exchange - | Patomic_compare_exchange - | Patomic_cas + | Patomic_exchange _ + | Patomic_compare_exchange _ + | Patomic_compare_set _ | Patomic_fetch_add + | Patomic_add + | Patomic_sub + | Patomic_land + | Patomic_lor + | Patomic_lxor | Pdls_get - | Preinterpret_unboxed_int64_as_tagged_int63 -> None + | Preinterpret_unboxed_int64_as_tagged_int63 + | Parray_element_size_in_bytes _ + | Ppeek _ | Ppoke _ -> None | Preinterpret_tagged_int63_as_unboxed_int64 -> if !Clflags.native_code then None else @@ -2089,11 +2123,14 @@ let primitive_can_raise prim = | Punbox_vector _ | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ | Punboxed_product_field _ | Pget_header _ -> false - | Patomic_exchange | Patomic_compare_exchange - | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false + | Patomic_exchange _ | Patomic_compare_exchange _ + | Patomic_compare_set _ | Patomic_fetch_add | Patomic_add + | Patomic_sub | Patomic_land | Patomic_lor + | Patomic_lxor | Patomic_load _ -> false | Prunstack | Pperform | Presume | Preperform -> true (* XXX! *) | Pdls_get | Ppoll | Preinterpret_tagged_int63_as_unboxed_int64 - | Preinterpret_unboxed_int64_as_tagged_int63 -> + | Preinterpret_unboxed_int64_as_tagged_int63 + | Parray_element_size_in_bytes _ | Ppeek _ | Ppoke _ -> false let constant_layout: constant -> layout = function @@ -2205,6 +2242,7 @@ 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 + | Parray_element_size_in_bytes _ -> layout_int | Pfloatfield _ -> layout_boxed_float Boxed_float64 | Pfloatoffloat32 _ -> layout_boxed_float Boxed_float64 | Pfloat32offloat _ -> layout_boxed_float Boxed_float32 @@ -2319,14 +2357,31 @@ let primitive_result_layout (p : primitive) = | Prunstack | Presume | Pperform | Preperform -> layout_any_value | Patomic_load { immediate_or_pointer = Immediate } -> layout_int | Patomic_load { immediate_or_pointer = Pointer } -> layout_any_value - | Patomic_exchange - | Patomic_compare_exchange - | Patomic_cas - | Patomic_fetch_add + | Patomic_exchange { immediate_or_pointer = Immediate } -> layout_int + | Patomic_exchange { immediate_or_pointer = Pointer } -> layout_any_value + | Patomic_compare_exchange { immediate_or_pointer = Immediate } -> layout_int + | Patomic_compare_exchange { immediate_or_pointer = Pointer } -> layout_any_value + | Patomic_compare_set _ + | Patomic_fetch_add -> layout_int | Pdls_get -> layout_any_value + | Patomic_add + | Patomic_sub + | Patomic_land + | Patomic_lor + | Patomic_lxor | Ppoll -> layout_unit | Preinterpret_tagged_int63_as_unboxed_int64 -> layout_unboxed_int64 | Preinterpret_unboxed_int64_as_tagged_int63 -> layout_int + | Ppeek layout -> ( + match layout with + | Ppp_tagged_immediate -> layout_int + | Ppp_unboxed_float32 -> layout_unboxed_float Unboxed_float32 + | Ppp_unboxed_float -> layout_unboxed_float Unboxed_float64 + | Ppp_unboxed_int32 -> layout_unboxed_int32 + | Ppp_unboxed_int64 -> layout_unboxed_int64 + | Ppp_unboxed_nativeint -> layout_unboxed_nativeint + ) + | Ppoke _ -> layout_unit let compute_expr_layout free_vars_kind lam = let rec compute_expr_layout kinds = function @@ -2388,6 +2443,21 @@ let array_set_kind mode = function | Pgcscannableproductarray kinds -> Pgcscannableproductarray_set (mode, kinds) | Pgcignorableproductarray kinds -> Pgcignorableproductarray_set kinds +let array_ref_kind_of_array_set_kind (kind : array_set_kind) mode + : array_ref_kind = + match kind with + | Pintarray_set -> Pintarray_ref + | Punboxedfloatarray_set uf -> Punboxedfloatarray_ref uf + | Punboxedintarray_set ui -> Punboxedintarray_ref ui + | Punboxedvectorarray_set uv -> Punboxedvectorarray_ref uv + | Pgcscannableproductarray_set (_, scannables) -> + Pgcscannableproductarray_ref scannables + | Pgcignorableproductarray_set ignorables -> + Pgcignorableproductarray_ref ignorables + | Pgenarray_set _ -> Pgenarray_ref mode + | Paddrarray_set _ -> Paddrarray_ref + | Pfloatarray_set -> Pfloatarray_ref mode + let may_allocate_in_region lam = (* loop_region raises, if the lambda might allocate in parent region *) let rec loop_region lam = @@ -2479,3 +2549,47 @@ let rec try_to_find_location lam = let try_to_find_debuginfo lam = Debuginfo.from_location (try_to_find_location lam) + +(* The "count_initializers_*" functions count the number of individual + components in an initializer for the corresponding array kind _after_ + unarization. These are used to implement the "%array_element_size_in_bytes" + primitives for products, as each such component takes a full word in product + arrays. *) +let rec count_initializers_scannable + (scannable : scannable_product_element_kind) = + match scannable with + | Pint_scannable | Paddr_scannable -> 1 + | Pproduct_scannable scannables -> + List.fold_left + (fun acc scannable -> acc + count_initializers_scannable scannable) + 0 scannables + +let rec count_initializers_ignorable + (ignorable : ignorable_product_element_kind) = + match ignorable with + | Pint_ignorable | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> 1 + | Pproduct_ignorable ignorables -> + List.fold_left + (fun acc ignorable -> acc + count_initializers_ignorable ignorable) + 0 ignorables + +let count_initializers_array_kind (lambda_array_kind : array_kind) = + match lambda_array_kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _ + | Punboxedintarray _ | Punboxedvectorarray _ -> 1 + | Pgcscannableproductarray scannables -> + List.fold_left + (fun acc scannable -> acc + count_initializers_scannable scannable) + 0 scannables + | Pgcignorableproductarray ignorables -> + List.fold_left + (fun acc ignorable -> acc + count_initializers_ignorable ignorable) + 0 ignorables + +let rec ignorable_product_element_kind_involves_int + (kind : ignorable_product_element_kind) = + match kind with + | Pint_ignorable -> true + | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> false + | Pproduct_ignorable kinds -> + List.exists ignorable_product_element_kind_involves_int kinds diff --git a/lambda/lambda.mli b/lambda/lambda.mli index f72780dda1c..f8b3ae9e436 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -74,6 +74,10 @@ type field_read_semantics = | Reads_agree | Reads_vary +type has_initializer = + | With_initializer + | Uninitialized + (* Tail calls can close their enclosing region early *) type region_close = | Rc_normal (* do not close region, may TCO if in tail position *) @@ -137,6 +141,7 @@ type primitive = | Pmake_unboxed_product of layout list | Punboxed_product_field of int * (layout list) (* the [layout list] is the layout of the whole product *) + | Parray_element_size_in_bytes of array_kind (* Context switches *) | Prunstack | Pperform @@ -178,15 +183,21 @@ type primitive = | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets (* Array operations *) | Pmakearray of array_kind * mutable_flag * locality_mode - | Pmakearray_dynamic of array_kind * locality_mode + | Pmakearray_dynamic of array_kind * locality_mode * has_initializer + (** For [Pmakearray_dynamic], if the array kind specifies an unboxed + product, the float array optimization will never apply. *) | Pduparray of array_kind * mutable_flag (** For [Pduparray], the argument must be an immutable array. The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) - | Parrayblit of array_set_kind + | Parrayblit of { + src_mutability : mutable_flag; + dst_array_set_kind : array_set_kind; + } (** For [Parrayblit], we record the [array_set_kind] of the destination array. We check that the source array has the same shape, but do not - need to know anything about its locality. *) + need to know anything about its locality. We do however request the + mutability of the source array. *) | Parraylength of array_kind | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag | Parraysetu of array_set_kind * array_index_kind @@ -298,10 +309,15 @@ type primitive = | Pint_as_pointer of locality_mode (* Atomic operations *) | Patomic_load of {immediate_or_pointer : immediate_or_pointer} - | Patomic_exchange - | Patomic_compare_exchange - | Patomic_cas + | Patomic_exchange of {immediate_or_pointer : immediate_or_pointer} + | Patomic_compare_exchange of {immediate_or_pointer : immediate_or_pointer} + | Patomic_compare_set of {immediate_or_pointer : immediate_or_pointer} | Patomic_fetch_add + | Patomic_add + | Patomic_sub + | Patomic_land + | Patomic_lor + | Patomic_lxor (* Inhibition of optimisation *) | Popaque of layout (* Statically-defined probes *) @@ -332,6 +348,8 @@ type primitive = | Parray_of_iarray (* Unsafely reinterpret an immutable array as a mutable one; O(1) *) | Pget_header of locality_mode + | Ppeek of peek_or_poke + | Ppoke of peek_or_poke (* Get the header of a block. This primitive is invalid if provided with an immediate value. Note: The GC color bits in the header are not reliable except for checking @@ -513,6 +531,14 @@ and boxed_integer = Primitive.boxed_integer = and boxed_vector = Primitive.boxed_vector = | Boxed_vec128 +and peek_or_poke = + | Ppp_tagged_immediate + | Ppp_unboxed_float32 + | Ppp_unboxed_float + | Ppp_unboxed_int32 + | Ppp_unboxed_int64 + | Ppp_unboxed_nativeint + and bigarray_kind = Pbigarray_unknown | Pbigarray_float16 @@ -914,6 +940,8 @@ val const_unit: structured_constant val const_int : int -> structured_constant val lambda_unit: lambda +val of_bool : bool -> lambda + val layout_unit : layout val layout_int : layout val layout_array : array_kind -> layout @@ -1158,6 +1186,11 @@ val array_ref_kind : locality_mode -> array_kind -> array_ref_kind (** The mode will be discarded if unnecessary for the given [array_kind] *) val array_set_kind : modify_mode -> array_kind -> array_set_kind +(** Any mode information in the given [array_set_kind] is ignored. Any mode + in the return value always comes from the [locality_mode] parameter. *) +val array_ref_kind_of_array_set_kind + : array_set_kind -> locality_mode -> array_ref_kind + (* Returns true if the given lambda can allocate on the local stack *) val may_allocate_in_region : lambda -> bool @@ -1173,3 +1206,7 @@ val try_to_find_location : lambda -> scoped_location val try_to_find_debuginfo : lambda -> Debuginfo.t val primitive_can_raise : primitive -> bool + +val count_initializers_array_kind : array_kind -> int +val ignorable_product_element_kind_involves_int : + ignorable_product_element_kind -> bool diff --git a/lambda/matching.ml b/lambda/matching.ml index 09357f8d312..82927c23f94 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1959,14 +1959,18 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = else match cstr.cstr_repr with | Variant_boxed _ -> - List.mapi - (fun i { ca_sort } -> - make_field_access str ca_sort ~field:i ~pos:i) - cstr.cstr_args + List.mapi + (fun i { ca_sort } -> + make_field_access str ca_sort ~field:i ~pos:i) + cstr.cstr_args @ rem - | Variant_unboxed -> (arg, str, sort, layout) :: rem - | Variant_with_null -> - Misc.fatal_error "[Variant_with_null] not implemented yet" + | Variant_unboxed | Variant_with_null -> + if cstr.cstr_constant then + rem (* [Null] constructor case. *) + else + (arg, str, sort, layout) :: rem + (* the unboxed variant constructor, or the [This] constructor + for [Variant_with_null]. *) | Variant_extensible -> List.mapi (fun i { ca_sort } -> @@ -3191,22 +3195,29 @@ let combine_constant value_kind loc arg cst partial ctx def let split_cases tag_lambda_list = let rec split_rec = function - | [] -> ([], []) + | [] -> ([], [], None) | ({cstr_tag; cstr_repr; cstr_constant}, act) :: rem -> ( - let consts, nonconsts = split_rec rem in + let consts, nonconsts, null = split_rec rem in match cstr_tag, cstr_repr with - | Ordinary _, Variant_unboxed -> (consts, (0, act) :: nonconsts) + | Ordinary _, (Variant_unboxed | Variant_with_null) -> + (consts, (0, act) :: nonconsts, null) | Ordinary {runtime_tag}, Variant_boxed _ when cstr_constant -> - ((runtime_tag, act) :: consts, nonconsts) + ((runtime_tag, act) :: consts, nonconsts, null) | Ordinary {runtime_tag}, Variant_boxed _ -> - (consts, (runtime_tag, act) :: nonconsts) - | _, (Variant_extensible | Variant_with_null) -> assert false + (consts, (runtime_tag, act) :: nonconsts, null) + | Null, Variant_with_null -> + (match null with + | None -> (consts, nonconsts, Some act) + | Some _ -> Misc.fatal_error + "Multiple null cases in Matching.split_cases") + | Null, (Variant_boxed _ | Variant_unboxed) -> + assert false + | _, Variant_extensible -> assert false | Extension _, _ -> assert false - | Null, _ -> Misc.fatal_error "[Null] constructors not implemented" ) in - let const, nonconst = split_rec tag_lambda_list in - (sort_int_lambda_list const, sort_int_lambda_list nonconst) + let const, nonconst, null = split_rec tag_lambda_list in + (sort_int_lambda_list const, sort_int_lambda_list nonconst, null) (* The bool tracks whether the constructor is constant, because we don't have a constructor_description available for polymorphic variants *) @@ -3241,6 +3252,9 @@ let transl_match_on_option value_kind arg loc ~if_some ~if_none = else Lifthenelse(arg, if_some, if_none, value_kind) +let transl_match_on_or_null value_kind arg loc ~if_null ~if_this = + Lifthenelse (Lprim (Pisnull, [ arg ], loc), if_null, if_this, value_kind) + let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx def (descr_lambda_list, total1, pats) = match cstr.cstr_tag with @@ -3302,7 +3316,7 @@ let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx mk_failaction_pos partial constrs ctx def in let descr_lambda_list = fails @ descr_lambda_list in - let consts, nonconsts = split_cases descr_lambda_list in + let consts, nonconsts, null = split_cases descr_lambda_list in (* Our duty below is to generate code, for matching on a list of constructor+action cases, that is good for both bytecode and native-code compilation. (Optimizations that only work well @@ -3332,19 +3346,25 @@ let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx act | _ -> ( match - (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) + (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts, null) with - | 1, 1, [ (0, act1) ], [ (0, act2) ] + | 1, 1, [ (0, act1) ], [ (0, act2) ], None when not (Clflags.is_flambda2 ()) -> transl_match_on_option value_kind arg loc ~if_none:act1 ~if_some:act2 - | n, 0, _, [] -> + | 1, 1, [], [(_, act2)], Some act1 -> + (* The [Variant_with_null] case. *) + transl_match_on_or_null value_kind arg loc + ~if_null:act1 ~if_this:act2 + | _, _, _, _, Some _ -> + Misc.fatal_error "Matching.combine_constructor: Unexpected Null case" + | n, 0, _, [], None -> (* The matched type defines constant constructors only. (typically the constant cases are dense, so call_switcher will generate a Lswitch, still one instruction.) *) call_switcher value_kind loc fail_opt arg 0 (n - 1) consts - | n, _, _, _ -> ( + | n, _, _, _, None -> ( let act0 = (* = Some act when all non-const constructors match to act *) match (fail_opt, nonconsts) with @@ -3371,7 +3391,7 @@ let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx match token with SEMISEMI -> true | _ -> false (The type of tokens has more than 120 constructors.) - *) + *) Lifthenelse ( Lprim (Pisint { variant_only = true }, [ arg ], loc), call_switcher value_kind loc fail_opt arg 0 (n - 1) consts, @@ -3388,9 +3408,7 @@ let combine_constructor value_kind loc arg pat_env pat_barrier cstr partial ctx in let hs, sw = share_actions_sw value_kind sw in let sw = reintroduce_fail sw in - hs (Lswitch (arg, sw, loc, value_kind)) - ) - ) + hs (Lswitch (arg, sw, loc, value_kind)))) in (lambda1, Jumps.union local_jumps total1) diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index ed0e1326695..2a9ca1fb5ed 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -478,6 +478,15 @@ let field_read_semantics ppf sem = | Reads_agree -> () | Reads_vary -> fprintf ppf "_mut" +let peek_or_poke ppf (pp : peek_or_poke) = + match pp with + | Ppp_tagged_immediate -> fprintf ppf "tagged_immediate" + | Ppp_unboxed_float32 -> fprintf ppf "unboxed_float32" + | Ppp_unboxed_float -> fprintf ppf "unboxed_float" + | Ppp_unboxed_int32 -> fprintf ppf "unboxed_int32" + | Ppp_unboxed_int64 -> fprintf ppf "unboxed_int64" + | Ppp_unboxed_nativeint -> fprintf ppf "unboxed_nativeint" + let primitive ppf = function | Pbytes_to_string -> fprintf ppf "bytes_to_string" | Pbytes_of_string -> fprintf ppf "bytes_of_string" @@ -609,6 +618,8 @@ let primitive ppf = function fprintf ppf "unboxed_product_field %d #(%a)" n (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ", ") (layout' false)) layouts + | Parray_element_size_in_bytes ak -> + fprintf ppf "array_element_size_in_bytes (%s)" (array_kind ak) | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" @@ -668,14 +679,20 @@ let primitive ppf = function | Pmakearray (k, Immutable_unique, mode) -> fprintf ppf "make%sarray_unique[%s]" (locality_mode_if_local mode) (array_kind k) - | Pmakearray_dynamic (k, mode) -> - fprintf ppf "make%sarray_any[%s]" (locality_mode_if_local mode) + | Pmakearray_dynamic (k, mode, has_init) -> + fprintf ppf "make%sarray_any[%s]%s" (locality_mode_if_local mode) (array_kind k) + (match has_init with + | With_initializer -> "" + | Uninitialized -> "[uninit]") | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) | Pduparray (k, Immutable_unique) -> fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayblit sk -> fprintf ppf "arrayblit[%a]" array_set_kind sk + | Parrayblit { src_mutability; dst_array_set_kind } -> + fprintf ppf "arrayblit[%s -> %a]" + (array_mut src_mutability) + array_set_kind dst_array_set_kind | Parrayrefu (rk, idx, mut) -> fprintf ppf "%s.unsafe_get[%a indexed by %a]" (array_mut mut) array_ref_kind rk @@ -896,10 +913,24 @@ let primitive ppf = function (match immediate_or_pointer with | Immediate -> fprintf ppf "atomic_load_imm" | Pointer -> fprintf ppf "atomic_load_ptr") - | Patomic_exchange -> fprintf ppf "atomic_exchange" - | Patomic_compare_exchange -> fprintf ppf "atomic_compare_exchange" - | Patomic_cas -> fprintf ppf "atomic_cas" + | Patomic_exchange {immediate_or_pointer} -> + (match immediate_or_pointer with + | Immediate -> fprintf ppf "atomic_exchange_imm" + | Pointer -> fprintf ppf "atomic_exchange_ptr") + | Patomic_compare_exchange {immediate_or_pointer} -> + (match immediate_or_pointer with + | Immediate -> fprintf ppf "atomic_compare_exchange_imm" + | Pointer -> fprintf ppf "atomic_compare_exchange_ptr") + | Patomic_compare_set {immediate_or_pointer} -> + (match immediate_or_pointer with + | Immediate -> fprintf ppf "atomic_compare_set_imm" + | Pointer -> fprintf ppf "atomic_compare_set_ptr") | Patomic_fetch_add -> fprintf ppf "atomic_fetch_add" + | Patomic_add -> fprintf ppf "atomic_add" + | Patomic_sub -> fprintf ppf "atomic_sub" + | Patomic_land -> fprintf ppf "atomic_land" + | Patomic_lor -> fprintf ppf "atomic_lor" + | Patomic_lxor -> fprintf ppf "atomic_lxor" | Popaque _ -> fprintf ppf "opaque" | Pdls_get -> fprintf ppf "dls_get" | Ppoll -> fprintf ppf "poll" @@ -922,6 +953,12 @@ let primitive ppf = function fprintf ppf "reinterpret_tagged_int63_as_unboxed_int64" | Preinterpret_unboxed_int64_as_tagged_int63 -> fprintf ppf "reinterpret_unboxed_int64_as_tagged_int63" + | Ppeek layout -> + fprintf ppf "(peek@ %a)" + peek_or_poke layout + | Ppoke layout -> + fprintf ppf "(poke@ %a)" + peek_or_poke layout let name_of_primitive = function | Pbytes_of_string -> "Pbytes_of_string" @@ -947,6 +984,7 @@ let name_of_primitive = function | Pduprecord _ -> "Pduprecord" | Pmake_unboxed_product _ -> "Pmake_unboxed_product" | Punboxed_product_field _ -> "Punboxed_product_field" + | Parray_element_size_in_bytes _ -> "Parray_element_size_in_bytes" | Pccall _ -> "Pccall" | Praise _ -> "Praise" | Psequand -> "Psequand" @@ -1071,10 +1109,24 @@ let name_of_primitive = function (match immediate_or_pointer with | Immediate -> "atomic_load_imm" | Pointer -> "atomic_load_ptr") - | Patomic_exchange -> "Patomic_exchange" - | Patomic_compare_exchange -> "Patomic_compare_exchange" - | Patomic_cas -> "Patomic_cas" + | Patomic_exchange {immediate_or_pointer} -> + (match immediate_or_pointer with + | Immediate -> "atomic_exchange_imm" + | Pointer -> "atomic_exchange_ptr") + | Patomic_compare_exchange {immediate_or_pointer} -> + (match immediate_or_pointer with + | Immediate -> "atomic_compare_exchange_imm" + | Pointer -> "atomic_compare_exchange_ptr") + | Patomic_compare_set {immediate_or_pointer} -> + (match immediate_or_pointer with + | Immediate -> "atomic_compare_set_imm" + | Pointer -> "atomic_compare_set_ptr") | Patomic_fetch_add -> "Patomic_fetch_add" + | Patomic_add -> "Patomic_add" + | Patomic_sub -> "Patomic_sub" + | Patomic_land -> "Patomic_land" + | Patomic_lor -> "Patomic_lor" + | Patomic_lxor -> "Patomic_lxor" | Popaque _ -> "Popaque" | Prunstack -> "Prunstack" | Presume -> "Presume" @@ -1098,6 +1150,8 @@ let name_of_primitive = function "Preinterpret_tagged_int63_as_unboxed_int64" | Preinterpret_unboxed_int64_as_tagged_int63 -> "Preinterpret_unboxed_int64_as_tagged_int63" + | Ppeek _ -> "Ppeek" + | Ppoke _ -> "Ppoke" let zero_alloc_attribute ppf check = match check with diff --git a/lambda/printlambda.mli b/lambda/printlambda.mli index fc4b898a224..05bb1f49f1d 100644 --- a/lambda/printlambda.mli +++ b/lambda/printlambda.mli @@ -44,6 +44,7 @@ val print_bigarray : val zero_alloc_attribute : formatter -> zero_alloc_attribute -> unit val locality_mode : formatter -> locality_mode -> unit val array_kind : array_kind -> string +val array_set_kind : formatter -> array_set_kind -> unit val tag_and_constructor_shape : (formatter -> value_kind -> unit) -> diff --git a/lambda/tmc.ml b/lambda/tmc.ml index 4a65037e891..1ae1b2c4da6 100644 --- a/lambda/tmc.ml +++ b/lambda/tmc.ml @@ -902,8 +902,10 @@ let rec choice ctx t = | Prunstack | Pperform | Presume | Preperform | Pdls_get (* we don't handle atomic primitives *) - | Patomic_exchange | Patomic_compare_exchange - | Patomic_cas | Patomic_fetch_add | Patomic_load _ + | Patomic_exchange _ | Patomic_compare_exchange _ + | Patomic_compare_set _ | Patomic_fetch_add + | Patomic_add | Patomic_sub | Patomic_land + | Patomic_lor | Patomic_lxor | Patomic_load _ | Punbox_float _ | Pbox_float (_, _) | Punbox_int _ | Pbox_int _ | Punbox_vector _ | Pbox_vector (_, _) @@ -923,6 +925,7 @@ let rec choice ctx t = (* nor unboxed products *) | Pmake_unboxed_product _ | Punboxed_product_field _ + | Parray_element_size_in_bytes _ | Pobj_dup | Pobj_magic _ @@ -973,6 +976,7 @@ let rec choice ctx t = | Pint_as_pointer _ | Psequand | Psequor | Ppoll + | Ppeek _ | Ppoke _ -> let primargs = traverse_list ctx primargs in Choice.lambda (Lprim (prim, primargs, loc)) diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 5712986a93d..a8983cbc271 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -536,15 +536,15 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | [x] -> x | _ -> assert false end else begin match cstr.cstr_tag, cstr.cstr_repr with - | Null, _ -> Misc.fatal_error "[Null] constructors not implemented yet" - | Ordinary _, Variant_with_null -> - Misc.fatal_error "[Variant_with_null] not implemented yet" + | Null, Variant_with_null -> Lconst Const_null + | Null, (Variant_boxed _ | Variant_unboxed | Variant_extensible) -> + assert false | Ordinary {runtime_tag}, _ when cstr.cstr_constant -> assert (args_with_sorts = []); (* CR layouts v5: This could have void args, but for now we've ruled that out by checking that the sort list is empty *) Lconst(const_int runtime_tag) - | Ordinary _, Variant_unboxed -> + | Ordinary _, (Variant_unboxed | Variant_with_null) -> (match ll with [v] -> v | _ -> assert false) | Ordinary {runtime_tag}, Variant_boxed _ -> let constant = diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 109651c043c..08bd8cac7f6 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -28,8 +28,10 @@ module String = Misc.Stdlib.String type error = | Unknown_builtin_primitive of string | Wrong_arity_builtin_primitive of string + | Wrong_layout_for_peek_or_poke of string | Invalid_floatarray_glb | Product_iarrays_unsupported + | Invalid_array_kind_for_uninitialized_makearray_dynamic exception Error of Location.t * error @@ -45,6 +47,18 @@ let unboxed_product_iarray_check loc kind mut = | Punboxedintarray _ | Punboxedvectorarray _), _ -> () +let unboxed_product_uninitialized_array_check loc array_kind = + (* See comments in lambda_to_lambda_transforms.ml in Flambda 2 for more + details on this restriction. *) + match array_kind with + | Pgcignorableproductarray igns + when not (List.exists + Lambda.ignorable_product_element_kind_involves_int igns) -> () + | Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _ -> + () + | Pgenarray | Paddrarray | Pintarray | Pfloatarray + | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> + raise (Error (loc, Invalid_array_kind_for_uninitialized_makearray_dynamic)) (* Insertion of debugging events *) @@ -110,6 +124,10 @@ type prim = | Identity | Apply of Lambda.region_close * Lambda.layout | Revapply of Lambda.region_close * Lambda.layout + | Peek of Lambda.peek_or_poke option + | Poke of Lambda.peek_or_poke option + (* For [Peek] and [Poke] the [option] is [None] until the primitive + specialization code (below) has been run. *) | Unsupported of Lambda.primitive let units_with_used_primitives = Hashtbl.create 7 @@ -531,11 +549,26 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = (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; - Primitive (Pmakearray_dynamic (gen_array_kind, mode), 2) + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Pmakearray_dynamic (gen_array_kind, mode, With_initializer), 2) + | "%makearray_dynamic_uninit" -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Pmakearray_dynamic (gen_array_kind, mode, Uninitialized), 1) | "%arrayblit" -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Alpha; - Primitive (Parrayblit (gen_array_set_kind (get_third_arg_mode ())), 5) + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Parrayblit { + src_mutability = Mutable; + dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ()) + }, 5); + | "%arrayblit_src_immut" -> + Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Primitive (Parrayblit { + src_mutability = Immutable; + dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ()) + }, 5); + | "%array_element_size_in_bytes" -> + (* The array kind will be filled in later *) + Primitive (Parray_element_size_in_bytes Pgenarray, 1) | "%obj_size" -> Primitive ((Parraylength Pgenarray), 1) | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode, Ptagged_int_index, Mutable)), 2) | "%obj_set_field" -> @@ -864,10 +897,18 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = | "%get_header" -> Primitive (Pget_header mode, 1) | "%atomic_load" -> Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1) - | "%atomic_exchange" -> Primitive (Patomic_exchange, 2) - | "%atomic_compare_exchange" -> Primitive (Patomic_compare_exchange, 3) - | "%atomic_cas" -> Primitive (Patomic_cas, 3) + | "%atomic_exchange" -> + Primitive (Patomic_exchange {immediate_or_pointer=Pointer}, 2) + | "%atomic_compare_exchange" -> + Primitive (Patomic_compare_exchange {immediate_or_pointer=Pointer}, 3) + | "%atomic_cas" -> + Primitive (Patomic_compare_set {immediate_or_pointer=Pointer}, 3) | "%atomic_fetch_add" -> Primitive (Patomic_fetch_add, 2) + | "%atomic_add" -> Primitive (Patomic_add, 2) + | "%atomic_sub" -> Primitive (Patomic_sub, 2) + | "%atomic_land" -> Primitive (Patomic_land, 2) + | "%atomic_lor" -> Primitive (Patomic_lor, 2) + | "%atomic_lxor" -> Primitive (Patomic_lxor, 2) | "%runstack" -> if runtime5 then Primitive (Prunstack, 3) else Unsupported Prunstack | "%reperform" -> @@ -888,6 +929,8 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Primitive(Preinterpret_tagged_int63_as_unboxed_int64, 1) | "%reinterpret_unboxed_int64_as_tagged_int63" -> Primitive(Preinterpret_unboxed_int64_as_tagged_int63, 1) + | "%peek" -> Peek None + | "%poke" -> Poke None | s when String.length s > 0 && s.[0] = '%' -> (match String.Map.find_opt s indexing_primitives with | Some prim -> prim ~mode @@ -1157,6 +1200,27 @@ let glb_array_set_type loc t1 t2 = (* Pfloatarray is a minimum *) | Pfloatarray_set, Pfloatarray -> Pfloatarray_set +let peek_or_poke_layout_from_type ~prim_name error_loc env ty + : Lambda.peek_or_poke option = + match Ctype.type_sort ~why:Peek_or_poke ~fixed:true env ty with + | Error _ -> None + | Ok sort -> + let sort = Jkind.Sort.default_to_value_and_get sort in + let layout = Typeopt.layout env error_loc sort ty in + match layout with + | Punboxed_float Unboxed_float32 -> Some Ppp_unboxed_float32 + | Punboxed_float Unboxed_float64 -> Some Ppp_unboxed_float + | Punboxed_int Unboxed_int32 -> Some Ppp_unboxed_int32 + | Punboxed_int Unboxed_int64 -> Some Ppp_unboxed_int64 + | Punboxed_int Unboxed_nativeint -> Some Ppp_unboxed_nativeint + | Pvalue { raw_kind = Pintval ; _ } -> Some Ppp_tagged_immediate + | Ptop + | Pvalue _ + | Punboxed_vector _ + | Punboxed_product _ + | Pbottom -> + raise (Error (error_loc, Wrong_layout_for_peek_or_poke prim_name)) + (* Specialize a primitive from available type information. *) (* CR layouts v7: This function had a loc argument added just to support the void check error message. Take it out when we remove that. *) @@ -1229,19 +1293,40 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = if st = array_set_type then None else Some (Primitive (Parraysets (array_set_type, index_kind), arity)) end - | Primitive (Pmakearray_dynamic (at, mode), arity), - _ :: p2 :: _ -> begin + | Primitive (Pmakearray_dynamic (array_kind, mode, With_initializer), 2), + _ :: p2 :: [] -> begin let loc = to_location loc in - let array_type = - glb_array_type loc at - (array_kind_of_elt ~elt_sort:None env loc p2) + let new_array_kind = + array_kind_of_elt ~elt_sort:None env loc p2 + |> glb_array_type loc array_kind in let array_mut = array_type_mut env rest_ty in - unboxed_product_iarray_check loc array_type array_mut; - if at = array_type then None - else Some (Primitive (Pmakearray_dynamic (array_type, mode), arity)) + unboxed_product_iarray_check loc new_array_kind array_mut; + if array_kind = new_array_kind then None + else + Some (Primitive (Pmakearray_dynamic ( + new_array_kind, mode, With_initializer), 2)) + end + | Primitive (Pmakearray_dynamic (array_kind, mode, Uninitialized), 1), + _ :: [] -> begin + let loc = to_location loc in + let new_array_kind = + array_type_kind ~elt_sort:None env loc rest_ty + |> glb_array_type loc array_kind + in + let array_mut = array_type_mut env rest_ty in + unboxed_product_iarray_check loc new_array_kind array_mut; + unboxed_product_uninitialized_array_check loc new_array_kind; + if array_kind = new_array_kind then None + else + Some (Primitive (Pmakearray_dynamic ( + new_array_kind, mode, Uninitialized), 1)) end - | Primitive (Parrayblit st, arity), + | Primitive (Pmakearray_dynamic _, arity), args -> + Misc.fatal_errorf + "Wrong arity for Pmakearray_dynamic (arity=%d, args length %d)" + arity (List.length args) + | Primitive (Parrayblit { src_mutability; dst_array_set_kind }, arity), _p1 :: _ :: p2 :: _ -> let loc = to_location loc in (* We only use the kind of one of two input arrays here. If you've bound the @@ -1249,11 +1334,19 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = kind. If you haven't, then taking the glb of both would be just as likely to compound your error (e.g., by treating a Pgenarray as a Pfloatarray) as to help you. *) - let array_type = - glb_array_set_type loc st (array_type_kind ~elt_sort:None env loc p2) + let array_kind = array_type_kind ~elt_sort:None env loc p2 in + let new_dst_array_set_kind = + glb_array_set_type loc dst_array_set_kind array_kind in - if st = array_type then None - else Some (Primitive (Parrayblit array_type, arity)) + if dst_array_set_kind = new_dst_array_set_kind then None + else Some (Primitive (Parrayblit { + src_mutability; dst_array_set_kind = new_dst_array_set_kind }, arity)) + | Primitive (Parray_element_size_in_bytes _, arity), p1 :: _ -> ( + let array_kind = + array_type_kind ~elt_sort:None env (to_location loc) p1 + in + Some (Primitive (Parray_element_size_in_bytes array_kind, arity)) + ) | Primitive (Pbigarrayref(unsafe, n, kind, layout), arity), p1 :: _ -> begin let (k, l) = bigarray_specialize_kind_and_layout env ~kind ~layout p1 in match k, l with @@ -1285,6 +1378,36 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = | Some (_p1, rhs) -> maybe_pointer_type env rhs in Some (Primitive (Patomic_load {immediate_or_pointer = is_int}, arity)) end + | Primitive (Patomic_exchange { immediate_or_pointer = Pointer }, + arity), [_; p2] -> begin + match maybe_pointer_type env p2 with + | Pointer -> None + | Immediate -> + Some + (Primitive + (Patomic_exchange + {immediate_or_pointer = Immediate}, arity)) + end + | Primitive (Patomic_compare_exchange { immediate_or_pointer = Pointer }, + arity), [_; p2; p3] -> begin + match maybe_pointer_type env p2, maybe_pointer_type env p3 with + | Pointer, _ | _, Pointer -> None + | Immediate, Immediate -> + Some + (Primitive + (Patomic_compare_exchange + {immediate_or_pointer = Immediate}, arity)) + end + | Primitive (Patomic_compare_set { immediate_or_pointer = Pointer }, + arity), [_; p2; p3] -> begin + match maybe_pointer_type env p2, maybe_pointer_type env p3 with + | Pointer, _ | _, Pointer -> None + | Immediate, Immediate -> + Some + (Primitive + (Patomic_compare_set + {immediate_or_pointer = Immediate}, arity)) + end | Comparison(comp, Compare_generic), p1 :: _ -> if (has_constant_constructor && simplify_constant_constructor comp) then begin @@ -1310,6 +1433,25 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = end else begin None end + | Peek _, _ -> ( + match is_function_type env ty with + | None -> None + | Some (_p1, result_ty) -> + match + peek_or_poke_layout_from_type ~prim_name:"peek" + (to_location loc) env result_ty + with + | None -> None + | Some contents_layout -> Some (Peek (Some contents_layout)) + ) + | Poke _, _ptr_ty :: new_value_ty :: _ -> ( + match + peek_or_poke_layout_from_type ~prim_name:"poke" + (to_location loc) env new_value_ty + with + | None -> None + | Some contents_layout -> Some (Poke (Some contents_layout)) + ) | _ -> None let caml_equal = @@ -1556,6 +1698,12 @@ let lambda_of_prim prim_name prim loc args arg_exps = ap_region_close = pos; ap_mode = alloc_heap; } + | Peek None, _ | Poke None, _ -> + raise(Error(to_location loc, Wrong_layout_for_peek_or_poke prim_name)) + | Peek (Some layout), [ptr] -> + Lprim (Ppeek layout, [ptr], loc) + | Poke (Some layout), [ptr; new_value] -> + Lprim (Ppoke layout, [ptr; new_value], loc) | Unsupported prim, _ -> let exn = transl_extension_path loc (Lazy.force Env.initial) @@ -1574,7 +1722,7 @@ let lambda_of_prim prim_name prim loc args arg_exps = | (Raise _ | Raise_with_backtrace | Lazy_force _ | Loc _ | Primitive _ | Sys_argv | Comparison _ | Send _ | Send_self _ | Send_cache _ | Frame_pointers | Identity - | Apply _ | Revapply _), _ -> + | Apply _ | Revapply _ | Peek _ | Poke _), _ -> raise(Error(to_location loc, Wrong_arity_builtin_primitive prim_name)) let check_primitive_arity loc p = @@ -1606,8 +1754,8 @@ let check_primitive_arity loc p = | Send _ | Send_self _ -> p.prim_arity = 2 | Send_cache _ -> p.prim_arity = 4 | Frame_pointers -> p.prim_arity = 0 - | Identity -> p.prim_arity = 1 - | Apply _ | Revapply _ -> p.prim_arity = 2 + | Identity | Peek _ -> p.prim_arity = 1 + | Apply _ | Revapply _ | Poke _ -> p.prim_arity = 2 | Unsupported _ -> true in if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) @@ -1733,7 +1881,7 @@ let lambda_primitive_needs_event_after = function | Pmulfloat (_, _) | Pdivfloat (_, _) | Pstringrefs | Pbytesrefs | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _ - | Pmakearray_dynamic (Pgenarray, _) + | Pmakearray_dynamic (Pgenarray, _, _) | Parrayrefu ((Pgenarray_ref _ | Pfloatarray_ref _), _, _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ @@ -1767,6 +1915,7 @@ let lambda_primitive_needs_event_after = function | Pgetglobal _ | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pmakemixedblock _ | Pmake_unboxed_product _ | Punboxed_product_field _ + | Parray_element_size_in_bytes _ | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Praise _ | Pufloatfield _ | Psetufloatfield _ | Pmixedfield _ | Psetmixedfield _ @@ -1783,16 +1932,17 @@ let lambda_primitive_needs_event_after = function | Pmakearray_dynamic ((Pintarray | Paddrarray | Pfloatarray | Punboxedfloatarray _ | Punboxedintarray _ | Punboxedvectorarray _ - | Pgcscannableproductarray _ | Pgcignorableproductarray _), _) + | Pgcscannableproductarray _ | Pgcignorableproductarray _), _, _) | Parrayblit _ | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisnull | Pisout | Pprobe_is_enabled _ - | Patomic_exchange | Patomic_compare_exchange - | Patomic_cas | Patomic_fetch_add | Patomic_load _ + | Patomic_exchange _ | Patomic_compare_exchange _ + | Patomic_compare_set _ | Patomic_fetch_add | Patomic_add | Patomic_sub + | Patomic_land | Patomic_lor | Patomic_lxor | Patomic_load _ | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer _ | Popaque _ | Pdls_get | Pobj_magic _ | Punbox_float _ | Punbox_int _ | Punbox_vector _ - | Preinterpret_unboxed_int64_as_tagged_int63 + | Preinterpret_unboxed_int64_as_tagged_int63 | Ppeek _ | Ppoke _ (* These don't allocate in bytecode; they're just identity functions: *) | Pbox_float (_, _) | Pbox_int _ | Pbox_vector (_, _) -> false @@ -1806,7 +1956,7 @@ let primitive_needs_event_after = function | Lazy_force _ | Send _ | Send_self _ | Send_cache _ | Apply _ | Revapply _ -> true | Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers | Identity - | Unsupported _ -> false + | Peek _ | Poke _ | Unsupported _ -> false let transl_primitive_application loc p env ty ~poly_mode ~poly_sort path exp args arg_exps pos = @@ -1850,6 +2000,8 @@ let report_error ppf = function | Wrong_arity_builtin_primitive prim_name -> fprintf ppf "Wrong arity for builtin primitive %a" Style.inline_code prim_name + | Wrong_layout_for_peek_or_poke prim_name -> + fprintf ppf "Unsupported layout for the %s primitive" prim_name | Invalid_floatarray_glb -> fprintf ppf "@[Floatarray primitives can't be used on arrays containing@ \ @@ -1857,6 +2009,11 @@ let report_error ppf = function | Product_iarrays_unsupported -> fprintf ppf "Immutable arrays of unboxed products are not yet supported." + | Invalid_array_kind_for_uninitialized_makearray_dynamic -> + fprintf ppf + "%%makearray_dynamic_uninit can only be used for GC-ignorable arrays@ \ + not involving tagged immediates; and arrays of unboxed numbers.@ Use \ + %%makearray instead, providing an initializer." let () = Location.register_error_of_exn diff --git a/lambda/translprim.mli b/lambda/translprim.mli index 10916122801..c575cc7e247 100644 --- a/lambda/translprim.mli +++ b/lambda/translprim.mli @@ -62,8 +62,10 @@ val sort_of_native_repr : type error = | Unknown_builtin_primitive of string | Wrong_arity_builtin_primitive of string + | Wrong_layout_for_peek_or_poke of string | Invalid_floatarray_glb | Product_iarrays_unsupported + | Invalid_array_kind_for_uninitialized_makearray_dynamic exception Error of Location.t * error diff --git a/lambda/value_rec_compiler.ml b/lambda/value_rec_compiler.ml index be935829918..aa54a84197f 100644 --- a/lambda/value_rec_compiler.ml +++ b/lambda/value_rec_compiler.ml @@ -219,7 +219,12 @@ let compute_static_size lam = | Pbigstring_set_32 _ | Pbigstring_set_f32 _ | Pbigstring_set_64 _ - | Ppoll -> + | Ppoll + | Patomic_add + | Patomic_sub + | Patomic_land + | Patomic_lor + | Patomic_lxor -> (* Unit-returning primitives. Most of these are only generated from external declarations and not special-cased by [Value_rec_check], but it doesn't hurt to be consistent. *) @@ -345,12 +350,14 @@ let compute_static_size lam = | Pbbswap _ | Pint_as_pointer _ | Patomic_load _ - | Patomic_exchange - | Patomic_compare_exchange - | Patomic_cas + | Patomic_exchange _ + | Patomic_compare_exchange _ + | Patomic_compare_set _ | Patomic_fetch_add | Popaque _ - | Pdls_get -> + | Pdls_get + | Ppeek _ + | Ppoke _ -> dynamic_size lam (* Primitives specific to flambda-backend *) @@ -368,7 +375,8 @@ let compute_static_size lam = | Punboxed_float32_array_set_128 _ | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ - | Punboxed_nativeint_array_set_128 _ -> + | Punboxed_nativeint_array_set_128 _ + | Parray_element_size_in_bytes _ -> Constant | Pmakeufloatblock (_, _) diff --git a/manual/src/cmds/runtime.etex b/manual/src/cmds/runtime.etex index 242277e4f77..6e9629ebfb8 100644 --- a/manual/src/cmds/runtime.etex +++ b/manual/src/cmds/runtime.etex @@ -129,6 +129,9 @@ The following environment variables are also consulted: "caml_shutdown" in section~\ref{ss:c-embedded-code}). The option also enables pooling (as in "caml_startup_pooled"). This mode can be used to detect leaks with a third-party memory debugger. + \item[d] ("max_domains") Maximum number of domains that can be active + concurrently. Defaults to 128 on 64-bit platforms and 16 on 32-bit + platforms. \item[e] ("runtime_events_log_wsize") Size of the per-domain runtime events ring buffers in log powers of two words. Defaults to 16, giving 64k word or 512kb buffers on 64-bit systems. diff --git a/middle_end/flambda2/algorithms/builtin_stubs.c b/middle_end/flambda2/algorithms/builtin_stubs.c new file mode 100644 index 00000000000..eb398310343 --- /dev/null +++ b/middle_end/flambda2/algorithms/builtin_stubs.c @@ -0,0 +1,47 @@ +#include "caml/mlvalues.h" +#include "caml/fail.h" + +#if defined(_MSC_VER) +#include +#endif + +// These are replaced with clz instructions by flambda2. +// +// Use weak symbols in order to allow compiler-libs and ocaml_intrinsics_kernel +// to be shared dependencies of the same program. + +CAMLweakdef intnat caml_int_clz_tagged_to_untagged(value i) { + // Do not use Long_val(v1) conversion, instead preserving the tag. + // It guarantees that the input to builtin_clz / _BitScanReverse is + // non-zero, to guard against versions that are undefined for input 0. The + // tag does not change the number of leading zeros. +#if defined(__GNUC__) || defined(__clang__) + #if SIZEOF_PTR == SIZEOF_INT + return __builtin_clz(i); + #elif SIZEOF_PTR == SIZEOF_LONG + return __builtin_clzl(i); + #elif SIZEOF_PTR == SIZEOF_LONGLONG + return __builtin_clzll(i); + #else + #error "No builtin clz function available" + #endif +#elif defined(_MSC_VER) + unsigned long r = 0; + #ifdef SIZEOF_PTR == 8 + _BitScanReverse64(&r, i); + r ^= 63; + #elif SIZEOF_PTR == 4 + _BitScanReverse(&r, i); + r ^= 31; + #else + #error "No builtin bsr function available" + #endif + return r; +#else + #error "Unsupported compiler" +#endif +} + +CAMLweakdef value caml_int_clz_tagged_to_tagged(value i) { + return Val_int(caml_int_clz_tagged_to_untagged(i)); +} diff --git a/middle_end/flambda2/algorithms/dune b/middle_end/flambda2/algorithms/dune index 2e59ac46c4f..8ec0a116307 100644 --- a/middle_end/flambda2/algorithms/dune +++ b/middle_end/flambda2/algorithms/dune @@ -4,6 +4,19 @@ (name flambda2_algorithms) (wrapped true) (instrumentation (backend bisect_ppx)) + (foreign_stubs + (language c) + (names builtin_stubs) + (flags + ((:include %{project_root}/oc_cflags.sexp) + (:include %{project_root}/sharedlib_cflags.sexp) + (:include %{project_root}/oc_cppflags.sexp)))) (ocamlopt_flags (:standard -O3 -open Int_replace_polymorphic_compare)) (libraries ocamlcommon)) + +(install + (files + (dllflambda2_algorithms_stubs.so as stublibs/dllflambda2_algorithms_stubs.so)) + (section lib) + (package ocaml)) diff --git a/middle_end/flambda2/algorithms/patricia_tree.ml b/middle_end/flambda2/algorithms/patricia_tree.ml index 7561bb9313d..1545ed25096 100644 --- a/middle_end/flambda2/algorithms/patricia_tree.ml +++ b/middle_end/flambda2/algorithms/patricia_tree.ml @@ -12,53 +12,51 @@ (* *) (**************************************************************************) -(* The following is a "little endian" implementation. *) - -(* CR-someday mshinwell: Can we fix the traversal order by swapping endianness? - What other (dis)advantages might that have? - - lmaurer: It would make [split] nearly as fast as [find]. One issue is we'd - want fast clz in order to implement [highest_bit]. *) +(* The following is a "big endian" implementation. *) type key = int +external int_clz : int -> (int[@untagged]) + = "caml_int_clz_tagged_to_tagged" "caml_int_clz_tagged_to_untagged" + [@@noalloc] [@@builtin] [@@no_effects] [@@no_coeffects] + (* A bit [b], represented as a bitmask with only [b] set. This makes testing an individual bit very cheap. *) type bit = int -(* A sequence of bits matched by the beginning (little-endian!) of every key in - a subtree. It has some length, represented as the first [bit] after the - entire prefix. *) +(* A sequence of bits matched by the beginning (big-endian) of every key in a + subtree. It has some length, represented as the first [bit] after the entire + prefix. *) type prefix = int let zero_bit i bit = i land bit = 0 -(* Least significant 1 bit *) -let lowest_bit x = x land -x +(* Most significant 1 bit *) +let highest_bit x = 1 lsl (62 - int_clz x) -(* Lowest bit at which [prefix0] and [prefix1] differ *) -let branching_bit prefix0 prefix1 = lowest_bit (prefix0 lxor prefix1) +(* Highest bit at which [prefix0] and [prefix1] differ *) +let branching_bit prefix0 prefix1 = highest_bit (prefix0 lxor prefix1) -(* Keep only the bits strictly lower than [i] *) -let mask i bit = i land (bit - 1) +(* Keep only the bits strictly higher than [i] *) +let mask i bit = i land -(bit lsl 1) (* Does [i] match [prefix], whose length is [bit]? In other words, does [i] - match [prefix] at every position strictly lower than [bit]? *) + match [prefix] at every position strictly higher than [bit]? *) let match_prefix i prefix bit = mask i bit = prefix let equal_prefix prefix0 bit0 prefix1 bit1 = bit0 = bit1 && prefix0 = prefix1 -let lower bit0 bit1 = +let higher bit0 bit1 = (* Need to do _unsigned_ int comparison *) match bit0 < 0, bit1 < 0 with - | false, false -> bit0 < bit1 - | true, _ -> false (* the only bit < 0 is 0x4000..., which is the highest *) - | false, true -> true + | false, false -> bit0 > bit1 + | _, true -> false (* the only bit < 0 is 0x4000..., which is the highest *) + | true, false -> true (* Is [prefix0], of length [bit0], a sub-prefix of [prefix1], of length [bit1]? *) let includes_prefix prefix0 bit0 prefix1 bit1 = - lower bit0 bit1 && match_prefix prefix1 prefix0 bit0 + higher bit0 bit1 && match_prefix prefix1 prefix0 bit0 (* Provides a total ordering over [(prefix, bit)] pairs. Not otherwise specified. (Only useful for implementing [compare], which is similarly @@ -95,8 +93,8 @@ module type Tree = sig (* A tree with the given prefix, the length of the prefix, and two subtrees. If the prefix is P, we require that [t0] has prefix P0 and [t1] has prefix - P1 (note that this is little-endian notation). For efficiency, [t0] and - [t1] are assumed to be non-empty. *) + P1 (note that this is big-endian notation). For efficiency, [t0] and [t1] + are assumed to be non-empty. *) val branch : prefix -> bit -> 'a t -> 'a t -> 'a t (* A view on a given node, corresponding to which of [empty], [leaf], or @@ -289,7 +287,7 @@ module Tree_operations (Tree : Tree) : sig val split : found:('a -> 'b) -> not_found:'b -> key -> 'a t -> 'a t * 'b * 'a t - val to_list_unordered : 'a t -> 'a Binding.t list + val to_list : 'a t -> 'a Binding.t list val merge : 'c is_value -> @@ -580,31 +578,67 @@ end = struct | Leaf _ -> 1 | Branch (_, _, t0, t1) -> cardinal t0 + cardinal t1 - let rec iter f t = + let[@inline always] order_branches bit t0 t1 = + if bit < 0 then t1, t0 else t0, t1 + + let rec unsigned_iter f t = match descr t with | Empty -> () | Leaf (key, d) -> Callback.call f key d | Branch (_, _, t0, t1) -> - iter f t0; - iter f t1 + unsigned_iter f t0; + unsigned_iter f t1 - let rec fold f t acc = + let iter f t = + match descr t with + | Empty -> () + | Leaf (key, d) -> Callback.call f key d + | Branch (_, bit, t0, t1) -> + let t0, t1 = order_branches bit t0 t1 in + unsigned_iter f t0; + unsigned_iter f t1 + + let rec unsigned_fold f t acc = + match descr t with + | Empty -> acc + | Leaf (key, d) -> Callback.call f key d acc + | Branch (_, _, t0, t1) -> unsigned_fold f t1 (unsigned_fold f t0 acc) + + let fold f t acc = match descr t with | Empty -> acc | Leaf (key, d) -> Callback.call f key d acc - | Branch (_, _, t0, t1) -> fold f t0 (fold f t1 acc) + | Branch (_, bit, t0, t1) -> + let t0, t1 = order_branches bit t0 t1 in + unsigned_fold f t1 (unsigned_fold f t0 acc) + + let rec unsigned_for_all p t = + match descr t with + | Empty -> true + | Leaf (key, d) -> Callback.call p key d + | Branch (_, _, t0, t1) -> unsigned_for_all p t0 && unsigned_for_all p t1 - let rec for_all p t = + let for_all p t = match descr t with | Empty -> true | Leaf (key, d) -> Callback.call p key d - | Branch (_, _, t0, t1) -> for_all p t0 && for_all p t1 + | Branch (_, bit, t0, t1) -> + let t0, t1 = order_branches bit t0 t1 in + unsigned_for_all p t0 && unsigned_for_all p t1 + + let rec unsigned_exists p t = + match descr t with + | Empty -> false + | Leaf (key, d) -> Callback.call p key d + | Branch (_, _, t0, t1) -> unsigned_exists p t0 || unsigned_exists p t1 - let rec exists p t = + let exists p t = match descr t with | Empty -> false | Leaf (key, d) -> Callback.call p key d - | Branch (_, _, t0, t1) -> exists p t0 || exists p t1 + | Branch (_, bit, t0, t1) -> + let t0, t1 = order_branches bit t0 t1 in + unsigned_exists p t0 || unsigned_exists p t1 let filter p t = let rec loop t = @@ -639,28 +673,34 @@ end = struct let choose_opt t = match choose t with exception Not_found -> None | choice -> Some choice - let[@inline always] min_binding_by ~compare_key (t : 'a t) : 'a Binding.t = - let rec loop t = - match descr t with - | Empty -> raise Not_found - | Leaf (i, d) -> Binding.create i d - | Branch (_, _, t0, t1) -> - let b0 = loop t0 in - let b1 = loop t1 in - if (compare_key [@inlined hint]) (Binding.key b0) (Binding.key b1) < 0 - then b0 - else b1 - in - loop t + let rec unsigned_min_binding t = + match descr t with + | Empty -> raise Not_found + | Leaf (key, d) -> Binding.create key d + | Branch (_, _, t0, _) -> unsigned_min_binding t0 - let min_binding t = min_binding_by ~compare_key:Int.compare t + let min_binding t = + match descr t with + | Empty -> raise Not_found + | Leaf (key, d) -> Binding.create key d + | Branch (_, bit, t0, t1) -> + unsigned_min_binding (if bit < 0 then t1 else t0) let min_binding_opt t = match min_binding t with exception Not_found -> None | min -> Some min + let rec unsigned_max_binding t = + match descr t with + | Empty -> raise Not_found + | Leaf (key, d) -> Binding.create key d + | Branch (_, _, _, t1) -> unsigned_max_binding t1 + let max_binding t = - let[@inline always] compare_key i1 i2 = Int.compare i2 i1 in - min_binding_by ~compare_key t + match descr t with + | Empty -> raise Not_found + | Leaf (key, d) -> Binding.create key d + | Branch (_, bit, t0, t1) -> + unsigned_max_binding (if bit < 0 then t0 else t1) let max_binding_opt t = match max_binding t with exception Not_found -> None | max -> Some max @@ -701,32 +741,66 @@ end = struct | Branch _, Empty -> -1 | Branch _, Leaf _ -> -1 - (* CR-someday lmaurer: Make this O(n) rather than O(n log n). Easy if we make - a version of [partition] that can drop the element. Even easier if we - switch to big-endian. *) - let[@inline always] split ~found ~not_found i t = - let rec loop ((lt, mem, gt) as acc) t = + (* All entries in [t] have the same sign -- either all are non-negative or all + are negative. + + [i] might be any value. *) + let same_sign_split ~found ~not_found i t = + let rec loop t = match descr t with - | Empty -> acc + | Empty -> + let iv = is_value_of t in + empty iv, not_found, empty iv | Leaf (j, d) -> + let iv = is_value_of t in if i = j - then lt, (found [@inlined hint]) d, gt + then empty iv, found d, empty iv else if j < i - then add j d lt, mem, gt - else lt, mem, add j d gt - | Branch (_, _, t0, t1) -> loop (loop acc t0) t1 + then singleton iv j d, not_found, empty iv + else empty iv, not_found, singleton iv j d + | Branch (prefix, bit, t0, t1) -> + if match_prefix i prefix bit + then + if zero_bit i bit + then + let lt, mem, gt = loop t0 in + lt, mem, branch prefix bit gt t1 + else + let lt, mem, gt = loop t1 in + branch prefix bit t0 lt, mem, gt + else if i < prefix + then empty (is_value_of t), not_found, t + else t, not_found, empty (is_value_of t) in - let empty = empty (is_value_of t) in - loop (empty, not_found, empty) t + loop t + + let split ~found ~not_found i t = + match descr t with + | Branch (_, bit, t0, t1) when bit < 0 -> + (* prefix is necessarily empty *) + if i < 0 + then + let lt, mem, gt = same_sign_split ~found ~not_found i t1 in + lt, mem, branch 0 bit t0 gt + else + let lt, mem, gt = same_sign_split ~found ~not_found i t0 in + branch 0 bit lt t1, mem, gt + | Empty | Leaf _ | Branch _ -> + (same_sign_split [@inlined hint]) ~found ~not_found i t - let to_list_unordered t = + let to_list t = let rec loop acc t = match descr t with | Empty -> acc | Leaf (i, d) -> Binding.create i d :: acc - | Branch (_, _, t0, t1) -> loop (loop acc t0) t1 + | Branch (_, _, t0, t1) -> loop (loop acc t1) t0 in - loop [] t + match descr t with + | Empty -> [] + | Leaf (i, d) -> [Binding.create i d] + | Branch (_, bit, t0, t1) -> + let t0, t1 = order_branches bit t0 t1 in + loop (loop [] t1) t0 (* CR-someday lmaurer: We could borrow Haskell's trick and generalize this function quite a bit, giving us a single implementation of [union], @@ -881,7 +955,13 @@ end = struct | Leaf (key, value) -> Seq.Cons (Binding.create key value, aux r) | Branch (_, _, t1, t2) -> aux (t1 :: t2 :: r) ()) in - aux [t] + fun () -> + match descr t with + | Empty -> Seq.Nil + | Leaf (key, value) -> Seq.Cons (Binding.create key value, aux []) + | Branch (_, bit, t0, t1) -> + let t0, t1 = order_branches bit t0 t1 in + aux [t0; t1] () let[@inline always] of_list iv l = List.fold_left @@ -913,7 +993,7 @@ end = struct let rec check_deep prefix bit t = match descr t with | Empty -> false (* [Empty] should only occur at top level *) - | Leaf (i, _) -> bit = 0 || match_prefix i prefix bit + | Leaf (i, _) -> (bit = 0 && prefix = i) || match_prefix i prefix bit | Branch (prefix', bit', t0, t1) -> (* CR-someday lmaurer: Should check that [bit'] has a POPCOUNT of 1 *) let prefix0 = @@ -922,14 +1002,15 @@ end = struct prefix' land lnot bit' in let prefix1 = prefix' lor bit' in - let bit0 = bit' lsl 1 in + let bit0 = bit' lsr 1 in let bit1 = bit0 in prefix0 = prefix' - && (bit = bit' || lower bit bit') - && (bit = 0 || match_prefix prefix' prefix bit) + && (bit = bit' || higher bit bit') + && bit <> 0 + && match_prefix prefix' prefix bit && check_deep prefix0 bit0 t0 && check_deep prefix1 bit1 t1 in - is_empty t || check_deep 0 0 t + is_empty t || check_deep 0 min_int t end [@@inline always] @@ -969,7 +1050,7 @@ module Set = struct in loop f Empty t - let elements = Ops.to_list_unordered + let elements = Ops.to_list let min_elt = Ops.min_binding @@ -1005,10 +1086,7 @@ module Map = struct let split i t = Ops.split ~found:(fun a -> Some a) ~not_found:None i t - let bindings s = - List.sort - (fun (id1, _) (id2, _) -> Int.compare id1 id2) - (Ops.to_list_unordered s) + let bindings s = Ops.to_list s let map f t = Ops.map Any f t diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 00f1f447c81..c5d4391e3f5 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -993,19 +993,18 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Pmakearray (array_kind, _, _mode) -> let array_kind = Empty_array_kind.of_lambda array_kind in register_const0 acc (Static_const.empty_array array_kind) "empty_array" - | Pmakearray_dynamic (_array_kind, _mode) -> - Misc.fatal_error "Closure_conversion.close_primitive: unimplemented" | Parrayblit _array_set_kind -> Misc.fatal_error "Closure_conversion.close_primitive: unimplemented" - | Pbytes_to_string | Pbytes_of_string | Parray_of_iarray - | Parray_to_iarray | Pignore | Pgetglobal _ | Psetglobal _ | Pgetpredef _ - | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ - | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise _ - | Pufloatfield _ | Psetufloatfield _ | Psequand | Psequor | Pnot | Pnegint - | Pmixedfield _ | Psetmixedfield _ | Paddint | Psubint | Pmulint - | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint - | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats _ - | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat _ + | Pmakearray_dynamic _ | Pbytes_to_string | Pbytes_of_string + | Parray_of_iarray | Parray_to_iarray | Pignore | Pgetglobal _ + | Psetglobal _ | Pgetpredef _ | Pfield _ | Pfield_computed _ | Psetfield _ + | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ + | Pccall _ | Praise _ | Pufloatfield _ | Psetufloatfield _ | Psequand + | Psequor | Pnot | Pnegint | Pmixedfield _ | Psetmixedfield _ | Paddint + | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints + | Pcompare_floats _ | Pcompare_bints _ | Poffsetint _ | Poffsetref _ + | Pintoffloat _ | Pfloatofint (_, _) | Pfloatoffloat32 _ | Pfloat32offloat _ | Pnegfloat (_, _) @@ -1045,11 +1044,13 @@ let close_primitive acc env ~let_bound_ids_with_kinds named | Punbox_vector _ | Pbox_vector (_, _) | Punbox_int _ | Pbox_int _ | Pmake_unboxed_product _ - | Punboxed_product_field _ | Pget_header _ | Prunstack | Pperform - | Presume | Preperform | Patomic_exchange | Patomic_compare_exchange - | Patomic_cas | Patomic_fetch_add | Pdls_get | Ppoll | Patomic_load _ + | Punboxed_product_field _ | Parray_element_size_in_bytes _ + | Pget_header _ | Prunstack | Pperform | Presume | Preperform + | Patomic_exchange _ | Patomic_compare_exchange _ | Patomic_compare_set _ + | Patomic_fetch_add | Patomic_add | Patomic_sub | Patomic_land + | Patomic_lor | Patomic_lxor | Pdls_get | Ppoll | Patomic_load _ | Preinterpret_tagged_int63_as_unboxed_int64 - | Preinterpret_unboxed_int64_as_tagged_int63 -> + | Preinterpret_unboxed_int64_as_tagged_int63 | Ppeek _ | Ppoke _ -> (* Inconsistent with outer match *) assert false in diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 3f232bb6643..80c5b51a1cd 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -535,7 +535,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) id, Lprim (prim, args, loc), body ) -> ( - match Lambda_to_lambda_transforms.transform_primitive env prim args loc with + let env, result = + Lambda_to_lambda_transforms.transform_primitive env prim args loc + in + match result with | Primitive (prim, args, loc) -> (* This case avoids extraneous continuations. *) let exn_continuation : IR.exn_continuation option = 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 a7a1494fa94..48b0d89de2d 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -100,6 +100,16 @@ let standard_int_or_float_of_unboxed_integer (ubint : L.unboxed_integer) : let standard_int_or_float_of_boxed_integer bint = standard_int_or_float_of_unboxed_integer (Primitive.unboxed_integer bint) +let standard_int_or_float_of_peek_or_poke (layout : L.peek_or_poke) : + K.Standard_int_or_float.t = + match layout with + | Ppp_tagged_immediate -> Tagged_immediate + | Ppp_unboxed_float32 -> Naked_float32 + | Ppp_unboxed_float -> Naked_float + | Ppp_unboxed_int32 -> Naked_int32 + | Ppp_unboxed_int64 -> Naked_int64 + | Ppp_unboxed_nativeint -> Naked_nativeint + 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 @@ -814,13 +824,48 @@ let bytes_like_set ~dbg ~unsafe (* Array bounds checks *) +(* The following function constructs bounds checks based on two things: + + 1. The array length kind, which specifies the representation of the array, + including any unboxed product types. This kind is used to establish the + starting field index in the runtime value where the access(es) is/are going + to occur, in addition to how many fields are going to be accessed at a + minimum. "How many fields" is always one except in the case where unboxed + products are involved: in such cases, more than one field may be accessed. + "At a minimum" only applies for vector reinterpret operations as described + next; in all other cases this number is exact. + + 2. The [num_consecutive_elements_being_accessed]. "Elements" here refers to + the non-unarized elements as the user sees via the array get/set primitives. + This value is always 1 except in the case where the array operation is in + fact really a reinterpret operation with a vector input or output (for + example an array of naked floats being read as a 128-bit vector of such + floats). In these latter cases the value of + [num_consecutive_elements_being_accessed] may be greater than 1. This value + may not be greater than 1 if unboxed products are involved, at present. *) + +(* CR mshinwell: When considering vectors and unboxed products, we should think + again about whether the abstractions/concepts here can be improved. *) let multiple_word_array_access_validity_condition array ~size_int - array_length_kind (index_kind : L.array_index_kind) ~width_in_scalars ~index - = + array_length_kind (index_kind : L.array_index_kind) + ~num_consecutive_elements_being_accessed ~index = + let width_in_scalars_per_access = + P.Array_kind_for_length.width_in_scalars array_length_kind + in + assert (width_in_scalars_per_access >= 1); let length_tagged = H.Prim (Unary (Array_length array_length_kind, array)) in - if width_in_scalars < 1 - then Misc.fatal_errorf "Invalid width_in_scalars value: %d" width_in_scalars - else if width_in_scalars = 1 + if num_consecutive_elements_being_accessed < 1 + then + Misc.fatal_errorf + "Invalid num_consecutive_elements_being_accessed value: %d" + num_consecutive_elements_being_accessed + else if width_in_scalars_per_access > 1 + && num_consecutive_elements_being_accessed > 1 + then + Misc.fatal_error + "Unboxed product arrays cannot involve vector accesses at present" + else if width_in_scalars_per_access = 1 + && num_consecutive_elements_being_accessed = 1 then (* Ensure good code generation in the common case. *) check_bound ~index_kind ~bound_kind:Tagged_immediate ~index @@ -828,13 +873,19 @@ let multiple_word_array_access_validity_condition array ~size_int else let length_untagged = untag_int length_tagged in let reduced_length_untagged = - H.Prim - (Binary - ( Int_arith (Naked_immediate, Sub), - length_untagged, - Simple - (Simple.untagged_const_int - (Targetint_31_63.of_int (width_in_scalars - 1))) )) + if num_consecutive_elements_being_accessed = 1 + then length_untagged + else + (* This is used for vector accesses, where no unarization is + involved. *) + H.Prim + (Binary + ( Int_arith (Naked_immediate, Sub), + length_untagged, + Simple + (Simple.untagged_const_int + (Targetint_31_63.of_int + (num_consecutive_elements_being_accessed - 1))) )) in (* We need to convert the length into a naked_nativeint because the optimised version of the max_with_zero function needs to be on @@ -847,34 +898,21 @@ let multiple_word_array_access_validity_condition array ~size_int reduced_length_untagged )) in let nativeint_bound = max_with_zero ~size_int reduced_length_nativeint in - let index : H.simple_or_prim = - (* [length_tagged] is in units of scalars. Multiply up [index] to - match. *) - let multiplier = - P.Array_kind_for_length.width_in_scalars array_length_kind - in - let arith_kind, multiplier = - match index_kind with - | Ptagged_int_index -> - ( I.Tagged_immediate, - Simple.const_int (Targetint_31_63.of_int multiplier) ) - | Punboxed_int_index bint -> ( - match bint with - | Unboxed_int32 -> - ( I.Naked_int32, - Simple.const - (Reg_width_const.naked_int32 (Int32.of_int multiplier)) ) - | Unboxed_int64 -> - ( I.Naked_int64, - Simple.const - (Reg_width_const.naked_int64 (Int64.of_int multiplier)) ) - | Unboxed_nativeint -> - ( I.Naked_nativeint, - Simple.const - (Reg_width_const.naked_nativeint - (Targetint_32_64.of_int multiplier)) )) - in - Prim (Binary (Int_arith (arith_kind, Mul), index, Simple multiplier)) + let nativeint_bound : H.simple_or_prim = + if width_in_scalars_per_access = 1 + then nativeint_bound + else + (* This is used for unboxed product accesses. [index] is in non-unarized + terms and we don't touch it, to avoid risks of overflow. Instead we + compute the non-unarized bound, then compare against that. *) + Prim + (Binary + ( Int_arith (Naked_nativeint, Div), + nativeint_bound, + Simple + (Simple.const + (Reg_width_const.naked_nativeint + (Targetint_32_64.of_int width_in_scalars_per_access))) )) in check_bound ~index_kind ~bound_kind:Naked_nativeint ~index ~bound:nativeint_bound @@ -883,25 +921,25 @@ let multiple_word_array_access_validity_condition array ~size_int (* CR mshinwell: it seems like these could be folded into the normal array load/store functions below *) -let array_vector_access_width_in_scalars (array_kind : P.Array_kind.t) = - match array_kind with - | Naked_vec128s -> 1 - | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 - | Naked_int32s | Naked_float32s -> 4 - | Values -> - Misc.fatal_error - "Attempted to load/store a SIMD vector from/to a value array." - | Unboxed_product _ -> - (* CR mshinwell: support unboxed products involving vectors? *) - Misc.fatal_error - "Attempted to load/store a SIMD vector from/to an unboxed product array, \ - which is not yet supported." - let array_vector_access_validity_condition array ~size_int (array_kind : P.Array_kind.t) index = - let width_in_scalars = array_vector_access_width_in_scalars array_kind in + let num_consecutive_elements_being_accessed = + match array_kind with + | Naked_vec128s -> 1 + | Naked_floats | Immediates | Naked_int64s | Naked_nativeints -> 2 + | Naked_int32s | Naked_float32s -> 4 + | Values -> + Misc.fatal_error + "Attempted to load/store a SIMD vector from/to a value array." + | Unboxed_product _ -> + (* CR mshinwell: support unboxed products involving vectors? *) + Misc.fatal_error + "Attempted to load/store a SIMD vector from/to an unboxed product \ + array, which is not yet supported." + in multiple_word_array_access_validity_condition array ~size_int - (Array_kind array_kind) Ptagged_int_index ~width_in_scalars ~index + (Array_kind array_kind) Ptagged_int_index + ~num_consecutive_elements_being_accessed ~index let check_array_vector_access ~dbg ~size_int ~array array_kind ~index primitive : H.expr_primitive = @@ -1053,17 +1091,16 @@ let bigarray_set ~dbg ~unsafe kind layout b indexes value = (* Array accesses *) let array_access_validity_condition array array_kind index - ~(index_kind : L.array_index_kind) ~width_in_scalars ~size_int = + ~(index_kind : L.array_index_kind) ~size_int = [ multiple_word_array_access_validity_condition array ~size_int array_kind - index_kind ~width_in_scalars ~index ] + index_kind ~num_consecutive_elements_being_accessed:1 ~index ] let check_array_access ~dbg ~array array_kind ~index ~index_kind ~size_int primitive : H.expr_primitive = - let width_in_scalars = P.Array_kind_for_length.width_in_scalars array_kind in checked_access ~primitive ~conditions: (array_access_validity_condition array array_kind index ~index_kind - ~width_in_scalars ~size_int) + ~size_int) ~dbg let compute_array_indexes ~index ~num_elts = @@ -1190,7 +1227,7 @@ let rec array_set_unsafe dbg ~array ~index array_kind then Misc.fatal_errorf "Wrong arity for unboxed product array_set_unsafe:@ %a" Debuginfo.print_compact dbg; - (* XXX mshinwell: should these be set in reverse order, to match the + (* CR mshinwell: should these be set in reverse order, to match the evaluation order? *) [ H.Sequence (List.concat_map @@ -1336,6 +1373,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) let mutability = Mutability.from_lambda mutability in [Variadic (Make_block (Values (tag, shape), mutability, mode), args)] | Pmake_unboxed_product layouts, _ -> + (* CR mshinwell: this should check the unarized lengths of [layouts] and + [args] (like [Parray_element_size_in_bytes] below) *) if List.compare_lengths layouts args <> 0 then Misc.fatal_errorf "Pmake_unboxed_product: expected %d arguments, got %d" @@ -1365,6 +1404,26 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) |> Array.to_list in List.map (fun arg : H.expr_primitive -> Simple arg) projected_args + | Parray_element_size_in_bytes array_kind, [_witness] -> + (* This is implemented as a unary primitive, but from our point of view it's + actually nullary. *) + let num_bytes = + match array_kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray -> 8 + | Punboxedfloatarray Unboxed_float32 -> + (* float32# arrays are packed *) + 4 + | Punboxedfloatarray Unboxed_float64 -> 8 + | Punboxedintarray Unboxed_int32 -> + (* int32# arrays are packed *) + 4 + | Punboxedintarray (Unboxed_int64 | Unboxed_nativeint) -> 8 + | Punboxedvectorarray Unboxed_vec128 -> 16 + | Pgcscannableproductarray _ | Pgcignorableproductarray _ -> + (* All elements of unboxed product arrays are currently 8 bytes wide. *) + L.count_initializers_array_kind array_kind * 8 + in + [Simple (Simple.const_int (Targetint_31_63.of_int num_bytes))] | Pmakefloatblock (mutability, mode), _ -> let args = List.flatten args in let mode = Alloc_mode.For_allocations.from_lambda mode ~current_region in @@ -1431,10 +1490,10 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) List.map unbox_float args ), Variadic (Make_array (Values, mutability, mode), args), [K.With_subkind.any_value] ) ])) - | Pmakearray_dynamic (_lambda_array_kind, _mode), _ -> - Misc.fatal_error "Lambda_to_flambda_primitives.convert_lprim: unimplemented" - | Parrayblit _array_set_kind, _ -> - Misc.fatal_error "Lambda_to_flambda_primitives.convert_lprim: unimplemented" + | Pmakearray_dynamic _, _ | Parrayblit _, _ -> + Misc.fatal_error + "Lambda_to_flambda_primitives.convert_lprim: Pmakearray_dynamic and \ + Parrayblit should have been expanded in [Lambda_to_lambda_transforms]" | Popaque layout, [arg] -> opaque layout arg ~middle_end_only:false | Pobj_magic layout, [arg] -> opaque layout arg ~middle_end_only:true | Pduprecord (repr, num_fields), [[arg]] -> @@ -1976,6 +2035,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [Binary (Int_arith (I.Tagged_immediate, Div), arg1, arg2)] | Pdivint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Div None arg1 arg2 ~current_region] + | Pmodint Unsafe, [[arg1]; [arg2]] -> + [H.Binary (Int_arith (I.Tagged_immediate, Mod), arg1, arg2)] | Pmodint Safe, [[arg1]; [arg2]] -> [checked_arith_op ~dbg None Mod None arg1 arg2 ~current_region] | Pdivbint { size = Boxed_int32; is_safe = Safe; mode }, [[arg1]; [arg2]] -> @@ -2321,14 +2382,34 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) [ Unary ( Atomic_load (convert_block_access_field_kind immediate_or_pointer), atomic ) ] - | Patomic_exchange, [[atomic]; [new_value]] -> - [Binary (Atomic_exchange, atomic, new_value)] - | Patomic_compare_exchange, [[atomic]; [old_value]; [new_value]] -> - [Ternary (Atomic_compare_exchange, atomic, old_value, new_value)] - | Patomic_cas, [[atomic]; [old_value]; [new_value]] -> - [Ternary (Atomic_compare_and_set, atomic, old_value, new_value)] + | Patomic_exchange { immediate_or_pointer }, [[atomic]; [new_value]] -> + [ Binary + ( Atomic_exchange (convert_block_access_field_kind immediate_or_pointer), + atomic, + new_value ) ] + | ( Patomic_compare_exchange { immediate_or_pointer }, + [[atomic]; [old_value]; [new_value]] ) -> + [ Ternary + ( Atomic_compare_exchange + (convert_block_access_field_kind immediate_or_pointer), + atomic, + old_value, + new_value ) ] + | ( Patomic_compare_set { immediate_or_pointer }, + [[atomic]; [old_value]; [new_value]] ) -> + [ Ternary + ( Atomic_compare_and_set + (convert_block_access_field_kind immediate_or_pointer), + atomic, + old_value, + new_value ) ] | Patomic_fetch_add, [[atomic]; [i]] -> - [Binary (Atomic_fetch_and_add, atomic, i)] + [Binary (Atomic_int_arith Fetch_add, atomic, i)] + | Patomic_add, [[atomic]; [i]] -> [Binary (Atomic_int_arith Add, atomic, i)] + | Patomic_sub, [[atomic]; [i]] -> [Binary (Atomic_int_arith Sub, atomic, i)] + | Patomic_land, [[atomic]; [i]] -> [Binary (Atomic_int_arith And, atomic, i)] + | Patomic_lor, [[atomic]; [i]] -> [Binary (Atomic_int_arith Or, atomic, i)] + | Patomic_lxor, [[atomic]; [i]] -> [Binary (Atomic_int_arith Xor, atomic, i)] | Pdls_get, _ -> [Nullary Dls_get] | Ppoll, _ -> [Nullary Poll] | Preinterpret_unboxed_int64_as_tagged_int63, [[i]] -> @@ -2345,8 +2426,13 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) "Preinterpret_tagged_int63_as_unboxed_int64 can only be used on 64-bit \ targets"; [Unary (Reinterpret_64_bit_word Tagged_int63_as_unboxed_int64, i)] - | ( ( Pmodint Unsafe - | Pdivbint { is_safe = Unsafe; size = _; mode = _ } + | Ppeek layout, [[ptr]] -> + let kind = standard_int_or_float_of_peek_or_poke layout in + [Unary (Peek kind, ptr)] + | Ppoke layout, [[ptr]; [new_value]] -> + let kind = standard_int_or_float_of_peek_or_poke layout in + [Binary (Poke kind, ptr, new_value)] + | ( ( Pdivbint { is_safe = Unsafe; size = _; mode = _ } | Pmodbint { is_safe = Unsafe; size = _; mode = _ } | Psetglobal _ | Praise _ | Pccall _ ), _ ) -> @@ -2377,7 +2463,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Punbox_int _ | Pbox_int _ | Punboxed_product_field _ | Pget_header _ | Pufloatfield _ | Patomic_load _ | Pmixedfield _ | Preinterpret_unboxed_int64_as_tagged_int63 - | Preinterpret_tagged_int63_as_unboxed_int64 ), + | Preinterpret_tagged_int63_as_unboxed_int64 + | Parray_element_size_in_bytes _ | Ppeek _ ), ([] | _ :: _ :: _ | [([] | _ :: _ :: _)]) ) -> Misc.fatal_errorf "Closure_conversion.convert_primitive: Wrong arity for unary primitive \ @@ -2419,8 +2506,9 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pgcscannableproductarray_ref _ | Pgcignorableproductarray_ref _ ), _, _ ) - | Pcompare_ints | Pcompare_floats _ | Pcompare_bints _ | Patomic_exchange - | Patomic_fetch_add ), + | Pcompare_ints | Pcompare_floats _ | Pcompare_bints _ + | Patomic_exchange _ | Patomic_fetch_add | Patomic_add | Patomic_sub + | Patomic_land | Patomic_lor | Patomic_lxor | Ppoke _ ), ( [] | [_] | _ :: _ :: _ :: _ @@ -2449,8 +2537,8 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list) | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _ | Punboxed_float_array_set_128 _ | Punboxed_float32_array_set_128 _ | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _ - | Punboxed_nativeint_array_set_128 _ | Patomic_cas - | Patomic_compare_exchange ), + | Punboxed_nativeint_array_set_128 _ | Patomic_compare_set _ + | Patomic_compare_exchange _ ), ( [] | [_] | [_; _] diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli index c678ffe5494..70cbfc63835 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.mli @@ -17,6 +17,8 @@ module Acc = Closure_conversion_aux.Acc module Expr_with_acc = Closure_conversion_aux.Expr_with_acc +val check_float_array_optimisation_enabled : string -> unit + val convert_and_bind : Acc.t -> big_endian:bool -> diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml index 7886600e567..6e99267f42d 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml @@ -110,7 +110,447 @@ let rec_catch_for_for_loop env loc ident start stop in env, lam -let transform_primitive env (prim : L.primitive) args loc = +type initialize_array_element_width = + | Thirty_two of { zero_init : L.lambda } + | Sixty_four_or_more + +let initialize_array0 env loc ~length array_set_kind width ~(init : L.lambda) + creation_expr = + let array = Ident.create_local "array" in + (* If the element size is 32-bit, zero-initialize the last 64-bit word, to + ensure reproducibility. *) + (* CR mshinwell: why does e.g. caml_make_unboxed_int32_vect not do this? *) + let maybe_zero_init_last_field = + match width with + | Sixty_four_or_more -> L.lambda_unit + | Thirty_two { zero_init } -> + let zero_init_last_field = + L.Lprim + ( Parraysetu (array_set_kind, Ptagged_int_index), + (* [Popaque] is used to conceal the out-of-bounds write. *) + [Lprim (Popaque L.layout_unit, [Lvar array], loc); length; zero_init], + loc ) + in + let length_is_greater_than_zero_and_is_one_mod_two = + L.Lprim + ( Psequand, + [ Lprim (Pintcomp Cgt, [length; Lconst (L.const_int 0)], loc); + Lprim + ( Pintcomp Cne, + [ Lprim (Pmodint Unsafe, [length; Lconst (L.const_int 2)], loc); + Lconst (L.const_int 0) ], + loc ) ], + loc ) + in + L.Lifthenelse + ( length_is_greater_than_zero_and_is_one_mod_two, + zero_init_last_field, + L.lambda_unit, + L.layout_unit ) + in + let env, initialize = + let index = Ident.create_local "index" in + rec_catch_for_for_loop env loc index + (Lconst (L.const_int 0)) + (L.Lprim (Psubint, [length; Lconst (L.const_int 1)], loc)) + Upto + (Lprim + ( Parraysetu (array_set_kind, Ptagged_int_index), + [Lvar array; Lvar index; init], + loc )) + in + let term = + L.Llet + ( Strict, + Pvalue { raw_kind = Pgenval; nullable = Non_nullable }, + array, + creation_expr, + Lsequence + (maybe_zero_init_last_field, Lsequence (initialize, Lvar array)) ) + in + env, Transformed term + +let initialize_array env loc ~length array_set_kind width ~init creation_expr = + match init with + | None -> env, Transformed creation_expr + | Some init -> + initialize_array0 env loc ~length array_set_kind width ~init creation_expr + +let makearray_dynamic_singleton name (mode : L.locality_mode) ~length ~init loc + = + let name = + Printf.sprintf "caml_make%s_%s%svect" + (match mode with Alloc_heap -> "" | Alloc_local -> "_local") + name + (if String.length name > 0 then "_" else "") + in + let external_call_desc = + Primitive.make ~name ~alloc:true (* the C stub may raise an exception *) + ~c_builtin:false ~effects:Arbitrary_effects ~coeffects:Has_coeffects + ~native_name:name + ~native_repr_args: + ([Primitive.Prim_global, L.Same_as_ocaml_repr (Base Value)] + @ + match init with + | None -> [] + | Some (init_extern_repr, _) -> [Primitive.Prim_local, init_extern_repr] + ) + ~native_repr_res: + ( (match mode with + | Alloc_heap -> Prim_global + | Alloc_local -> Prim_local), + L.Same_as_ocaml_repr (Base Value) ) + ~is_layout_poly:false + in + L.Lprim + ( Pccall external_call_desc, + ([length] @ match init with None -> [] | Some (_, init) -> [init]), + loc ) + +let makearray_dynamic_singleton_uninitialized name (mode : L.locality_mode) + ~length loc = + makearray_dynamic_singleton name + (mode : L.locality_mode) + ~length ~init:None loc + +let makearray_dynamic_unboxed_products_only_64_bit () = + (* To keep things simple in the C stub as regards array length, we currently + restrict to 64-bit targets. *) + if not (Target_system.is_64_bit ()) + then + Misc.fatal_error + "Cannot compile Pmakearray_dynamic at unboxed product layouts for 32-bit \ + targets" + +let makearray_dynamic_unboxed_product_c_stub ~name (mode : L.locality_mode) = + Primitive.make ~name ~alloc:true (* the C stub may raise an exception *) + ~c_builtin:false ~effects:Arbitrary_effects ~coeffects:Has_coeffects + ~native_name:name + ~native_repr_args: + [ Prim_global, L.Same_as_ocaml_repr (Base Value); + Prim_local, L.Same_as_ocaml_repr (Base Value); + Prim_global, L.Same_as_ocaml_repr (Base Value) ] + ~native_repr_res: + ( (match mode with Alloc_heap -> Prim_global | Alloc_local -> Prim_local), + L.Same_as_ocaml_repr (Base Value) ) + ~is_layout_poly:false + +let makearray_dynamic_non_scannable_unboxed_product env + (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length + ~(init : L.lambda option) loc = + makearray_dynamic_unboxed_products_only_64_bit (); + let is_local = + L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) + in + let external_call_desc = + makearray_dynamic_unboxed_product_c_stub + ~name:"caml_makearray_dynamic_non_scannable_unboxed_product" mode + in + let num_components = L.count_initializers_array_kind lambda_array_kind in + (* Note that we don't check the number of unarized arguments against the + layout; we trust the front end. If we wanted to do this, it would have to + be done slightly later, after unarization. *) + (* CR mshinwell: two things were tried here, but one is dirty and the other + needed too much work: + + - CPS convert the primitive arguments before getting here. They may then + have to be converted a second time, in the event that the primitive is + transformed by this file. + + - For this primitive only, have a function passed in here which when + called, does the CPS conversion of the arguments and then escapes using an + exception, returning the number of arguments. This seems dirty. + + Both of these cases introduce complexity as it is necessary to go back to + using an older accumulator during CPS conversion. This is probably fine but + is a real change. *) + let term = + L.( + Lprim + ( Pccall external_call_desc, + [Lconst (L.const_int num_components); is_local; length], + loc )) + in + match init with + | None -> env, Transformed term + | Some init -> + initialize_array0 env loc ~length + (L.array_set_kind + (match mode with + | Alloc_heap -> L.modify_heap + | Alloc_local -> L.modify_maybe_stack) + lambda_array_kind) + (* There is no packing in unboxed product arrays, even if the elements are + all float32# or int32#. *) + Sixty_four_or_more ~init term + +let makearray_dynamic_scannable_unboxed_product0 + (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length ~init + loc = + makearray_dynamic_unboxed_products_only_64_bit (); + (* Trick: use the local stack as a way of getting the variable argument list + to the C function. *) + if not Config.stack_allocation + then + Misc.fatal_error + "Cannot compile Pmakearray_dynamic at unboxed product layouts without \ + stack allocation enabled"; + let args_array = Ident.create_local "args_array" in + let array_layout = L.layout_array lambda_array_kind in + let is_local = + L.of_bool (match mode with Alloc_heap -> false | Alloc_local -> true) + in + let external_call_desc = + makearray_dynamic_unboxed_product_c_stub + ~name:"caml_makearray_dynamic_scannable_unboxed_product" mode + in + (* Note that we don't check the number of unarized arguments against the + layout; we trust the front end. If we wanted to do this, it would have to + be done slightly later, after unarization. *) + let body = + L.Llet + ( Strict, + array_layout, + args_array, + Lprim + ( Pmakearray (lambda_array_kind, Immutable, L.alloc_local), + [init] (* will be unarized when this term is CPS converted *), + loc ), + Lprim + (Pccall external_call_desc, [Lvar args_array; is_local; length], loc) + ) + in + (* We must not add a region if the C stub is going to return a local value, + otherwise we will incorrectly close the region on such live value. *) + Transformed + (match mode with + | Alloc_local -> body + | Alloc_heap -> L.Lregion (body, array_layout)) + +let makearray_dynamic_scannable_unboxed_product env + (lambda_array_kind : L.array_kind) (mode : L.locality_mode) ~length + ~(init : L.lambda) loc = + let must_be_scanned = + match lambda_array_kind with + | Pgcignorableproductarray _ -> false + | Pgcscannableproductarray kinds -> + let rec must_be_scanned (kind : L.scannable_product_element_kind) = + match kind with + | Pint_scannable -> false + | Paddr_scannable -> true + | Pproduct_scannable kinds -> List.exists must_be_scanned kinds + in + List.exists must_be_scanned kinds + | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _ + | Punboxedintarray _ | Punboxedvectorarray _ -> + Misc.fatal_errorf + "%s: should have been sent to [makearray_dynamic_singleton]" + (Printlambda.array_kind lambda_array_kind) + in + if must_be_scanned + then + ( env, + makearray_dynamic_scannable_unboxed_product0 lambda_array_kind mode + ~length ~init loc ) + else + makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode + ~length ~init:(Some init) loc + +let makearray_dynamic env (lambda_array_kind : L.array_kind) + (mode : L.locality_mode) (has_init : L.has_initializer) args loc : + Env.t * primitive_transform_result = + (* %makearray_dynamic is analogous to (from stdlib/array.ml): + * external create: int -> 'a -> 'a array = "caml_make_vect" + * except that it works on any layout, including unboxed products, at both + * heap and local modes. + * Additionally, if the initializer is omitted, an uninitialized array will + * be returned. Initializers must however be provided when the array kind is + * Pgenarray, Paddrarray, Pintarray, Pfloatarray or Pgcscannableproductarray; + * or when a Pgcignorablearray involves an [int]. (See comment below.) + *) + let dbg = Debuginfo.from_location loc in + let length, init = + match args, has_init with + | [length], Uninitialized -> length, None + | [length; init], With_initializer -> length, Some init + | _, (Uninitialized | With_initializer) -> + Misc.fatal_errorf + "Pmakearray_dynamic takes the (non-unarized) length and optionally an \ + initializer (the latter perhaps of unboxed product layout) according \ + to the setting of [Uninitialized] or [With_initializer]:@ %a" + Debuginfo.print_compact dbg + in + let[@inline] must_have_initializer () = + match init with + | Some init -> init + | None -> ( + match lambda_array_kind with + | Pintarray | Pgcignorableproductarray _ -> + (* If we get here for [Pgcignorableproductarray] then a tagged immediate + is involved: see main [match] below. *) + Misc.fatal_errorf + "Cannot compile Pmakearray_dynamic at layout %s without an \ + initializer; otherwise it might be possible for values of type \ + [int] having incorrect representations to be revealed, thus \ + breaking soundness:@ %a" + (Printlambda.array_kind lambda_array_kind) + Debuginfo.print_compact dbg + | Pgenarray | Paddrarray | Pfloatarray | Punboxedfloatarray _ + | Punboxedintarray _ | Punboxedvectorarray _ | Pgcscannableproductarray _ + -> + Misc.fatal_errorf + "Cannot compile Pmakearray_dynamic at layout %s without an \ + initializer:@ %a" + (Printlambda.array_kind lambda_array_kind) + Debuginfo.print_compact dbg) + in + match lambda_array_kind with + | Pgenarray | Paddrarray | Pintarray | Pfloatarray -> + let init = must_have_initializer () in + ( env, + Transformed + (makearray_dynamic_singleton "" mode ~length + ~init:(Some (Same_as_ocaml_repr (Base Value), init)) + loc) ) + | Punboxedfloatarray Unboxed_float32 -> + makearray_dynamic_singleton_uninitialized "unboxed_float32" ~length mode loc + |> initialize_array env loc ~length (Punboxedfloatarray_set Unboxed_float32) + (Thirty_two + { zero_init = Lconst (Const_base (Const_unboxed_float32 "0")) }) + ~init + | Punboxedfloatarray Unboxed_float64 -> + makearray_dynamic_singleton_uninitialized "unboxed_float64" ~length mode loc + |> initialize_array env loc ~length (Punboxedfloatarray_set Unboxed_float64) + Sixty_four_or_more ~init + | Punboxedintarray Unboxed_int32 -> + makearray_dynamic_singleton_uninitialized "unboxed_int32" ~length mode loc + |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_int32) + (Thirty_two + { zero_init = Lconst (Const_base (Const_unboxed_int32 0l)) }) + ~init + | Punboxedintarray Unboxed_int64 -> + makearray_dynamic_singleton_uninitialized "unboxed_int64" ~length mode loc + |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_int64) + Sixty_four_or_more ~init + | Punboxedintarray Unboxed_nativeint -> + makearray_dynamic_singleton_uninitialized "unboxed_nativeint" ~length mode + loc + |> initialize_array env loc ~length (Punboxedintarray_set Unboxed_nativeint) + Sixty_four_or_more ~init + | Punboxedvectorarray Unboxed_vec128 -> + makearray_dynamic_singleton_uninitialized "unboxed_vec128" ~length mode loc + |> initialize_array env loc ~length (Punboxedvectorarray_set Unboxed_vec128) + Sixty_four_or_more ~init + | Pgcscannableproductarray _ -> + let init = must_have_initializer () in + makearray_dynamic_scannable_unboxed_product env lambda_array_kind mode + ~length ~init loc + | Pgcignorableproductarray ignorable -> + (* Care: all (unarized) elements that are valid OCaml values, in this case + of type [int] or equivalent, must be initialized. This is to ensure + soundness in the event of a read occurring prior to initialization (e.g. + by ensuring that values without the bottom bit set cannot be returned at + type [int]). *) + let init = + if List.exists L.ignorable_product_element_kind_involves_int ignorable + then Some (must_have_initializer ()) + else init + in + makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode + ~length ~init loc + +let arrayblit env ~(src_mutability : L.mutable_flag) + ~(dst_array_set_kind : L.array_set_kind) args loc = + let src_array_ref_kind = + (* We don't expect any allocation (e.g. occurring from the reading of a + [float array]) to persist after simplification. We use [alloc_local] just + in case that simplification doesn't happen for some reason (this seems + unlikely). *) + L.array_ref_kind_of_array_set_kind dst_array_set_kind L.alloc_local + in + match args with + | [src_expr; src_start_pos_expr; dst_expr; dst_start_pos_expr; length_expr] -> + (* Care: the [args] are arbitrary Lambda expressions, so need to be + [let]-bound *) + let id = Ident.create_local in + let bind = L.bind_with_layout in + let src = id "src" in + let src_start_pos = id "src_start_pos" in + let dst = id "dst" in + let dst_start_pos = id "dst_start_pos" in + let length = id "length" in + (* CR mshinwell: support indexing by other types apart from [int] *) + let src_end_pos_exclusive = + L.Lprim (Paddint, [Lvar src_start_pos; Lvar length], loc) + in + let src_end_pos_inclusive = + L.Lprim (Psubint, [src_end_pos_exclusive; Lconst (L.const_int 1)], loc) + in + let dst_start_pos_minus_src_start_pos = + L.Lprim (Psubint, [Lvar dst_start_pos; Lvar src_start_pos], loc) + in + let dst_start_pos_minus_src_start_pos_var = + Ident.create_local "dst_start_pos_minus_src_start_pos" + in + let must_copy_backwards = + L.Lprim (Pintcomp Cgt, [Lvar dst_start_pos; Lvar src_start_pos], loc) + in + let make_loop env (direction : Asttypes.direction_flag) = + let src_index = Ident.create_local "index" in + let start_pos, end_pos = + match direction with + | Upto -> L.Lvar src_start_pos, src_end_pos_inclusive + | Downto -> src_end_pos_inclusive, L.Lvar src_start_pos + in + rec_catch_for_for_loop env loc src_index start_pos end_pos direction + (Lprim + ( Parraysetu (dst_array_set_kind, Ptagged_int_index), + [ Lvar dst; + Lprim + ( Paddint, + [Lvar src_index; dst_start_pos_minus_src_start_pos], + loc ); + Lprim + ( Parrayrefu + ( src_array_ref_kind, + Ptagged_int_index, + match src_mutability with + | Immutable | Immutable_unique -> Immutable + | Mutable -> Mutable ), + [Lvar src; Lvar src_index], + loc ) ], + loc )) + in + let env, copy_backwards = make_loop env Downto in + let env, copy_forwards = make_loop env Upto in + let body = + (* The region is expected to be redundant (see comment above about + modes). *) + L.Lregion + ( L.Lifthenelse + (must_copy_backwards, copy_backwards, copy_forwards, L.layout_unit), + L.layout_unit ) + in + let expr = + (* Preserve right-to-left evaluation order. *) + bind Strict (length, L.layout_int) length_expr + @@ bind Strict (dst_start_pos, L.layout_int) dst_start_pos_expr + @@ bind Strict (dst, L.layout_any_value) dst_expr + @@ bind Strict (src_start_pos, L.layout_int) src_start_pos_expr + @@ bind Strict (src, L.layout_any_value) src_expr + @@ bind Strict + (dst_start_pos_minus_src_start_pos_var, L.layout_int) + dst_start_pos_minus_src_start_pos body + in + env, Transformed expr + | _ -> + Misc.fatal_errorf + "Wrong arity for Parrayblit{,_immut} (expected src, src_offset, \ + dst_offset and length):@ %a" + Debuginfo.print_compact + (Debuginfo.from_location loc) + +let transform_primitive0 env (prim : L.primitive) args loc = match prim, args with | Psequor, [arg1; arg2] -> let const_true = Ident.create_local "const_true" in @@ -251,3 +691,12 @@ let transform_primitive env (prim : L.primitive) args loc = (see translprim).") | _, _ -> Primitive (prim, args, loc) [@@ocaml.warning "-fragile-match"] + +let transform_primitive env (prim : L.primitive) args loc = + match prim with + | Pmakearray_dynamic (lambda_array_kind, mode, has_init) -> + makearray_dynamic env lambda_array_kind mode has_init args loc + | Parrayblit { src_mutability; dst_array_set_kind } -> + arrayblit env ~src_mutability ~dst_array_set_kind args loc + | _ -> env, transform_primitive0 env prim args loc + [@@ocaml.warning "-fragile-match"] diff --git a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli index f7a0bd73d04..4ea169908bb 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.mli @@ -44,6 +44,7 @@ val switch_for_if_then_else : val transform_primitive : Lambda_to_flambda_env.t -> Lambda.primitive -> + (* CR mshinwell: consider [Ident.t list] instead for the arguments. *) Lambda.lambda list -> Lambda.scoped_location -> - primitive_transform_result + Lambda_to_flambda_env.t * primitive_transform_result diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index d60a3b8dcd3..488360c5784 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -414,65 +414,6 @@ module Standard_int = struct | Naked_nativeint -> Format.pp_print_string ppf "naked_nativeint" end -module Standard_int_or_float = struct - type t = - | Tagged_immediate - | Naked_immediate - | Naked_float32 - | Naked_float - | Naked_int32 - | Naked_int64 - | Naked_nativeint - - let of_standard_int (t : Standard_int.t) : t = - match t with - | Tagged_immediate -> Tagged_immediate - | Naked_immediate -> Naked_immediate - | Naked_int32 -> Naked_int32 - | Naked_int64 -> Naked_int64 - | Naked_nativeint -> Naked_nativeint - - let to_kind t : kind = - match t with - | Tagged_immediate -> Value - | Naked_immediate -> Naked_number Naked_immediate - | Naked_float32 -> Naked_number Naked_float32 - | Naked_float -> Naked_number Naked_float - | Naked_int32 -> Naked_number Naked_int32 - | Naked_int64 -> Naked_number Naked_int64 - | Naked_nativeint -> Naked_number Naked_nativeint - - include Container_types.Make (struct - type nonrec t = t - - let print ppf t = - match t with - | Tagged_immediate -> Format.pp_print_string ppf "Tagged_immediate" - | Naked_immediate -> Format.pp_print_string ppf "Naked_immediate" - | Naked_float32 -> Format.pp_print_string ppf "Naked_float32" - | Naked_float -> Format.pp_print_string ppf "Naked_float" - | Naked_int32 -> Format.pp_print_string ppf "Naked_int32" - | Naked_int64 -> Format.pp_print_string ppf "Naked_int64" - | Naked_nativeint -> Format.pp_print_string ppf "Naked_nativeint" - - let compare = Stdlib.compare - - let equal t1 t2 = compare t1 t2 = 0 - - let hash = Hashtbl.hash - end) - - let print_lowercase ppf t = - match t with - | Tagged_immediate -> Format.pp_print_string ppf "tagged_immediate" - | Naked_immediate -> Format.pp_print_string ppf "naked_immediate" - | Naked_float32 -> Format.pp_print_string ppf "naked_float32" - | Naked_float -> Format.pp_print_string ppf "naked_float" - | Naked_int32 -> Format.pp_print_string ppf "naked_int32" - | Naked_int64 -> Format.pp_print_string ppf "naked_int64" - | Naked_nativeint -> Format.pp_print_string ppf "naked_nativeint" -end - module Boxable_number = struct type t = | Naked_float32 @@ -1089,3 +1030,69 @@ module Flat_suffix_element = struct | Naked_nativeint -> With_subkind.naked_nativeint | Naked_vec128 -> With_subkind.naked_vec128 end + +module Standard_int_or_float = struct + type t = + | Tagged_immediate + | Naked_immediate + | Naked_float32 + | Naked_float + | Naked_int32 + | Naked_int64 + | Naked_nativeint + + let of_standard_int (t : Standard_int.t) : t = + match t with + | Tagged_immediate -> Tagged_immediate + | Naked_immediate -> Naked_immediate + | Naked_int32 -> Naked_int32 + | Naked_int64 -> Naked_int64 + | Naked_nativeint -> Naked_nativeint + + let to_kind t : kind = + match t with + | Tagged_immediate -> Value + | Naked_immediate -> Naked_number Naked_immediate + | Naked_float32 -> Naked_number Naked_float32 + | Naked_float -> Naked_number Naked_float + | Naked_int32 -> Naked_number Naked_int32 + | Naked_int64 -> Naked_number Naked_int64 + | Naked_nativeint -> Naked_number Naked_nativeint + + include Container_types.Make (struct + type nonrec t = t + + let print ppf t = + match t with + | Tagged_immediate -> Format.pp_print_string ppf "Tagged_immediate" + | Naked_immediate -> Format.pp_print_string ppf "Naked_immediate" + | Naked_float32 -> Format.pp_print_string ppf "Naked_float32" + | Naked_float -> Format.pp_print_string ppf "Naked_float" + | Naked_int32 -> Format.pp_print_string ppf "Naked_int32" + | Naked_int64 -> Format.pp_print_string ppf "Naked_int64" + | Naked_nativeint -> Format.pp_print_string ppf "Naked_nativeint" + + let compare = Stdlib.compare + + let equal t1 t2 = compare t1 t2 = 0 + + let hash = Hashtbl.hash + end) + + let print_lowercase ppf t = + match t with + | Tagged_immediate -> Format.pp_print_string ppf "tagged_immediate" + | Naked_immediate -> Format.pp_print_string ppf "naked_immediate" + | Naked_float32 -> Format.pp_print_string ppf "naked_float32" + | Naked_float -> Format.pp_print_string ppf "naked_float" + | Naked_int32 -> Format.pp_print_string ppf "naked_int32" + | Naked_int64 -> Format.pp_print_string ppf "naked_int64" + | Naked_nativeint -> Format.pp_print_string ppf "naked_nativeint" + + let to_kind_with_subkind t = + match t with + | Tagged_immediate -> With_subkind.tagged_immediate + | Naked_immediate | Naked_float32 | Naked_float | Naked_int32 | Naked_int64 + | Naked_nativeint -> + With_subkind.anything (to_kind t) +end diff --git a/middle_end/flambda2/kinds/flambda_kind.mli b/middle_end/flambda2/kinds/flambda_kind.mli index ca3597cba44..968e4d02eff 100644 --- a/middle_end/flambda2/kinds/flambda_kind.mli +++ b/middle_end/flambda2/kinds/flambda_kind.mli @@ -154,26 +154,6 @@ module Standard_int : sig include Container_types.S with type t := t end -module Standard_int_or_float : sig - (** The same as [Standard_int], but also permitting naked floats. *) - type t = - | Tagged_immediate - | Naked_immediate - | Naked_float32 - | Naked_float - | Naked_int32 - | Naked_int64 - | Naked_nativeint - - val of_standard_int : Standard_int.t -> t - - val to_kind : t -> kind - - val print_lowercase : Format.formatter -> t -> unit - - include Container_types.S with type t := t -end - module Boxable_number : sig (** These kinds are those of the numbers for which a tailored boxed representation exists. *) @@ -343,3 +323,25 @@ module Flat_suffix_element : sig val to_kind_with_subkind : t -> With_subkind.t end + +module Standard_int_or_float : sig + (** The same as [Standard_int], but also permitting naked floats. *) + type t = + | Tagged_immediate + | Naked_immediate + | Naked_float32 + | Naked_float + | Naked_int32 + | Naked_int64 + | Naked_nativeint + + val of_standard_int : Standard_int.t -> t + + val to_kind : t -> kind + + val to_kind_with_subkind : t -> With_subkind.t + + val print_lowercase : Format.formatter -> t -> unit + + include Container_types.S with type t := t +end diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index d0e0c5e0863..cf64409d7a9 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -584,7 +584,7 @@ let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop = | Boolean_not -> Boolean_not | Int_as_pointer _ | Duplicate_block _ | Duplicate_array _ | Bigarray_length _ | Float_arith _ | Reinterpret_64_bit_word _ | Is_boxed_float | Obj_dup - | Get_header | Atomic_load _ -> + | Get_header | Atomic_load _ | Peek _ -> Misc.fatal_errorf "TODO: Unary primitive: %a" Flambda_primitive.Without_args.print (Flambda_primitive.Without_args.Unary op) @@ -609,7 +609,7 @@ let binop env (op : Flambda_primitive.binary_primitive) : Fexpr.binop = | Float_comp (w, c) -> Infix (Float_comp (w, c)) | String_or_bigstring_load (slv, saw) -> String_or_bigstring_load (slv, saw) | Bigarray_get_alignment align -> Bigarray_get_alignment align - | Bigarray_load _ | Atomic_exchange | Atomic_fetch_and_add -> + | Bigarray_load _ | Atomic_exchange _ | Atomic_int_arith _ | Poke _ -> Misc.fatal_errorf "TODO: Binary primitive: %a" Flambda_primitive.Without_args.print (Flambda_primitive.Without_args.Binary op) @@ -645,7 +645,7 @@ let ternop env (op : Flambda_primitive.ternary_primitive) : Fexpr.ternop = let ask = fexpr_of_array_set_kind env ask in Array_set (ak, ask) | Bytes_or_bigstring_set (blv, saw) -> Bytes_or_bigstring_set (blv, saw) - | Bigarray_set _ | Atomic_compare_and_set | Atomic_compare_exchange -> + | Bigarray_set _ | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> Misc.fatal_errorf "TODO: Ternary primitive: %a" Flambda_primitive.Without_args.print (Flambda_primitive.Without_args.Ternary op) diff --git a/middle_end/flambda2/simplify/simplify_binary_primitive.ml b/middle_end/flambda2/simplify/simplify_binary_primitive.ml index 64d8d83bf4d..1dc06962334 100644 --- a/middle_end/flambda2/simplify/simplify_binary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_binary_primitive.ml @@ -1017,7 +1017,7 @@ let simplify_atomic_exchange ~original_prim dacc ~original_term _dbg ~arg1:_ (P.result_kind' original_prim) ~original_term -let simplify_atomic_fetch_and_add ~original_prim dacc ~original_term _dbg +let simplify_atomic_int_arith ~original_prim dacc ~original_term _dbg ~op:_ ~arg1:_ ~arg1_ty:_ ~arg2:_ ~arg2_ty:_ ~result_var = SPR.create_unknown dacc ~result_var (P.result_kind' original_prim) @@ -1027,6 +1027,10 @@ let simplify_block_set _block_access_kind _init_or_assign ~field:_ dacc ~original_term _dbg ~arg1:_ ~arg1_ty:_ ~arg2:_ ~arg2_ty:_ ~result_var = SPR.create_unit dacc ~result_var ~original_term +let simplify_poke dacc ~original_term _dbg ~arg1:_ ~arg1_ty:_ ~arg2:_ ~arg2_ty:_ + ~result_var = + SPR.create_unit dacc ~result_var ~original_term + let simplify_binary_primitive0 dacc original_prim (prim : P.binary_primitive) ~arg1 ~arg1_ty ~arg2 ~arg2_ty dbg ~result_var = let original_term = Named.create_prim original_prim dbg in @@ -1073,8 +1077,9 @@ let simplify_binary_primitive0 dacc original_prim (prim : P.binary_primitive) ~original_prim | Bigarray_get_alignment align -> simplify_bigarray_get_alignment align ~original_prim - | Atomic_exchange -> simplify_atomic_exchange ~original_prim - | Atomic_fetch_and_add -> simplify_atomic_fetch_and_add ~original_prim + | Atomic_exchange _ -> simplify_atomic_exchange ~original_prim + | Atomic_int_arith op -> simplify_atomic_int_arith ~original_prim ~op + | Poke _ -> simplify_poke in simplifier dacc ~original_term dbg ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~result_var @@ -1083,8 +1088,8 @@ let recover_comparison_primitive dacc (prim : P.binary_primitive) ~arg1 ~arg2 = | Block_set _ | Array_load _ | Int_arith _ | Int_shift _ | Int_comp (_, Yielding_int_like_compare_functions _) | Float_arith _ | Float_comp _ | Phys_equal _ | String_or_bigstring_load _ - | Bigarray_load _ | Bigarray_get_alignment _ | Atomic_exchange - | Atomic_fetch_and_add -> + | Bigarray_load _ | Bigarray_get_alignment _ | Atomic_exchange _ + | Atomic_int_arith _ | Poke _ -> None | Int_comp (kind, Yielding_bool op) -> ( match kind with diff --git a/middle_end/flambda2/simplify/simplify_ternary_primitive.ml b/middle_end/flambda2/simplify/simplify_ternary_primitive.ml index 444886f1560..15fb98decd2 100644 --- a/middle_end/flambda2/simplify/simplify_ternary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_ternary_primitive.ml @@ -89,8 +89,9 @@ let simplify_ternary_primitive dacc original_prim (prim : P.ternary_primitive) simplify_bytes_or_bigstring_set bytes_like_value string_accessor_width | Bigarray_set (num_dimensions, bigarray_kind, bigarray_layout) -> simplify_bigarray_set ~num_dimensions bigarray_kind bigarray_layout - | Atomic_compare_and_set -> simplify_atomic_compare_and_set ~original_prim - | Atomic_compare_exchange -> simplify_atomic_compare_exchange ~original_prim + | Atomic_compare_and_set _ -> simplify_atomic_compare_and_set ~original_prim + | Atomic_compare_exchange _ -> + simplify_atomic_compare_exchange ~original_prim in simplifier dacc ~original_term dbg ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~arg3 ~arg3_ty ~result_var diff --git a/middle_end/flambda2/simplify/simplify_unary_primitive.ml b/middle_end/flambda2/simplify/simplify_unary_primitive.ml index 770d4c5320d..54d3ea9b4cf 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -894,6 +894,12 @@ let simplify_is_null dacc ~original_term ~arg:scrutinee ~arg_ty:scrutinee_ty simplify_relational_primitive dacc ~original_term ~scrutinee ~scrutinee_ty ~result_var ~make_shape:(fun scrutinee -> T.is_null ~scrutinee) +let simplify_peek ~original_prim dacc ~original_term ~arg:_ ~arg_ty:_ + ~result_var = + SPR.create_unknown dacc ~result_var + (P.result_kind' original_prim) + ~original_term + let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg ~arg_ty dbg ~result_var = let min_name_mode = Bound_var.name_mode result_var in @@ -955,5 +961,6 @@ let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg | Get_header -> simplify_get_header ~original_prim | Atomic_load block_access_field_kind -> simplify_atomic_load block_access_field_kind ~original_prim + | Peek _ -> simplify_peek ~original_prim in simplifier dacc ~original_term ~arg ~arg_ty ~result_var diff --git a/middle_end/flambda2/terms/code_size.ml b/middle_end/flambda2/terms/code_size.ml index 05c3f1814e4..770ed4b8f6e 100644 --- a/middle_end/flambda2/terms/code_size.ml +++ b/middle_end/flambda2/terms/code_size.ml @@ -381,7 +381,7 @@ let unary_prim_size prim = | End_region { ghost } | End_try_region { ghost } -> if ghost then 0 else 1 | Obj_dup -> needs_caml_c_call_extcall_size + 1 | Get_header -> 2 - | Atomic_load _ -> 1 + | Atomic_load _ | Peek _ -> 1 let binary_prim_size prim = match (prim : Flambda_primitive.binary_primitive) with @@ -403,8 +403,9 @@ let binary_prim_size prim = binary_float_comp_primitive width cmp | Float_comp (_width, Yielding_int_like_compare_functions ()) -> 8 | Bigarray_get_alignment _ -> 3 (* load data + add index + and *) - | Atomic_exchange | Atomic_fetch_and_add -> - does_not_need_caml_c_call_extcall_size + | Atomic_int_arith _ -> 1 + | Atomic_exchange _ -> does_not_need_caml_c_call_extcall_size + | Poke _ -> 1 let ternary_prim_size prim = match (prim : Flambda_primitive.ternary_primitive) with @@ -414,7 +415,8 @@ let ternary_prim_size prim = 5 (* ~ 3 block_load + 2 block_set *) | Bigarray_set (_dims, _kind, _layout) -> 2 (* ~ 1 block_load + 1 block_set *) - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set Immediate -> 1 + | Atomic_compare_and_set Any_value | Atomic_compare_exchange _ -> does_not_need_caml_c_call_extcall_size let variadic_prim_size prim args = diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml index e34a17beedb..ce02191339e 100644 --- a/middle_end/flambda2/terms/flambda_primitive.ml +++ b/middle_end/flambda2/terms/flambda_primitive.ml @@ -1089,6 +1089,7 @@ type unary_primitive = | Obj_dup | Get_header | Atomic_load of Block_access_field_kind.t + | Peek of Flambda_kind.Standard_int_or_float.t (* Here and below, operations that are genuine projections shouldn't be eligible for CSE, since we deal with projections through types. *) @@ -1120,7 +1121,7 @@ let unary_primitive_eligible_for_cse p ~arg = Simple.is_var arg | Project_function_slot _ | Project_value_slot _ -> false | Is_boxed_float | Is_flat_float_array -> true - | End_region _ | End_try_region _ | Obj_dup | Atomic_load _ -> false + | End_region _ | End_try_region _ | Obj_dup | Atomic_load _ | Peek _ -> false let compare_unary_primitive p1 p2 = let unary_primitive_numbering p = @@ -1154,6 +1155,7 @@ let compare_unary_primitive p1 p2 = | Get_header -> 26 | Atomic_load _ -> 27 | Is_null -> 28 + | Peek _ -> 29 in match p1, p2 with | ( Block_load { kind = kind1; mut = mut1; field = field1 }, @@ -1245,7 +1247,7 @@ let compare_unary_primitive p1 p2 = | Bigarray_length _ | Unbox_number _ | Box_number _ | Untag_immediate | Tag_immediate | Project_function_slot _ | Project_value_slot _ | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _ - | Obj_dup | Get_header | Atomic_load _ ), + | Obj_dup | Get_header | Atomic_load _ | Peek _ ), _ ) -> Stdlib.compare (unary_primitive_numbering p1) (unary_primitive_numbering p2) @@ -1312,6 +1314,9 @@ let print_unary_primitive ppf p = | Atomic_load block_access_field_kind -> Format.fprintf ppf "@[(Atomic_load@ %a)@]" Block_access_field_kind.print block_access_field_kind + | Peek kind -> + fprintf ppf "@[(Peek@ %a)@]" + Flambda_kind.Standard_int_or_float.print_lowercase kind let arg_kind_of_unary_primitive p = match p with @@ -1346,6 +1351,7 @@ let arg_kind_of_unary_primitive p = | Obj_dup -> K.value | Get_header -> K.value | Atomic_load _ -> K.value + | Peek _ -> K.naked_nativeint let result_kind_of_unary_primitive p : result_kind = match p with @@ -1383,6 +1389,7 @@ let result_kind_of_unary_primitive p : result_kind = | Obj_dup -> Singleton K.value | Get_header -> Singleton K.naked_nativeint | Atomic_load _ -> Singleton K.value + | Peek kind -> Singleton (K.Standard_int_or_float.to_kind kind) let effects_and_coeffects_of_unary_primitive p : Effects_and_coeffects.t = match p with @@ -1471,7 +1478,9 @@ let effects_and_coeffects_of_unary_primitive p : Effects_and_coeffects.t = Has_coeffects, Strict ) | Get_header -> No_effects, No_coeffects, Strict - | Atomic_load _ -> Arbitrary_effects, Has_coeffects, Strict + | Atomic_load _ | Peek _ -> + (* For the moment, prevent [Peek] from being moved. *) + Arbitrary_effects, Has_coeffects, Strict let unary_classify_for_printing p = match p with @@ -1489,6 +1498,7 @@ let unary_classify_for_printing p = | Is_boxed_float | Is_flat_float_array -> Neither | End_region _ | End_try_region _ -> Neither | Get_header -> Neither + | Peek _ -> Neither let free_names_unary_primitive p = match p with @@ -1510,7 +1520,8 @@ let free_names_unary_primitive p = | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _ | Obj_dup | Get_header - | Atomic_load (_ : Block_access_field_kind.t) -> + | Atomic_load (_ : Block_access_field_kind.t) + | Peek (_ : Flambda_kind.Standard_int_or_float.t) -> Name_occurrences.empty let apply_renaming_unary_primitive p renaming = @@ -1531,7 +1542,8 @@ let apply_renaming_unary_primitive p renaming = | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _ | Project_function_slot _ | Project_value_slot _ | Obj_dup | Get_header - | Atomic_load (_ : Block_access_field_kind.t) -> + | Atomic_load (_ : Block_access_field_kind.t) + | Peek (_ : Flambda_kind.Standard_int_or_float.t) -> p let ids_for_export_unary_primitive p = @@ -1544,7 +1556,8 @@ let ids_for_export_unary_primitive p = | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate | Is_boxed_float | Is_flat_float_array | End_region _ | End_try_region _ | Project_function_slot _ | Project_value_slot _ | Obj_dup | Get_header - | Atomic_load (_ : Block_access_field_kind.t) -> + | Atomic_load (_ : Block_access_field_kind.t) + | Peek (_ : Flambda_kind.Standard_int_or_float.t) -> Ids_for_export.empty type binary_int_arith_op = @@ -1599,6 +1612,24 @@ let print_binary_float_arith_op ppf width op = | Float32, Mul -> fprintf ppf "Float32.*." | Float32, Div -> fprintf ppf "Float32./." +type binary_int_atomic_op = + | Fetch_add + | Add + | Sub + | And + | Or + | Xor + +let print_binary_int_atomic_op ppf op = + let fprintf = Format.fprintf in + match op with + | Fetch_add -> fprintf ppf "xadd" + | Add -> fprintf ppf "+" + | Sub -> fprintf ppf "-" + | And -> fprintf ppf "and" + | Or -> fprintf ppf "or" + | Xor -> fprintf ppf "xor" + type binary_primitive = | Block_set of { kind : Block_access_kind.t; @@ -1616,8 +1647,9 @@ type binary_primitive = | Float_arith of float_bitwidth * binary_float_arith_op | Float_comp of float_bitwidth * unit comparison_behaviour | Bigarray_get_alignment of int - | Atomic_exchange - | Atomic_fetch_and_add + | Atomic_exchange of Block_access_field_kind.t + | Atomic_int_arith of binary_int_atomic_op + | Poke of Flambda_kind.Standard_int_or_float.t let binary_primitive_eligible_for_cse p = match p with @@ -1635,7 +1667,7 @@ let binary_primitive_eligible_for_cse p = floating-point arithmetic operations. See also the comment in effects_and_coeffects of unary primitives. *) Flambda_features.float_const_prop () - | Atomic_exchange | Atomic_fetch_and_add -> false + | Atomic_exchange _ | Atomic_int_arith _ | Poke _ -> false let compare_binary_primitive p1 p2 = let binary_primitive_numbering p = @@ -1651,8 +1683,9 @@ let compare_binary_primitive p1 p2 = | Float_arith _ -> 8 | Float_comp _ -> 9 | Bigarray_get_alignment _ -> 10 - | Atomic_exchange -> 11 - | Atomic_fetch_and_add -> 12 + | Atomic_exchange _ -> 11 + | Atomic_int_arith _ -> 12 + | Poke _ -> 13 in match p1, p2 with | ( Block_set { kind = kind1; init = init1; field = field1 }, @@ -1701,10 +1734,15 @@ let compare_binary_primitive p1 p2 = if c <> 0 then c else Stdlib.compare comp1 comp2 | Bigarray_get_alignment align1, Bigarray_get_alignment align2 -> Int.compare align1 align2 + | ( Atomic_exchange block_access_field_kind1, + Atomic_exchange block_access_field_kind2 ) -> + Block_access_field_kind.compare block_access_field_kind1 + block_access_field_kind2 + | Atomic_int_arith op1, Atomic_int_arith op2 -> Stdlib.compare op1 op2 | ( ( Block_set _ | Array_load _ | String_or_bigstring_load _ | Bigarray_load _ | Phys_equal _ | Int_arith _ | Int_shift _ | Int_comp _ | Float_arith _ | Float_comp _ | Bigarray_get_alignment _ - | Atomic_exchange | Atomic_fetch_and_add ), + | Atomic_exchange _ | Atomic_int_arith _ | Poke _ ), _ ) -> Stdlib.compare (binary_primitive_numbering p1) @@ -1740,8 +1778,14 @@ let print_binary_primitive ppf p = fprintf ppf "." | Bigarray_get_alignment align -> fprintf ppf "@[(Bigarray_get_alignment[%d])@]" align - | Atomic_exchange -> fprintf ppf "Atomic_exchange" - | Atomic_fetch_and_add -> fprintf ppf "Atomic_fetch_and_add" + | Atomic_exchange block_access_field_kind -> + Format.fprintf ppf "@[(Atomic_exchange@ %a)@]" Block_access_field_kind.print + block_access_field_kind + | Atomic_int_arith op -> + Format.fprintf ppf "@[(Atomic_int_arith %a)@]" print_binary_int_atomic_op op + | Poke kind -> + fprintf ppf "@[(Poke@ %a)@]" + Flambda_kind.Standard_int_or_float.print_lowercase kind let args_kind_of_binary_primitive p = match p with @@ -1766,7 +1810,8 @@ let args_kind_of_binary_primitive p = | Float_arith (Float32, _) | Float_comp (Float32, _) -> K.naked_float32, K.naked_float32 | Bigarray_get_alignment _ -> bigstring_kind, K.naked_immediate - | Atomic_exchange | Atomic_fetch_and_add -> K.value, K.value + | Atomic_exchange _ | Atomic_int_arith _ -> K.value, K.value + | Poke kind -> K.naked_nativeint, K.Standard_int_or_float.to_kind kind let result_kind_of_binary_primitive p : result_kind = match p with @@ -1788,7 +1833,9 @@ let result_kind_of_binary_primitive p : result_kind = | Float_arith (Float32, _) -> Singleton K.naked_float32 | Phys_equal _ | Int_comp _ | Float_comp _ -> Singleton K.naked_immediate | Bigarray_get_alignment _ -> Singleton K.naked_immediate - | Atomic_exchange | Atomic_fetch_and_add -> Singleton K.value + | Atomic_exchange _ | Atomic_int_arith Fetch_add -> Singleton K.value + | Atomic_int_arith (Add | Sub | And | Or | Xor) -> Unit + | Poke _ -> Unit let effects_and_coeffects_of_binary_primitive p : Effects_and_coeffects.t = match p with @@ -1816,52 +1863,57 @@ let effects_and_coeffects_of_binary_primitive p : Effects_and_coeffects.t = then No_effects, No_coeffects, Strict else No_effects, Has_coeffects, Strict | Bigarray_get_alignment _ -> No_effects, No_coeffects, Strict - | Atomic_exchange | Atomic_fetch_and_add -> + | Atomic_exchange _ | Atomic_int_arith _ -> Arbitrary_effects, Has_coeffects, Strict + | Poke _ -> Arbitrary_effects, No_coeffects, Strict let binary_classify_for_printing p = match p with | Array_load _ -> Destructive | Block_set _ | Phys_equal _ | Int_arith _ | Int_shift _ | Int_comp _ | Float_arith _ | Float_comp _ | Bigarray_load _ | String_or_bigstring_load _ - | Bigarray_get_alignment _ | Atomic_exchange | Atomic_fetch_and_add -> + | Bigarray_get_alignment _ | Atomic_exchange _ | Atomic_int_arith _ | Poke _ + -> Neither let free_names_binary_primitive p = match p with | Block_set _ | Array_load _ | String_or_bigstring_load _ | Bigarray_load _ | Phys_equal _ | Int_arith _ | Int_shift _ | Int_comp _ | Float_arith _ - | Float_comp _ | Bigarray_get_alignment _ | Atomic_exchange - | Atomic_fetch_and_add -> + | Float_comp _ | Bigarray_get_alignment _ | Atomic_exchange _ + | Atomic_int_arith _ + | Poke (_ : Flambda_kind.Standard_int_or_float.t) -> Name_occurrences.empty let apply_renaming_binary_primitive p _renaming = match p with | Block_set _ | Array_load _ | String_or_bigstring_load _ | Bigarray_load _ | Phys_equal _ | Int_arith _ | Int_shift _ | Int_comp _ | Float_arith _ - | Float_comp _ | Bigarray_get_alignment _ | Atomic_exchange - | Atomic_fetch_and_add -> + | Float_comp _ | Bigarray_get_alignment _ | Atomic_exchange _ + | Atomic_int_arith _ + | Poke (_ : Flambda_kind.Standard_int_or_float.t) -> p let ids_for_export_binary_primitive p = match p with | Block_set _ | Array_load _ | String_or_bigstring_load _ | Bigarray_load _ | Phys_equal _ | Int_arith _ | Int_shift _ | Int_comp _ | Float_arith _ - | Float_comp _ | Bigarray_get_alignment _ | Atomic_exchange - | Atomic_fetch_and_add -> + | Float_comp _ | Bigarray_get_alignment _ | Atomic_exchange _ + | Atomic_int_arith _ + | Poke (_ : Flambda_kind.Standard_int_or_float.t) -> Ids_for_export.empty type ternary_primitive = | Array_set of Array_kind.t * Array_set_kind.t | Bytes_or_bigstring_set of bytes_like_value * string_accessor_width | Bigarray_set of num_dimensions * Bigarray_kind.t * Bigarray_layout.t - | Atomic_compare_and_set - | Atomic_compare_exchange + | Atomic_compare_and_set of Block_access_field_kind.t + | Atomic_compare_exchange of Block_access_field_kind.t let ternary_primitive_eligible_for_cse p = match p with | Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> false let compare_ternary_primitive p1 p2 = @@ -1870,8 +1922,8 @@ let compare_ternary_primitive p1 p2 = | Array_set _ -> 0 | Bytes_or_bigstring_set _ -> 1 | Bigarray_set _ -> 2 - | Atomic_compare_and_set -> 3 - | Atomic_compare_exchange -> 4 + | Atomic_compare_and_set _ -> 3 + | Atomic_compare_exchange _ -> 4 in match p1, p2 with | Array_set (kind1, set_kind1), Array_set (kind2, set_kind2) -> @@ -1889,8 +1941,16 @@ let compare_ternary_primitive p1 p2 = else let c = Stdlib.compare kind1 kind2 in if c <> 0 then c else Stdlib.compare layout1 layout2 + | ( Atomic_compare_and_set block_access_field_kind1, + Atomic_compare_and_set block_access_field_kind2 ) -> + Block_access_field_kind.compare block_access_field_kind1 + block_access_field_kind2 + | ( Atomic_compare_exchange block_access_field_kind1, + Atomic_compare_exchange block_access_field_kind2 ) -> + Block_access_field_kind.compare block_access_field_kind1 + block_access_field_kind2 | ( ( Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ - | Atomic_compare_and_set | Atomic_compare_exchange ), + | Atomic_compare_and_set _ | Atomic_compare_exchange _ ), _ ) -> Stdlib.compare (ternary_primitive_numbering p1) @@ -1911,8 +1971,12 @@ let print_ternary_primitive ppf p = fprintf ppf "@[(Bigarray_set (num_dimensions@ %d)@ (kind@ %a)@ (layout@ %a))@]" num_dimensions Bigarray_kind.print kind Bigarray_layout.print layout - | Atomic_compare_and_set -> fprintf ppf "Atomic_compare_and_set" - | Atomic_compare_exchange -> fprintf ppf "Atomic_compare_exchange" + | Atomic_compare_and_set block_access_field_kind -> + Format.fprintf ppf "@[(Atomic_compare_and_set@ %a)@]" + Block_access_field_kind.print block_access_field_kind + | Atomic_compare_exchange block_access_field_kind -> + Format.fprintf ppf "@[(Atomic_compare_exchange@ %a)@]" + Block_access_field_kind.print block_access_field_kind let args_kind_of_ternary_primitive p = match p with @@ -1942,13 +2006,13 @@ let args_kind_of_ternary_primitive p = bigstring_kind, bytes_or_bigstring_index_kind, K.naked_vec128 | Bigarray_set (_, kind, _) -> bigarray_kind, bigarray_index_kind, Bigarray_kind.element_kind kind - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> K.value, K.value, K.value let result_kind_of_ternary_primitive p : result_kind = match p with | Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ -> Unit - | Atomic_compare_and_set | Atomic_compare_exchange -> Singleton K.value + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> Singleton K.value let effects_and_coeffects_of_ternary_primitive p : Effects.t * Coeffects.t * Placement.t = @@ -1956,31 +2020,31 @@ let effects_and_coeffects_of_ternary_primitive p : | Array_set _ -> writing_to_an_array | Bytes_or_bigstring_set _ -> writing_to_bytes_or_bigstring | Bigarray_set (_, kind, _) -> writing_to_a_bigarray kind - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> Arbitrary_effects, Has_coeffects, Strict let ternary_classify_for_printing p = match p with | Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> Neither let free_names_ternary_primitive p = match p with | Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> Name_occurrences.empty let apply_renaming_ternary_primitive p _ = match p with | Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> p let ids_for_export_ternary_primitive p = match p with | Array_set _ | Bytes_or_bigstring_set _ | Bigarray_set _ - | Atomic_compare_and_set | Atomic_compare_exchange -> + | Atomic_compare_and_set _ | Atomic_compare_exchange _ -> Ids_for_export.empty type variadic_primitive = diff --git a/middle_end/flambda2/terms/flambda_primitive.mli b/middle_end/flambda2/terms/flambda_primitive.mli index d59e2f17fae..eb6277e91a6 100644 --- a/middle_end/flambda2/terms/flambda_primitive.mli +++ b/middle_end/flambda2/terms/flambda_primitive.mli @@ -443,6 +443,9 @@ type unary_primitive = (by the type system) should always go through caml_obj_tag, which is opaque to the compiler. *) | Atomic_load of Block_access_field_kind.t + (* CR mshinwell: consider putting atomicity onto [Peek] and [Poke] then + deleting [Atomic_load] *) + | Peek of Flambda_kind.Standard_int_or_float.t (** Whether a comparison is to yield a boolean result, as given by a particular comparison operator, or whether it is to behave in the manner of "compare" @@ -475,6 +478,15 @@ type binary_float_arith_op = | Mul | Div +(** Binary atomic arithmetic operations on integers. *) +type binary_int_atomic_op = + | Fetch_add + | Add + | Sub + | And + | Or + | Xor + (** Primitives taking exactly two arguments. *) type binary_primitive = | Block_set of @@ -499,8 +511,9 @@ type binary_primitive = | Float_arith of float_bitwidth * binary_float_arith_op | Float_comp of float_bitwidth * unit comparison_behaviour | Bigarray_get_alignment of int - | Atomic_exchange - | Atomic_fetch_and_add + | Atomic_exchange of Block_access_field_kind.t + | Atomic_int_arith of binary_int_atomic_op + | Poke of Flambda_kind.Standard_int_or_float.t (** Primitives taking exactly three arguments. *) type ternary_primitive = @@ -509,8 +522,8 @@ type ternary_primitive = for more details on the unarization. *) | Bytes_or_bigstring_set of bytes_like_value * string_accessor_width | Bigarray_set of num_dimensions * Bigarray_kind.t * Bigarray_layout.t - | Atomic_compare_and_set - | Atomic_compare_exchange + | Atomic_compare_and_set of Block_access_field_kind.t + | Atomic_compare_exchange of Block_access_field_kind.t (** Primitives taking zero or more arguments. *) type variadic_primitive = diff --git a/middle_end/flambda2/tests/algorithms/patricia_tree_tests.ml b/middle_end/flambda2/tests/algorithms/patricia_tree_tests.ml index 2ab49f0cbb5..53857f37111 100644 --- a/middle_end/flambda2/tests/algorithms/patricia_tree_tests.ml +++ b/middle_end/flambda2/tests/algorithms/patricia_tree_tests.ml @@ -281,15 +281,13 @@ module Set_specs = struct let of_list_then_elements l = List.equal Int.equal - (l |> Set.of_list |> Set.elements |> List.sort Int.compare) + (l |> Set.of_list |> Set.elements) (l |> List.sort_uniq Int.compare) let elements_then_of_list s = Set.equal s (s |> Set.elements |> Set.of_list) let to_seq s = - List.equal Int.equal - (s |> Set.to_seq |> List.of_seq |> List.sort Int.compare) - (s |> Set.elements |> List.sort Int.compare) + List.equal Int.equal (s |> Set.to_seq |> List.of_seq) (s |> Set.elements) let union_list l = Set.equal (Set.union_list l) (List.fold_left Set.union Set.empty l) @@ -317,9 +315,6 @@ module Map_specs (V : Value) = struct let equal_bindings (k1, v1) (k2, v2) = Int.equal k1 k2 && V.equal v1 v2 - let compare_bindings (k1, v1) (k2, v2) = - match Int.compare k1 k2 with 0 -> V.compare v1 v2 | c -> c - let find_opt_vs_find k m = Map.find_opt k m =? option_of_not_found (Map.find k) m @@ -528,7 +523,7 @@ module Map_specs (V : Value) = struct let to_seq_vs_bindings m = List.equal equal_bindings - (m |> Map.to_seq |> List.of_seq |> List.sort compare_bindings) + (m |> Map.to_seq |> List.of_seq) (m |> Map.bindings) let of_list_valid l = Map.valid (Map.of_list l) @@ -536,7 +531,7 @@ module Map_specs (V : Value) = struct module Equality_on_bindings = struct let sort_by_key l = List.sort (fun (k1, _) (k2, _) -> Int.compare k1 k2) l - let sort_and_group_by_key l = + let group_by_key l = let rec groups l = match l with | [] -> [] @@ -552,11 +547,11 @@ module Map_specs (V : Value) = struct let g, l = group l in (k, v :: g) :: groups l in - groups (sort_by_key l) + groups l let same_bindings_up_to_duplicate_keys l1 l2 = - let l1 = l1 |> sort_and_group_by_key in - let l2 = l2 |> sort_and_group_by_key in + let l1 = l1 |> group_by_key in + let l2 = l2 |> group_by_key in let rec check l1 l2 = match l1, l2 with | [], [] -> true @@ -572,7 +567,9 @@ module Map_specs (V : Value) = struct open Equality_on_bindings let of_list_then_bindings l = - same_bindings_up_to_duplicate_keys (l |> Map.of_list |> Map.bindings) l + same_bindings_up_to_duplicate_keys + (l |> Map.of_list |> Map.bindings) + (sort_by_key l) let bindings_then_of_list m = Map.equal V.equal (m |> Map.bindings |> Map.of_list) m @@ -584,7 +581,7 @@ module Map_specs (V : Value) = struct let map_keys f m = same_bindings_up_to_duplicate_keys (Map.map_keys f m |> Map.bindings) - (List.map (fun (k, v) -> f k, v) (m |> Map.bindings)) + (sort_by_key (List.map (fun (k, v) -> f k, v) (m |> Map.bindings))) let keys_vs_of_list m = Set.equal (Map.keys m) (m |> Map.bindings |> List.map fst |> Set.of_list) @@ -760,7 +757,8 @@ module Types = struct let generate_key = Generator.choose [ 1, Generator.one_of [0; 1; 2; 3; -1; Int.min_int; Int.max_int]; - 2, Generator.log_int ] + 1, Generator.log_int; + 1, Generator.map Generator.log_int ~f:( ~- ) ] let drop_leading_digits key : key Seq.t = let rec next mask : key Seq.node = diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 9b826d1b558..5d0d7aaa20e 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -961,6 +961,12 @@ let unary_primitive env res dbg f arg = | Immediate -> Immediate in None, res, C.atomic_load ~dbg imm_or_ptr arg + | Peek kind -> + let memory_chunk = + K.Standard_int_or_float.to_kind_with_subkind kind + |> C.memory_chunk_of_kind + in + None, res, C.load ~dbg memory_chunk Mutable ~addr:arg let binary_primitive env dbg f x y = match (f : P.binary_primitive) with @@ -985,8 +991,26 @@ let binary_primitive env dbg f x y = | Float_comp (width, Yielding_int_like_compare_functions ()) -> binary_float_comp_primitive_yielding_int env dbg width x y | Bigarray_get_alignment align -> C.bigstring_get_alignment x y align dbg - | Atomic_exchange -> C.atomic_exchange ~dbg x y - | Atomic_fetch_and_add -> C.atomic_fetch_and_add ~dbg x y + | Atomic_exchange block_access_kind -> + let imm_or_ptr : Lambda.immediate_or_pointer = + match block_access_kind with + | Any_value -> Pointer + | Immediate -> Immediate + in + C.atomic_exchange ~dbg imm_or_ptr x ~new_value:y + | Atomic_int_arith Fetch_add -> C.atomic_fetch_and_add ~dbg x y + | Atomic_int_arith Add -> C.atomic_add ~dbg x y + | Atomic_int_arith Sub -> C.atomic_sub ~dbg x y + | Atomic_int_arith And -> C.atomic_land ~dbg x y + | Atomic_int_arith Or -> C.atomic_lor ~dbg x y + | Atomic_int_arith Xor -> C.atomic_lxor ~dbg x y + | Poke kind -> + let memory_chunk = + K.Standard_int_or_float.to_kind_with_subkind kind + |> C.memory_chunk_of_kind + in + C.store ~dbg memory_chunk Assignment ~addr:x ~new_value:y + |> C.return_unit dbg let ternary_primitive _env dbg f x y z = match (f : P.ternary_primitive) with @@ -996,10 +1020,20 @@ let ternary_primitive _env dbg f x y z = bytes_or_bigstring_set ~dbg kind width ~bytes:x ~index:y ~new_value:z | Bigarray_set (_dimensions, kind, _layout) -> bigarray_store ~dbg kind ~bigarray:x ~index:y ~new_value:z - | Atomic_compare_and_set -> - C.atomic_compare_and_set ~dbg x ~old_value:y ~new_value:z - | Atomic_compare_exchange -> - C.atomic_compare_exchange ~dbg x ~old_value:y ~new_value:z + | Atomic_compare_and_set block_access_kind -> + let imm_or_ptr : Lambda.immediate_or_pointer = + match block_access_kind with + | Any_value -> Pointer + | Immediate -> Immediate + in + C.atomic_compare_and_set ~dbg imm_or_ptr x ~old_value:y ~new_value:z + | Atomic_compare_exchange block_access_kind -> + let imm_or_ptr : Lambda.immediate_or_pointer = + match block_access_kind with + | Any_value -> Pointer + | Immediate -> Immediate + in + C.atomic_compare_exchange ~dbg imm_or_ptr x ~old_value:y ~new_value:z let variadic_primitive _env dbg f args = match (f : P.variadic_primitive) with diff --git a/ocamltest/ocamltest_config.ml.in b/ocamltest/ocamltest_config.ml.in index 9a2b9b9bcde..0eb883c1863 100644 --- a/ocamltest/ocamltest_config.ml.in +++ b/ocamltest/ocamltest_config.ml.in @@ -104,6 +104,6 @@ let stack_allocation = @stack_allocation@ let poll_insertion = @poll_insertion@ -let naked_pointers = @naked_pointers@ +let naked_pointers = false let tsan = @tsan@ diff --git a/otherlibs/stdlib_alpha/capsule.ml b/otherlibs/stdlib_alpha/capsule.ml index 73d1bee4777..2e095abcd1a 100644 --- a/otherlibs/stdlib_alpha/capsule.ml +++ b/otherlibs/stdlib_alpha/capsule.ml @@ -12,6 +12,12 @@ (* *) (**************************************************************************) +module Global = struct + type 'a t = { global : 'a @@ global } [@@unboxed] +end + +open Global + (* Like [int Stdlib.Atomic.t], but [portable]. *) module A = struct type t : value mod portable uncontended @@ -29,14 +35,14 @@ end external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool @@ portable = "%equal" module Name : sig - type 'k t : value mod global portable many uncontended unique - type packed = P : 'k t -> packed + type 'k t : value mod external_ global portable many uncontended unique + type packed = P : 'k t -> packed [@@unboxed] val make : unit -> packed @@ portable val equality_witness : 'k1 t -> 'k2 t -> ('k1, 'k2) Type.eq option @@ portable end = struct type 'k t = int - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] let ctr = A.make 0 let make () = P (A.fetch_and_add ctr 1) @@ -50,9 +56,9 @@ end module Access : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t : value mod global portable many unique + type 'k t : value mod external_ global portable many unique - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] (* Can break soundness. *) val unsafe_mk : unit -> 'k t @@ portable @@ -63,7 +69,7 @@ end = struct type 'k t = T : dummy t - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] external unsafe_rebrand : 'k t -> 'j t @@ portable = "%identity" @@ -83,7 +89,9 @@ let initial = Access.unsafe_mk () module Password : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t : value mod portable many unique uncontended + type 'k t : value mod external_ portable many unique uncontended + + type packed = P : 'k t -> packed [@@unboxed] (* Can break the soundness of the API. *) val unsafe_mk : 'k Name.t -> 'k t @@ portable @@ -92,7 +100,7 @@ module Password : sig module Shared : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t + type 'k t : value mod external_ portable many unique uncontended (* Can break the soundness of the API. *) val unsafe_mk : 'k Name.t -> 'k t @@ portable @@ -103,6 +111,8 @@ module Password : sig end = struct type 'k t = 'k Name.t + type packed = P : 'k t -> packed [@@unboxed] + let unsafe_mk name = name let name t = t @@ -120,32 +130,38 @@ end (* Like [Stdlib.raise], but [portable], and the value it never returns is also [portable] *) external reraise : exn -> 'a @ portable @@ portable = "%reraise" - -external raise_with_backtrace : - exn -> Printexc.raw_backtrace -> 'a @ portable @@ portable = "%raise_with_backtrace" +external raise_with_backtrace: exn -> Printexc.raw_backtrace -> 'a @ portable @@ portable = "%raise_with_backtrace" +external get_raw_backtrace: unit -> Printexc.raw_backtrace @@ portable = "caml_get_exception_raw_backtrace" module Data = struct type ('a, 'k) t : value mod portable uncontended exception Encapsulated : 'k Name.t * (exn, 'k) t -> exn - external unsafe_mk : 'a -> ('a, 'k) t @@ portable = "%identity" + external unsafe_mk : ('a[@local_opt]) -> (('a, 'k) t[@local_opt]) @@ portable = "%identity" - external unsafe_get : ('a, 'k) t -> 'a @@ portable = "%identity" + external unsafe_get : (('a, 'k) t[@local_opt]) -> ('a[@local_opt]) @@ portable = "%identity" let wrap _ t = unsafe_mk t + let wrap_local _ t = exclave_ unsafe_mk t let unwrap _ t = unsafe_get t + let unwrap_local _ t = exclave_ unsafe_get t let unwrap_shared _ t = unsafe_get t + let unwrap_shared_local _ t = exclave_ unsafe_get t let create f = unsafe_mk (f ()) + let create_local f = exclave_ unsafe_mk (f ()) + (* CR-soon mslater/tdelvecchio: copying the backtrace at each reraise can cause quadratic + behavior when propagating the exception through nested handlers. This should use a + new reraise-with-current-backtrace primitive that doesn't do the copy. *) let reraise_encapsulated password exn = - reraise (Encapsulated (Password.name password, unsafe_mk exn)) + raise_with_backtrace (Encapsulated (Password.name password, unsafe_mk exn)) (get_raw_backtrace ()) let reraise_encapsulated_shared password exn = - reraise (Encapsulated (Password.Shared.name password, unsafe_mk exn)) + raise_with_backtrace (Encapsulated (Password.Shared.name password, unsafe_mk exn)) (get_raw_backtrace ()) let map pw f t = let v = unsafe_get t in @@ -153,62 +169,112 @@ module Data = struct | res -> unsafe_mk res | exception exn -> reraise_encapsulated pw exn + let map_local pw f t = exclave_ + let v = unsafe_get t in + match f v with + | res -> unsafe_mk res + | exception exn -> reraise_encapsulated pw exn + let fst t = let t1, _ = unsafe_get t in unsafe_mk t1 + let fst_local t = exclave_ + let t1, _ = unsafe_get t in + unsafe_mk t1 + let snd t = let _, t2 = unsafe_get t in unsafe_mk t2 + let snd_local t = exclave_ + let _, t2 = unsafe_get t in + unsafe_mk t2 + let both t1 t2 = unsafe_mk (unsafe_get t1, unsafe_get t2) + let both_local t1 t2 = exclave_ unsafe_mk (unsafe_get t1, unsafe_get t2) let extract pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated pw exn + let extract_local pw f t = exclave_ + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated pw exn + let inject = unsafe_mk + let inject_local = unsafe_mk let project = unsafe_get + let project_local = unsafe_get let bind pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated pw exn + let bind_local pw f t = exclave_ + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated pw exn + let iter pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated pw exn + let iter_local pw f t = + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated pw exn + let map_shared pw f t = let v = unsafe_get t in match f v with | res -> unsafe_mk res | exception exn -> reraise_encapsulated_shared pw exn + let map_shared_local pw f t = exclave_ + let v = unsafe_get t in + match f v with + | res -> unsafe_mk res + | exception exn -> reraise_encapsulated_shared pw exn + + let extract_shared pw f t = let v = unsafe_get t in try f v with | exn -> reraise_encapsulated_shared pw exn + let extract_shared_local pw f t = exclave_ + let v = unsafe_get t in + try f v with + | exn -> reraise_encapsulated_shared pw exn + end exception Encapsulated = Data.Encapsulated -let access (type k) (pw : k Password.t) f = +let access_local (type k) (pw : k Password.t) f = exclave_ let c : k Access.t = Access.unsafe_mk () in match f c with | res -> res | exception exn -> Data.reraise_encapsulated pw exn -let access_shared (type k) (pw : k Password.Shared.t) f = +let access pw f = + (access_local pw (fun access -> { global = f access })).global + +let access_shared_local (type k) (pw : k Password.Shared.t) f = exclave_ let c : k Access.t = Access.unsafe_mk () in match f c with | res -> res | exception exn -> Data.reraise_encapsulated_shared pw exn +let access_shared pw f = + (access_shared_local pw (fun access -> { global = f access })).global + (* Like [Stdlib.Mutex], but [portable]. *) module M = struct type t : value mod portable uncontended @@ -375,16 +441,14 @@ let create_with_rwlock () = let (P name) = Name.make () in Rwlock.P { name; rwlock = Rw.create (); poisoned = false } -exception Protected : 'k Mutex.t * (exn, 'k) Data.t -> exn - -(* CR-soon mslater: replace with portable stdlib *) -let get_raw_backtrace : unit -> Printexc.raw_backtrace @@ portable = - O.magic O.magic Printexc.get_raw_backtrace - -let protect f = - try f () with - | exn -> - let (P mut) = create_with_mutex () in - raise_with_backtrace (Protected (mut, Data.unsafe_mk exn)) (get_raw_backtrace ()) - ;; - +let with_password_local f = exclave_ + let (P name) = Name.make () in + let password = Password.unsafe_mk name in + try f (Password.P password) with + | Encapsulated (inner, data) as exn -> + (match Name.equality_witness name inner with + | Some Equal -> reraise (Data.unsafe_get data) + | None -> reraise exn) + | exn -> reraise exn + +let with_password f = (with_password_local (fun password -> { global = f password })).global diff --git a/otherlibs/stdlib_alpha/capsule.mli b/otherlibs/stdlib_alpha/capsule.mli index 23b61a258c9..31cdfbebf6d 100644 --- a/otherlibs/stdlib_alpha/capsule.mli +++ b/otherlibs/stdlib_alpha/capsule.mli @@ -58,14 +58,14 @@ module Access : sig (* CR layouts v5: this should have layout [void], but [void] can't be used for function argument and return types yet. *) - type 'k t : value mod global portable many unique + type 'k t : value mod external_ global portable many unique (** ['k t] represents access to the current capsule, allowing wraping and unwraping [Data.t] values. An [uncontended] ['k t] indicates that ['k] is the current capsule. A [shared] ['k t] indicates that ['k] is the current capsule but that it may be shared with other domains. *) - type packed = P : 'k t -> packed + type packed = P : 'k t -> packed [@@unboxed] (** [packed] is the type of access to some unknown capsule. Unpacking one provides a ['k t] together with a fresh existential type brand for ['k]. *) @@ -91,9 +91,9 @@ val initial : initial Access.t (** Passwords represent permission to get access to a capsule. *) module Password : sig - (* CR layouts v5: this should have layout [void], but - [void] can't be used for function argument and return types yet. *) - type 'k t : value mod portable many unique uncontended + (* CR layouts v5: this should have layout [void], but + [void] can't be used for function argument and return types yet. *) + type 'k t : value mod external_ portable many unique uncontended (** ['k t] is the type of "passwords" representing permission for the current fiber to have [uncontended] access to the capsule ['k]. They are only ever avilable locally, so that they cannot move @@ -104,13 +104,18 @@ module Password : sig mutex. This guarantees that uncontended access to the capsule is only granted to a single domain at once. *) + type packed = P : 'k t -> packed [@@unboxed] + (** [packed] is the type of a password for some unknown capsule. + Unpacking one provides a ['k t] together with a fresh existential + type brand for ['k]. *) + val name : 'k t @ local -> 'k Name.t @@ portable (** [name t] identifies the capsule that [t] is associated with. *) (** Shared passwords represent permission to get shared access to a capsule *) module Shared : sig - type 'k t + type 'k t : value mod external_ portable many unique uncontended (** ['k t] is the type of "shared passwords" representing permission for the current fiber to have [shared] access to the capsule ['k]. They are only ever avilable locally, so that they cannot @@ -132,21 +137,39 @@ end val access : 'k Password.t @ local -> ('k Access.t -> 'a @ portable contended) @ local portable - -> 'a @ contended + -> 'a @ portable contended @@ portable (** [access p f] runs [f] within the capsule ['k], providing it with an {!Access.t} for ['k]. The result is within ['k] so it must be [portable] and it is marked [contended]. *) +val access_local : + 'k Password.t @ local + -> ('k Access.t -> 'a @ local portable contended) @ local portable + -> 'a @ local portable contended + @@ portable +(** [access_local p f] runs [f] within the capsule ['k], providing it with + an {!Access.t} for ['k]. The result is within ['k] so it must be + [portable] and it is marked [contended]. *) + val access_shared : 'k Password.Shared.t @ local -> ('k Access.t @ shared -> 'a @ portable contended) @ local portable - -> 'a @ contended + -> 'a @ portable contended @@ portable (** [shared_access p f] runs [f] within the capsule ['k], providing it with a shared {!Access.t} for ['k]. The result is within ['k] so it must be [portable] and it is marked [contended]. *) +val access_shared_local : + 'k Password.Shared.t @ local + -> ('k Access.t @ shared -> 'a @ local portable contended) @ local portable + -> 'a @ local portable contended + @@ portable +(** [shared_access_local p f] runs [f] within the capsule ['k], providing it + with a shared {!Access.t} for ['k]. The result is within ['k] so it + must be [portable] and it is marked [contended]. *) + (** Does *not* require runtime5. In runtime4, implemented as a no-op, hence does not provide mutual exclusion between systhreads. *) module Mutex : sig @@ -239,9 +262,9 @@ end (** Requires runtime5. *) module Condition : sig - type 'k t : value mod portable uncontended - (** ['k t] is the type of a condition variable associated with the capsule ['k]. - This condition may only be used with the matching ['k Mutex.t]. *) + type 'k t : value mod portable uncontended + (** ['k t] is the type of a condition variable associated with the capsule ['k]. + This condition may only be used with the matching ['k Mutex.t]. *) val create : unit -> 'k t @@ portable (** [create ()] creates and returns a new condition variable. @@ -282,24 +305,40 @@ module Data : sig type ('a, 'k) t : value mod portable uncontended (** [('a, 'k) t] is the type of ['a]s within the capsule ['k]. It - can be passed between domains. Operations on [('a, 'k) t] - require a ['k Password.t], created from the ['k Mutex.t]. *) + can be passed between domains. Operations on [('a, 'k) t] + require a ['k Password.t], created from the ['k Mutex.t]. *) val wrap : 'k Access.t @ local shared -> 'a -> ('a, 'k) t @@ portable - (** [wrap c v] is a pointer to a value [v] from the current - capsule. *) + (** [wrap c v] is a pointer to a value [v] from the + current capsule. *) + + val wrap_local : + 'k Access.t @ local shared + -> 'a @ local + -> ('a, 'k) t @ local + @@ portable + (** [wrap_local c v] is a pointer to a value [v] from the + current capsule. *) val unwrap : 'k Access.t @ local -> ('a, 'k) t -> 'a @@ portable - (** [unwrap c t] returns the value of [t] which is from the current - capsule. *) + (** [unwrap c t] returns the value of [t] which is from the + current capsule. *) + + val unwrap_local : + 'k Access.t @ local + -> ('a, 'k) t @ local + -> 'a @ local + @@ portable + (** [unwrap_local c t] returns the value of [t] which is from the + current capsule. *) val unwrap_shared : ('a : value mod portable) 'k. @@ -307,15 +346,31 @@ module Data : sig -> ('a, 'k) t -> 'a @ shared @@ portable - (** [unwrap_shared c t] returns the shared value of [t] which is - from the current capsule. *) + (** [unwrap_shared c t] returns the shared value of [t] which is from + the current capsule. *) + + val unwrap_shared_local : + ('a : value mod portable) 'k. + 'k Access.t @ local shared + -> ('a, 'k) t @ local + -> 'a @ local shared + @@ portable + (** [unwrap_shared_local c t] returns the shared value of [t] which is from + the current capsule. *) val create : (unit -> 'a) @ local portable -> ('a, 'k) t @@ portable - (** [create f] runs [f] within the capsule ['k] and creates - a pointer to the result of [f]. *) + (** [create f] runs [f] within the capsule ['k] and creates a pointer to + the result of [f]. *) + + val create_local : + (unit -> 'a @ local) @ local portable + -> ('a, 'k) t @ local + @@ portable + (** [create_local f] runs [f] within the capsule ['k] and creates a pointer to + the result of [f]. *) val map : 'k Password.t @ local @@ -326,6 +381,15 @@ module Data : sig (** [map p f t] applies [f] to the value of [p] within the capsule ['k], creating a pointer to the result. *) + val map_local : + 'k Password.t @ local + -> ('a @ local -> 'b @ local) @ local portable + -> ('a, 'k) t @ local + -> ('b, 'k) t @ local + @@ portable + (** [map_local p f t] applies [f] to the value of [p] within the capsule ['k], + creating a pointer to the result. *) + val both : ('a, 'k) t -> ('b, 'k) t @@ -333,18 +397,37 @@ module Data : sig @@ portable (** [both t1 t2] is a pointer to a pair of the values of [t1] and [t2]. *) + val both_local : + ('a, 'k) t @ local + -> ('b, 'k) t @ local + -> ('a * 'b, 'k) t @ local + @@ portable + (** [both_local t1 t2] is a pointer to a pair of the values of [t1] and [t2]. *) + val fst : ('a * 'b, 'k) t -> ('a, 'k) t @@ portable (** [fst t] gives a pointer to the first value inside [t] *) + val fst_local : + ('a * 'b, 'k) t @ local + -> ('a, 'k) t @ local + @@ portable + (** [fst_local t] gives a pointer to the first value inside [t] *) + val snd : ('a * 'b, 'k) t -> ('b, 'k) t @@ portable (** [snd t] gives a pointer to the second value inside [t] *) + val snd_local : + ('a * 'b, 'k) t @ local + -> ('b, 'k) t @ local + @@ portable + (** [snd_local t] gives a pointer to the second value inside [t] *) + val extract : 'k Password.t @ local -> ('a -> 'b @ portable contended) @ local portable @@ -355,6 +438,16 @@ module Data : sig the capsule ['k] and returns the result. The result is within ['k] so it must be [portable] and it is marked [contended]. *) + val extract_local : + 'k Password.t @ local + -> ('a @ local -> 'b @ local portable contended) @ local portable + -> ('a, 'k) t @ local + -> 'b @ local portable contended + @@ portable + (** [extract_local p f t] applies [f] to the value of [t] within + the capsule ['k] and returns the result. The result is within ['k] + so it must be [portable] and it is marked [contended]. *) + val inject : ('a : value mod uncontended) 'k. 'a @ portable -> ('a, 'k) t @@ -362,6 +455,13 @@ module Data : sig (** [inject v] is a pointer to an immutable value [v] injected into the capsule ['k]. *) + val inject_local : + ('a : value mod uncontended) 'k. + 'a @ local portable -> ('a, 'k) t @ local + @@ portable + (** [inject_local v] is a pointer to an immutable value [v] injected + into the capsule ['k]. *) + val project : ('a : value mod portable) 'k. ('a, 'k) t -> 'a @ contended @@ -369,6 +469,13 @@ module Data : sig (** [project t] returns the value of [t]. The result is within ['k] so it must be [portable] and it is marked [contended]. *) + val project_local : + ('a : value mod portable) 'k. + ('a, 'k) t @ local -> 'a @ local contended + @@ portable + (** [project_local t] returns the value of [t]. The result is within + ['k] so it must be [portable] and it is marked [contended]. *) + val bind : 'k Password.t @ local -> ('a -> ('b, 'j) t) @ local portable @@ -377,6 +484,14 @@ module Data : sig @@ portable (** [bind f t] is [project (map f t)]. *) + val bind_local : + 'k Password.t @ local + -> ('a @ local -> ('b, 'j) t @ local) @ local portable + -> ('a, 'k) t @ local + -> ('b, 'j) t @ local + @@ portable + (** [bind_local f t] is [project_local (map_local f t)]. *) + val iter : 'k Password.t @ local -> ('a -> unit) @ local portable @@ -385,6 +500,14 @@ module Data : sig @@ portable (** [iter] is [extract] with result type specialized to [unit]. *) + val iter_local : + 'k Password.t @ local + -> ('a @ local -> unit) @ local portable + -> ('a, 'k) t @ local + -> unit + @@ portable + (** [iter_local] is [extract_local] with result type specialized to [unit]. *) + val map_shared : ('a : value mod portable) 'b 'k. 'k Password.Shared.t @ local @@ -396,6 +519,17 @@ module Data : sig creating a pointer to the result. Since [nonportable] functions may enclose [uncontended] (and thus write) access to data, ['a] must cross [portability] *) + val map_shared_local : + ('a : value mod portable) 'b 'k. + 'k Password.Shared.t @ local + -> ('a @ local shared -> 'b @ local) @ local portable + -> ('a, 'k) t @ local + -> ('b, 'k) t @ local + @@ portable + (** [map_shared_local p f t] applies [f] to the shared parts of [p] within the capsule ['k], + creating a pointer to the result. Since [nonportable] functions may enclose + [uncontended] (and thus write) access to data, ['a] must cross [portability] *) + val extract_shared : ('a : value mod portable) 'b 'k. 'k Password.Shared.t @ local @@ -403,7 +537,20 @@ module Data : sig -> ('a, 'k) t -> 'b @ portable contended @@ portable - (** [extract p f t] applies [f] to the value of [t] within + (** [extract_shared p f t] applies [f] to the value of [t] within + the capsule ['k] and returns the result. The result is within ['k] + so it must be [portable] and it is marked [contended]. Since [nonportable] + functions may enclose [uncontended] (and thus write) access to data, + ['a] must cross [portability] *) + + val extract_shared_local : + ('a : value mod portable) 'b 'k. + 'k Password.Shared.t @ local + -> ('a @ local shared -> 'b @ local portable contended) @ local portable + -> ('a, 'k) t @ local + -> 'b @ local portable contended + @@ portable + (** [extract_shared_local p f t] applies [f] to the value of [t] within the capsule ['k] and returns the result. The result is within ['k] so it must be [portable] and it is marked [contended]. Since [nonportable] functions may enclose [uncontended] (and thus write) access to data, @@ -416,15 +563,14 @@ exception Encapsulated : 'k Name.t * (exn, 'k) Data.t -> exn the data. The [Name.t] can be used to associate the [Data.t] with a particular [Password.t] or [Mutex.t]. *) -exception Protected : 'k Mutex.t * (exn, 'k) Data.t -> exn -(** If a function passed to [protect] raises an exception, it is wrapped - in [Protected] to provide access to the capsule in which the function ran. *) -(* CR-soon mslater: this should return a key, not a mutex. *) +val with_password : (Password.packed @ local -> 'a) @ local -> 'a @@ portable +(** [with_password f] creates a fresh capsule and applies [f] with the associated [password]. -val protect - : (unit -> 'a @ portable contended) @ local portable - -> 'a @ portable contended - @@ portable -(** [protect f] runs [f] in a fresh capsule. If [f] returns normally, [protect] - merges this capsule into the caller's capsule. If [f] raises, [protect] - raises [Protected], giving the caller access to the encapsulated exception. *) + If [f] raises an [Encapsulated] exception in the capsule represented by [password], + [with_password] destroys the capsule, unwraps the exception, and re-raises it directly. *) + +val with_password_local : (Password.packed @ local -> 'a @ local) @ local -> 'a @ local @@ portable +(** See [with_password]. + + If [f] returns normally, note that the capsule is not destroyed, and locality still enforces + that the password cannot escape. *) diff --git a/otherlibs/systhreads/st_pthreads.h b/otherlibs/systhreads/st_pthreads.h index 95266e98b4b..029437d412e 100644 --- a/otherlibs/systhreads/st_pthreads.h +++ b/otherlibs/systhreads/st_pthreads.h @@ -28,23 +28,16 @@ typedef int st_retcode; -/* Variables used to stop "tick" threads */ -static atomic_uintnat tick_thread_stop[Max_domains]; -#define Tick_thread_stop tick_thread_stop[Caml_state->id] - /* OS-specific initialization */ - static int st_initialize(void) { - atomic_store_release(&Tick_thread_stop, 0); return 0; } -/* Thread creation. Created in detached mode if [res] is NULL. */ - typedef pthread_t st_thread_id; +/* Thread creation. Created in detached mode if [res] is NULL. */ static int st_thread_create(st_thread_id * res, void * (*fn)(void *), void * arg) { @@ -296,16 +289,24 @@ static int st_event_wait(st_event e) return rc; } -/* The tick thread: interrupt the domain periodically to force preemption */ +struct caml_thread_tick_args { + int domain_id; + atomic_uintnat* stop; +}; +/* The tick thread: interrupt the domain periodically to force preemption */ static void * caml_thread_tick(void * arg) { - int *domain_id = (int *) arg; + struct caml_thread_tick_args* tick_thread_args = + (struct caml_thread_tick_args*) arg; + int domain_id = tick_thread_args->domain_id; + atomic_uintnat* stop = tick_thread_args->stop; + caml_stat_free(tick_thread_args); - caml_init_domain_self(*domain_id); + caml_init_domain_self(domain_id); caml_domain_state *domain = Caml_state; - while(! atomic_load_acquire(&Tick_thread_stop)) { + while(! atomic_load_acquire(stop)) { st_msleep(Thread_timeout); atomic_store_release(&domain->requested_external_interrupt, 1); diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index a01d80755ab..aaabdf96ae5 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -44,6 +44,7 @@ #include "caml/printexc.h" #include "caml/roots.h" #include "caml/signals.h" +#include "caml/startup_aux.h" #include "caml/sync.h" #include "caml/sys.h" #include "caml/memprof.h" @@ -162,10 +163,11 @@ struct caml_thread_table { int tick_thread_running; int tick_thread_disabled; st_thread_id tick_thread_id; + atomic_uintnat tick_thread_stop; }; -/* thread_table instance, up to Max_domains */ -static struct caml_thread_table thread_table[Max_domains]; +/* thread_table instance, up to caml_params->max_domains */ +static struct caml_thread_table* thread_table; #define Locking_scheme(dom_id) (thread_table[dom_id].locking_scheme) #define Default_lock(dom_id) (&thread_table[dom_id].default_lock) @@ -199,6 +201,9 @@ static void thread_lock_release(int dom_id) s->unlock(s->context); } +/* Used to signal that the "tick" thread for this domain should be stopped. */ +#define Tick_thread_stop thread_table[Caml_state->id].tick_thread_stop + /* The remaining fields are accessed while holding the domain lock */ /* The descriptor for the currently executing thread for this domain; @@ -648,9 +653,9 @@ static void caml_thread_domain_spawn_hook(void) yet. */ static void caml_thread_domain_initialize_hook(void) { - caml_thread_t new_thread; + atomic_store_release(&Tick_thread_stop, 0); /* OS-specific initialization */ st_initialize(); @@ -717,6 +722,12 @@ CAMLprim value caml_thread_initialize(value unit) caml_failwith("caml_thread_initialize: cannot initialize Thread " "while several domains are running."); + thread_table = caml_stat_calloc_noexc(caml_params->max_domains, + sizeof(struct caml_thread_table)); + if (thread_table == NULL) + caml_fatal_error("caml_thread_initialize: failed to allocate thread" + " table"); + /* Initialize the key to the [caml_thread_t] structure */ st_tls_newkey(&caml_thread_key); @@ -839,8 +850,16 @@ static st_retcode create_tick_thread(void) pthread_sigmask(SIG_BLOCK, &mask, &old_mask); #endif + struct caml_thread_tick_args* tick_thread_args = + caml_stat_alloc_noexc(sizeof(struct caml_thread_tick_args)); + if (tick_thread_args == NULL) + caml_fatal_error("create_tick_thread: failed to allocate thread args"); + + tick_thread_args->domain_id = Caml_state->id; + tick_thread_args->stop = &Tick_thread_stop; + st_retcode err = st_thread_create(&Tick_thread_id, caml_thread_tick, - (void *) &Caml_state->id); + (void *)tick_thread_args); #ifdef POSIX_SIGNALS pthread_sigmask(SIG_SETMASK, &old_mask, NULL); diff --git a/runtime/alloc.c b/runtime/alloc.c index b3456b8bb33..ff3fe0edf8b 100644 --- a/runtime/alloc.c +++ b/runtime/alloc.c @@ -405,6 +405,8 @@ CAMLprim value caml_update_dummy(value dummy, value newval) tag = Tag_val (newval); + CAMLassert (tag != Infix_tag && tag != Closure_tag); + if (Wosize_val(dummy) == 0) { /* Size-0 blocks are statically-allocated atoms. We cannot mutate them, but there is no need: @@ -423,21 +425,6 @@ CAMLprim value caml_update_dummy(value dummy, value newval) for (i = 0; i < size; i++) { Store_double_flat_field (dummy, i, Double_flat_field (newval, i)); } - } else if (tag == Infix_tag) { - value clos = newval - Infix_offset_hd(Hd_val(newval)); - CAMLassert (Tag_val(clos) == Closure_tag); - CAMLassert (Tag_val(dummy) == Infix_tag); - CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval)); - dummy = dummy - Infix_offset_val(dummy); - size = Wosize_val(clos); - CAMLassert (size == Wosize_val(dummy)); - /* It is safe to use [caml_modify] to copy code pointers - from [clos] to [dummy], because the value being overwritten is - an integer, and the new "value" is a pointer outside the minor - heap. */ - for (i = 0; i < size; i++) { - caml_modify (&Field(dummy, i), Field(clos, i)); - } } else { CAMLassert (tag < No_scan_tag); CAMLassert (Tag_val(dummy) != Infix_tag); diff --git a/runtime/array.c b/runtime/array.c index a58b16c1cc7..419645d85db 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -406,6 +406,18 @@ CAMLprim value caml_floatarray_create_local(value len) return caml_alloc_local (wosize, Double_array_tag); } +// Stubs with consistent naming: + +CAMLprim value caml_make_unboxed_float64_vect(value len) +{ + return caml_floatarray_create(len); +} + +CAMLprim value caml_make_local_unboxed_float64_vect(value len) +{ + return caml_floatarray_create_local(len); +} + /* [len] is a [value] representing number of words or floats */ static value make_vect_gen(value len, value init, int local) { @@ -453,7 +465,8 @@ static value make_vect_gen(value len, value init, int local) for (i = 0; i < size; i++) Field(res, i) = init; } } - /* Give the GC a chance to run, and run memprof callbacks */ + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ if (!local) caml_process_pending_actions (); CAMLreturn (res); } @@ -469,6 +482,151 @@ CAMLprim value caml_make_local_vect(value len, value init) return make_vect_gen(len, init, 1); } +CAMLprim value caml_makearray_dynamic_non_scannable_unboxed_product( + value v_num_components, value v_is_local, + value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + // This function is only used for native code. + + CAMLparam0(); + CAMLlocal1(res); + + mlsize_t num_components = Long_val(v_num_components); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + mlsize_t size; + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + // These arrays are always mixed blocks without packing. + // This currently differs from e.g. int32# array, which is allocated as a + // custom block, and is packed. + int reserved = Reserved_mixed_block_scannable_wosize_native(0); + + size = non_unarized_length * num_components; + if (size == 0) { + res = Atom(0); + } else if (num_components < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local_reserved(size, tag, reserved); + } else if (size <= Max_young_wosize) { + res = caml_alloc_small_with_reserved(size, tag, reserved); + } else { + res = caml_alloc_shr_reserved(size, tag, reserved); + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + // CR mshinwell: the other functions which allocate unboxed number arrays + // should also do this + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + +CAMLprim value caml_makearray_dynamic_scannable_unboxed_product( + value v_init, value v_is_local, value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + + CAMLparam1(v_init); + CAMLlocal1(res); + + mlsize_t num_initializers = Wosize_val(v_init); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + + mlsize_t size, i; + + // N.B. [v_init] may be on the local stack! + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + + size = non_unarized_length * num_initializers; + if (size == 0) { + res = Atom(0); + } else if (num_initializers < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else if (size <= Max_young_wosize) { + res = caml_alloc_small(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else { + int move_init_to_major = 0; + for (mlsize_t i = 0; i < num_initializers; i++) { + if (Is_block(Field(v_init, i)) && Is_young(Field(v_init, i))) { + move_init_to_major = 1; + } + } + if (move_init_to_major) { + /* We don't want to create so many major-to-minor references, + so the contents of [v_init] are moved to the major heap by doing + a minor GC. */ + /* CR mslater/mshinwell: Why is this better than adding them to the + remembered set with caml_initialize? See discussion in a + conversation on: + https://github.com/ocaml-flambda/flambda-backend/pull/3317 + */ + CAML_EV_COUNTER (EV_C_FORCE_MINOR_MAKE_VECT, 1); + caml_minor_collection (); + } +#ifdef DEBUG + for (mlsize_t i = 0; i < num_initializers; i++) { + CAMLassert(!(Is_block(Field(v_init, i)) && Is_young(Field(v_init, i)))); + } +#endif + res = caml_alloc_shr(size, tag); + /* We now know that everything in [v_init] is not in the minor heap, so + there is no need to call [caml_initialize]. */ + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + /* [len] is a [value] representing number of floats */ /* [ int -> float array ] */ CAMLprim value caml_make_float_vect(value len) @@ -492,18 +650,34 @@ CAMLprim value caml_make_float_vect(value len) #endif } -CAMLprim value caml_make_unboxed_int32_vect(value len) +static value caml_make_unboxed_int32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int32_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int32_array_wosize) + caml_invalid_argument("Array.make"); /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + struct custom_operations* ops = + &caml_unboxed_int32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 1); } CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) @@ -511,14 +685,28 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int32(0)); } -CAMLprim value caml_make_unboxed_int64_vect(value len) +static value caml_make_unboxed_int64_vect0(value len, int local) { mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int64_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int64_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_int64_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 1); } CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) @@ -526,16 +714,30 @@ CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int64(0)); } -CAMLprim value caml_make_unboxed_nativeint_vect(value len) +static value caml_make_unboxed_nativeint_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_nativeint_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_nativeint_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_nativeint_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 1); } CAMLprim value caml_make_unboxed_nativeint_vect_bytecode(value len) diff --git a/runtime/bigarray.c b/runtime/bigarray.c index 6a3043b6d1b..8296e4e0bde 100644 --- a/runtime/bigarray.c +++ b/runtime/bigarray.c @@ -251,7 +251,7 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) uses_resources = ((flags & CAML_BA_MANAGED_MASK) == CAML_BA_MANAGED) && !(flags & CAML_BA_SUBARRAY); - res = caml_alloc_custom_mem(&caml_ba_ops, asize, uses_resources ? size : 0); + res = caml_alloc_custom_dep(&caml_ba_ops, asize, uses_resources ? size : 0); b = Caml_ba_array_val(res); b->data = data; b->num_dims = num_dims; @@ -291,9 +291,11 @@ CAMLexport void caml_ba_finalize(value v) case CAML_BA_MANAGED: if (b->proxy == NULL) { free(b->data); + caml_free_dependent_memory(v, caml_ba_byte_size(b)); } else { if (caml_atomic_refcount_decr(&b->proxy->refcount) == 1) { free(b->proxy->data); + caml_free_dependent_memory(v, b->proxy->size); free(b->proxy); } } @@ -620,6 +622,7 @@ CAMLexport uintnat caml_ba_deserialize(void * dst) caml_deserialize_error("input_value: size overflow for bigarray"); /* Allocate room for data */ b->data = malloc(size); + caml_alloc_dependent_memory(Custom_val_data (dst), size); if (b->data == NULL) caml_deserialize_error("input_value: out of memory for bigarray"); /* Read data */ @@ -1138,8 +1141,7 @@ static void caml_ba_update_proxy(struct caml_ba_array * b1, caml_atomic_refcount_init(&proxy->refcount, 2); /* initial refcount: 2 = original array + sub array */ proxy->data = b1->data; - proxy->size = - b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0; + proxy->size = caml_ba_byte_size(b1); b1->proxy = proxy; b2->proxy = proxy; } diff --git a/runtime/caml/address_class.h b/runtime/caml/address_class.h index 3ac411cda91..280f13ba1da 100644 --- a/runtime/caml/address_class.h +++ b/runtime/caml/address_class.h @@ -26,7 +26,7 @@ out-of-heap pointers may not point to odd addresses. A valid value is either: - - a tagged integer (Is_long) + - a tagged integer or a null pointer (Is_long) - a pointer to the minor heap - a pointer to a well-formed block outside the minor heap. It may be in the major heap, or static data allocated by the OCaml code or the OCaml diff --git a/runtime/caml/custom.h b/runtime/caml/custom.h index 127d8247abd..fce4cd33cb6 100644 --- a/runtime/caml/custom.h +++ b/runtime/caml/custom.h @@ -59,6 +59,13 @@ CAMLextern value caml_alloc_custom(const struct custom_operations * ops, mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); +// The local version will fail if a finalizer is supplied in the [ops], +// since finalizers on locally-allocated values are not yet supported. +CAMLextern value caml_alloc_custom_local(const struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + /* [caml_alloc_custom_mem] allocates a custom block with dependent memory (memory outside the heap that will be reclaimed when the block is finalized). If [mem] is greater than [custom_minor_max_size] (see gc.mli) @@ -67,6 +74,17 @@ CAMLextern value caml_alloc_custom_mem(const struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem /*memory consumed*/); + /* [caml_alloc_custom_dep] allocates a custom block with dependent memory + (memory outside the heap that will be reclaimed when the block is + finalized). If [mem] is greater than [custom_minor_max_size] (see gc.mli) + the block is allocated directly in the major heap. + The program must call [caml_free_dependent_memory] when the memory is + reclaimed. + */ +CAMLextern value caml_alloc_custom_dep(const struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem /*dep memory in bytes*/); + CAMLextern void caml_register_custom_operations(const struct custom_operations * ops); diff --git a/runtime/caml/domain.h b/runtime/caml/domain.h index 930359bbdcc..5468fb085f0 100644 --- a/runtime/caml/domain.h +++ b/runtime/caml/domain.h @@ -28,14 +28,16 @@ extern "C" { #include "mlvalues.h" #include "domain_state.h" -/* The runtime currently has a hard limit on the number of domains. - This hard limit may go away in the future. */ #ifdef ARCH_SIXTYFOUR -#define Max_domains 128 +#define Max_domains_def 128 #else -#define Max_domains 16 +#define Max_domains_def 16 #endif +/* Upper limit for the number of domains. Chosen to be arbitrarily large. Used + * for sanity checking [max_domains] value in OCAMLRUNPARAM. */ +#define Max_domains_max 4096 + /* is the minor heap full or an external interrupt has been triggered */ Caml_inline int caml_check_gc_interrupt(caml_domain_state * dom_st) { @@ -86,7 +88,7 @@ CAMLextern void (*caml_domain_initialize_hook)(void); CAMLextern void (*caml_domain_stop_hook)(void); CAMLextern void (*caml_domain_external_interrupt_hook)(void); -CAMLextern void caml_init_domains(uintnat minor_heap_wsz); +CAMLextern void caml_init_domains(uintnat max_domains, uintnat minor_heap_wsz); CAMLextern void caml_init_domain_self(int); CAMLextern uintnat caml_minor_heap_max_wsz; diff --git a/runtime/caml/domain_state.tbl b/runtime/caml/domain_state.tbl index c9f3d025f16..915a9bbb090 100644 --- a/runtime/caml/domain_state.tbl +++ b/runtime/caml/domain_state.tbl @@ -161,12 +161,15 @@ DOMAIN_STATE(struct caml_intern_state*, intern_state) /* These stats represent only the current domain's respective values. */ /* Use the Gc module to get aggregated total program stats. */ /*****************************************************************************/ + DOMAIN_STATE(uintnat, stat_minor_words) DOMAIN_STATE(uintnat, stat_promoted_words) DOMAIN_STATE(uintnat, stat_major_words) DOMAIN_STATE(intnat, stat_forced_major_collections) DOMAIN_STATE(uintnat, stat_blocks_marked) +/*****************************************************************************/ + DOMAIN_STATE(int, inside_stw_handler) /* whether or not a domain is inside of a stop-the-world handler this is used for several debug assertions inside of methods diff --git a/runtime/caml/gc_stats.h b/runtime/caml/gc_stats.h index 4cded2c8bec..8aff709b633 100644 --- a/runtime/caml/gc_stats.h +++ b/runtime/caml/gc_stats.h @@ -83,6 +83,8 @@ void caml_collect_gc_stats_sample_stw(caml_domain_state *domain); current domain but the sampled stats of other domains. */ void caml_compute_gc_stats(struct gc_stats* buf); +void caml_init_gc_stats (uintnat max_domains); + #endif /* CAML_INTERNALS */ #endif /* CAML_GC_STATS_H */ diff --git a/runtime/caml/intext.h b/runtime/caml/intext.h index 7983636bfc9..b2a4523c1b8 100644 --- a/runtime/caml/intext.h +++ b/runtime/caml/intext.h @@ -98,7 +98,9 @@ #define OLD_CODE_CUSTOM 0x12 // no longer supported #define CODE_CUSTOM_LEN 0x18 #define CODE_CUSTOM_FIXED 0x19 -#define CODE_UNBOXED_INT64 0x1a + +#define CODE_UNBOXED_INT64 0x1a // Jane Street extensions +#define CODE_NULL 0x1f #if ARCH_FLOAT_ENDIANNESS == 0x76543210 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG diff --git a/runtime/caml/major_gc.h b/runtime/caml/major_gc.h index 2a5af67d3e5..154640aad9c 100644 --- a/runtime/caml/major_gc.h +++ b/runtime/caml/major_gc.h @@ -48,6 +48,11 @@ void caml_darken_cont(value); void caml_mark_root(value, value*); void caml_mark_roots_stw(int, caml_domain_state**); void caml_finish_major_cycle(int force_compaction); +/* Reset any internal accounting the GC uses to set collection pacing. + * For use at times when we have disturbed the usual pacing, for + * example, after any synchronous major collection. + */ +void caml_reset_major_pacing(void); #ifdef DEBUG int caml_mark_stack_is_empty(void); #endif diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index 7c3359b7e86..6aac82005ab 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -37,11 +37,12 @@ CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); CAMLextern value caml_alloc_shr_noexc(mlsize_t wosize, tag_t); CAMLextern value caml_alloc_shr_reserved (mlsize_t, tag_t, reserved_t); CAMLextern value caml_alloc_local(mlsize_t, tag_t); +CAMLextern value caml_alloc_local_reserved(mlsize_t, tag_t, reserved_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_adjust_minor_gc_speed (mlsize_t, mlsize_t); -CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); -CAMLextern void caml_free_dependent_memory (mlsize_t bsz); +CAMLextern void caml_alloc_dependent_memory (value v, mlsize_t bsz); +CAMLextern void caml_free_dependent_memory (value v, mlsize_t bsz); CAMLextern void caml_modify (volatile value *, value); CAMLextern void caml_modify_local (value obj, intnat i, value val); CAMLextern void caml_initialize (volatile value *, value); diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h index 0c6389ef836..435f9fec9e4 100644 --- a/runtime/caml/misc.h +++ b/runtime/caml/misc.h @@ -534,7 +534,7 @@ int caml_runtime_warnings_active(void); 00 -> free words in minor heap 01 -> fields of free list blocks in major heap 03 -> heap chunks deallocated by heap shrinking - 04 -> fields deallocated by caml_obj_truncate: obsolete + 04 -> fields deallocated by caml_obj_truncate, which is no longer available 05 -> unused child pointers in large free blocks 10 -> uninitialised fields of minor objects 11 -> uninitialised fields of major objects diff --git a/runtime/caml/mlvalues.h b/runtime/caml/mlvalues.h index 6df439a30bd..3dcd70239b0 100644 --- a/runtime/caml/mlvalues.h +++ b/runtime/caml/mlvalues.h @@ -69,9 +69,63 @@ typedef opcode_t * code_t; #include "domain_state.h" +/* The null pointer value. */ +#define Val_null ((value) 0) + /* Longs vs blocks. */ -#define Is_long(x) (((x) & 1) != 0) -#define Is_block(x) (((x) & 1) == 0) + +#ifdef __x86_64__ +// Specialize the implementation of Is_block and Is_long on x86-64. +// +// Is_block(x) returns 1 if the least significant bit of x is 0, and x != 0. +// Normally, that is translated into 4 assembly instructions. +// +// However, we can use TZCNT to compute Is_block(x) in just one instruction. +// TZCNT counts the number of trailing zeros in x, setting the carry flag +// to 1 if x == 0 and setting the zero flag to 1 if the LSB of x is 1. +// Therefore, Is_block(x) == 1 iff CF == 0 && ZF == 0. +// We discard the output register as unnecessary. +// +// Similarly, after TZCNT, Is_long(x) == 1 iff CF == 1 || ZF == 1. +// +// Unfortunately, we can't port this optimization to ARM, since CTZ +// there does not set any flags. +// +// On platforms prior to Haswell, TZCNT is not available and is silently +// interpreted as BSF, producing undefined results when x == 0. +// We don't have any CPUs with those architectures, so this seems fine. +Caml_inline int Is_block(value x) { + int result; + value never_used; + __asm__ ( + "tzcnt %2, %1" + : "=@cca" (result), "=r" (never_used) + : "r" (x) + : "cc" + ); + return result; +} + +Caml_inline int Is_long(value x) { + int result; + value never_used; + __asm__ ( + "tzcnt %2, %1" + : "=@ccbe" (result), "=r" (never_used) + : "r" (x) + : "cc" + ); + return result; +} +#else +Caml_inline int Is_long(value x) { + return ((x & 1) != 0 || x == 0); +} + +Caml_inline int Is_block(value x) { + return ((x & 1) == 0 && x != 0); +} +#endif /* Conversion macro names are always of the form "to_from". */ /* Example: Val_long as in "Val from long" or "Val of long". */ @@ -443,10 +497,7 @@ CAMLextern value caml_hash_variant(char const * tag); #define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ /* Abstract things. Their contents is not traced by the GC; therefore - they must not contain any [value]. Must have odd number so that - headers with this tag cannot be mistaken for pointers. Previously - used in caml_obj_truncate for a header of the truncated tail of the - object. + they must not contain any [value]. */ #define Abstract_tag 251 #define Data_abstract_val(v) ((void*) Op_val(v)) @@ -527,6 +578,7 @@ CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ See [custom.h] for operations on method suites. */ #define Custom_tag 255 #define Data_custom_val(v) ((void *) (Op_val(v) + 1)) +#define Custom_val_data(d) (Val_op((value *)d - 1)) struct custom_operations; /* defined in [custom.h] */ /* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ diff --git a/runtime/caml/startup_aux.h b/runtime/caml/startup_aux.h index 9e58360eca5..03deb547ebe 100644 --- a/runtime/caml/startup_aux.h +++ b/runtime/caml/startup_aux.h @@ -55,6 +55,7 @@ struct caml_params { uintnat runtime_warnings; uintnat cleanup_on_exit; uintnat event_trace; + uintnat max_domains; }; extern const struct caml_params* const caml_params; diff --git a/runtime/compare.c b/runtime/compare.c index a77917ed200..f00b9c8e1d4 100644 --- a/runtime/compare.c +++ b/runtime/compare.c @@ -142,6 +142,8 @@ static intnat do_compare_val(struct compare_stack* stk, if (v1 == v2 && total) goto next_item; if (Is_long(v1)) { if (v1 == v2) goto next_item; + if (v1 == Val_null) return LESS; /* v1 null < v2 non-null */ + if (v2 == Val_null) return GREATER; /* v1 non-null > v2 null */ if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ @@ -183,7 +185,7 @@ static intnat do_compare_val(struct compare_stack* stk, } default: /*fallthrough*/; } - return GREATER; /* v1 block > v2 long */ + return GREATER; /* v1 block > v2 long or null */ } t1 = Tag_val(v1); t2 = Tag_val(v2); diff --git a/runtime/custom.c b/runtime/custom.c index 80f1191c08f..25113a24072 100644 --- a/runtime/custom.c +++ b/runtime/custom.c @@ -67,14 +67,20 @@ static value alloc_custom_gen (const struct custom_operations * ops, mlsize_t mem, mlsize_t max_major, mlsize_t max_minor, - int minor_ok) + int minor_ok, + int local) { mlsize_t wosize; CAMLparam0(); CAMLlocal1(result); wosize = 1 + (bsz + sizeof(value) - 1) / sizeof(value); - if (wosize <= Max_young_wosize && minor_ok) { + if (local) { + CAMLassert(ops->finalize == NULL); + result = caml_alloc_local(wosize, Custom_tag); + Custom_ops_val(result) = ops; + } + else if (wosize <= Max_young_wosize && minor_ok) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; if (ops->finalize != NULL || mem != 0) { @@ -102,14 +108,35 @@ Caml_inline mlsize_t get_max_minor (void) Bsize_wsize (Caml_state->minor_heap_wsz) / 100 * caml_custom_minor_ratio; } +static value caml_alloc_custom0(const struct custom_operations * ops, + uintnat bsz, + mlsize_t mem, + mlsize_t max, + int local) +{ + mlsize_t max_major = max; + mlsize_t max_minor = max == 0 ? get_max_minor() : max; + return alloc_custom_gen (ops, bsz, mem, max_major, max_minor, 1, local); +} + CAMLexport value caml_alloc_custom(const struct custom_operations * ops, uintnat bsz, mlsize_t mem, mlsize_t max) { - mlsize_t max_major = max; - mlsize_t max_minor = max == 0 ? get_max_minor() : max; - return alloc_custom_gen (ops, bsz, mem, max_major, max_minor, 1); + return caml_alloc_custom0(ops, bsz, mem, max, 0); +} + +CAMLexport value caml_alloc_custom_local(const struct custom_operations * ops, + uintnat bsz, + mlsize_t mem, + mlsize_t max) +{ + if (ops->finalize != NULL) + caml_invalid_argument( + "caml_alloc_custom_local: finalizers not supported"); + + return caml_alloc_custom0(ops, bsz, mem, max, 1); } CAMLexport value caml_alloc_custom_mem(const struct custom_operations * ops, @@ -124,12 +151,20 @@ CAMLexport value caml_alloc_custom_mem(const struct custom_operations * ops, max_minor_single = max_minor * caml_custom_minor_max_bsz / 100; } value v = alloc_custom_gen (ops, bsz, mem, 0, - max_minor, (mem < max_minor_single)); + max_minor, (mem < max_minor_single), 0); size_t mem_words = (mem + sizeof(value) - 1) / sizeof(value); caml_memprof_sample_block(v, mem_words, mem_words, CAML_MEMPROF_SRC_CUSTOM); return v; } +CAMLexport value caml_alloc_custom_dep(const struct custom_operations * ops, + uintnat size, mlsize_t mem) +{ + /* For now, alias caml_alloc_custom_mem, but this implementation + is to be replaced */ + return caml_alloc_custom_mem(ops, size, mem); +} + struct custom_operations_list { const struct custom_operations * ops; struct custom_operations_list * next; diff --git a/runtime/domain.c b/runtime/domain.c index f5a667bce2b..e2380caae27 100644 --- a/runtime/domain.c +++ b/runtime/domain.c @@ -68,6 +68,7 @@ typedef cpuset_t cpu_set_t; #include "caml/shared_heap.h" #include "caml/signals.h" #include "caml/startup.h" +#include "caml/startup_aux.h" #include "caml/sync.h" #include "caml/weak.h" @@ -215,7 +216,7 @@ static struct { int num_domains; caml_plat_barrier barrier; - caml_domain_state* participating[Max_domains]; + caml_domain_state** participating; } stw_request = { CAML_PLAT_BARRIER_INITIALIZER, 0, @@ -225,7 +226,7 @@ static struct { NULL, 0, CAML_PLAT_BARRIER_INITIALIZER, - { 0 }, + NULL }; static caml_plat_mutex all_domains_lock = CAML_PLAT_MUTEX_INITIALIZER; @@ -233,20 +234,18 @@ static caml_plat_cond all_domains_cond = CAML_PLAT_COND_INITIALIZER; static atomic_uintnat /* dom_internal* */ stw_leader = 0; static uintnat stw_requests_suspended = 0; /* protected by all_domains_lock */ static caml_plat_cond requests_suspended_cond = CAML_PLAT_COND_INITIALIZER; -static dom_internal all_domains[Max_domains]; +static dom_internal* all_domains; CAMLexport atomic_uintnat caml_num_domains_running; - - /* size of the virtual memory reservation for the minor heap, per domain */ uintnat caml_minor_heap_max_wsz; /* The amount of memory reserved for all minor heaps of all domains is - Max_domains * caml_minor_heap_max_wsz. Individual domains can allocate - smaller minor heaps, but when a domain calls Gc.set to allocate a bigger minor - heap than this reservation, we perform a new virtual memory reservation based - on the increased minor heap size. + caml_params->max_domains * caml_minor_heap_max_wsz. Individual domains can + allocate smaller minor heaps, but when a domain calls Gc.set to allocate a + bigger minor heap than this reservation, we perform a new virtual memory + reservation based on the increased minor heap size. New domains are created with a minor heap of size caml_params->init_minor_heap_wsz. @@ -261,28 +260,29 @@ CAMLexport uintnat caml_minor_heaps_end; static CAMLthread_local dom_internal* domain_self; /* - * This structure is protected by all_domains_lock - * [0, participating_domains) are all the domains taking part in STW sections - * [participating_domains, Max_domains) are all those domains free to be used + * This structure is protected by all_domains_lock. + * [0, participating_domains) are all the domains taking part in STW sections. + * [participating_domains, caml_params->max_domains) are all those domains free + * to be used. */ static struct { int participating_domains; - dom_internal* domains[Max_domains]; + dom_internal** domains; } stw_domains = { 0, - { 0 } + NULL }; static void add_next_to_stw_domains(void) { - CAMLassert(stw_domains.participating_domains < Max_domains); + CAMLassert(stw_domains.participating_domains < caml_params->max_domains); stw_domains.participating_domains++; #ifdef DEBUG /* Enforce here the invariant for early-exit in [caml_interrupt_all_signal_safe], because the latter must be async-signal-safe and one cannot CAMLassert inside it. */ bool prev_has_interrupt_word = true; - for (int i = 0; i < Max_domains; i++) { + for (int i = 0; i < caml_params->max_domains; i++) { bool has_interrupt_word = all_domains[i].interruptor.interrupt_word != NULL; if (i < stw_domains.participating_domains) CAMLassert(has_interrupt_word); if (!prev_has_interrupt_word) CAMLassert(!has_interrupt_word); @@ -294,7 +294,7 @@ static void add_next_to_stw_domains(void) static void remove_from_stw_domains(dom_internal* dom) { int i; for(i=0; stw_domains.domains[i]!=dom; ++i) { - CAMLassert(imax_domains); } CAMLassert(i < stw_domains.participating_domains); @@ -306,10 +306,10 @@ static void remove_from_stw_domains(dom_internal* dom) { } static dom_internal* next_free_domain(void) { - if (stw_domains.participating_domains == Max_domains) + if (stw_domains.participating_domains == caml_params->max_domains) return NULL; - CAMLassert(stw_domains.participating_domains < Max_domains); + CAMLassert(stw_domains.participating_domains < caml_params->max_domains); return stw_domains.domains[stw_domains.participating_domains]; } @@ -392,7 +392,7 @@ asize_t caml_norm_minor_heap_size (intnat wsize) /* The current minor heap layout is as follows: - A contiguous memory block of size - [caml_minor_heap_max_wsz * Max_domains] + [caml_minor_heap_max_wsz * caml_params->max_domains] is reserved by [caml_init_domains]. The boundaries of this reserved area are stored in the globals [caml_minor_heaps_start] @@ -827,7 +827,7 @@ static void reserve_minor_heaps_from_stw_single(void) { == Bsize_wsize(caml_minor_heap_max_wsz)); minor_heap_max_bsz = (uintnat)Bsize_wsize(caml_minor_heap_max_wsz); - minor_heap_reservation_bsize = minor_heap_max_bsz * Max_domains; + minor_heap_reservation_bsize = minor_heap_max_bsz * caml_params->max_domains; /* reserve memory space for minor heaps */ heaps_base = caml_mem_map(minor_heap_reservation_bsize, 1 /* reserve_only */, "minor reservation"); @@ -840,7 +840,7 @@ static void reserve_minor_heaps_from_stw_single(void) { caml_gc_log("new minor heap reserved from %p to %p", (value*)caml_minor_heaps_start, (value*)caml_minor_heaps_end); - for (int i = 0; i < Max_domains; i++) { + for (int i = 0; i < caml_params->max_domains; i++) { struct dom_internal* dom = &all_domains[i]; uintnat domain_minor_heap_area = caml_minor_heaps_start + @@ -859,7 +859,7 @@ static void unreserve_minor_heaps_from_stw_single(void) { caml_gc_log("unreserve_minor_heaps"); - for (int i = 0; i < Max_domains; i++) { + for (int i = 0; i < caml_params->max_domains; i++) { struct dom_internal* dom = &all_domains[i]; CAMLassert( @@ -881,7 +881,8 @@ static void unreserve_minor_heaps_from_stw_single(void) { } size = caml_minor_heaps_end - caml_minor_heaps_start; - CAMLassert (Bsize_wsize(caml_minor_heap_max_wsz) * Max_domains == size); + CAMLassert (Bsize_wsize(caml_minor_heap_max_wsz) * caml_params->max_domains + == size); caml_mem_unmap((void *) caml_minor_heaps_start, size); } @@ -952,13 +953,29 @@ void caml_update_minor_heap_max(uintnat requested_wsz) { check_minor_heap(); } -void caml_init_domains(uintnat minor_heap_wsz) { +void caml_init_domains(uintnat max_domains, uintnat minor_heap_wsz) +{ int i; + /* Use [caml_stat_calloc_noexc] to zero initialize [all_domains]. */ + all_domains = caml_stat_calloc_noexc(max_domains, sizeof(dom_internal)); + if (all_domains == NULL) + caml_fatal_error("Failed to allocate all_domains"); + + stw_request.participating = + caml_stat_calloc_noexc(max_domains, sizeof(dom_internal*)); + if (stw_request.participating == NULL) + caml_fatal_error("Failed to allocate stw_request.participating"); + + stw_domains.domains = + caml_stat_calloc_noexc(max_domains, sizeof(dom_internal*)); + if (stw_domains.domains == NULL) + caml_fatal_error("Failed to allocate stw_domains.domains"); + reserve_minor_heaps_from_stw_single(); /* stw_single: mutators and domains have not started yet. */ - for (i = 0; i < Max_domains; i++) { + for (i = 0; i < max_domains; i++) { struct dom_internal* dom = &all_domains[i]; stw_domains.domains[i] = dom; @@ -987,7 +1004,7 @@ void caml_init_domains(uintnat minor_heap_wsz) { } void caml_init_domain_self(int domain_id) { - CAMLassert (domain_id >= 0 && domain_id < Max_domains); + CAMLassert (domain_id >= 0 && domain_id < caml_params->max_domains); domain_self = &all_domains[domain_id]; caml_state = domain_self->state; } @@ -1224,10 +1241,6 @@ static void* domain_thread_func(void* v) domain_create(caml_params->init_minor_heap_wsz, p->parent->state); - if (!domain_self) { - caml_fatal_error("Failed to create domain"); - } - /* this domain is now part of the STW participant set */ p->newdom = domain_self; @@ -1668,7 +1681,7 @@ int caml_try_run_on_all_domains_with_spin_work( #ifdef DEBUG { int domains_participating = 0; - for(i=0; imax_domains; i++) { if(all_domains[i].interruptor.running) domains_participating++; } @@ -1755,10 +1768,14 @@ void caml_interrupt_self(void) interrupt_domain_local(Caml_state); } -/* async-signal-safe */ +/* This function is async-signal-safe as [all_domains] and + [caml_params->max_domains] are set before signal handlers are installed and + do not change afterwards. */ void caml_interrupt_all_signal_safe(void) { - for (dom_internal *d = all_domains; d < &all_domains[Max_domains]; d++) { + for (dom_internal *d = all_domains; + d < &all_domains[caml_params->max_domains]; + d++) { /* [all_domains] is an array of values. So we can access [interrupt_word] directly without synchronisation other than with other people who access the same [interrupt_word].*/ @@ -2191,8 +2208,8 @@ CAMLprim value caml_recommended_domain_count(value unused) /* At least one, even if system says zero */ if (n <= 0) n = 1; - else if (n > Max_domains) - n = Max_domains; + else if (n > caml_params->max_domains) + n = caml_params->max_domains; return (Val_long(n)); } diff --git a/runtime/extern.c b/runtime/extern.c index 034e637b053..94b7567fdf1 100644 --- a/runtime/extern.c +++ b/runtime/extern.c @@ -601,6 +601,11 @@ Caml_inline void extern_unboxed_int(struct caml_extern_state* s, intnat n) writecode64(s, CODE_UNBOXED_INT64, n); } +Caml_inline void extern_null(struct caml_extern_state* s) +{ + writecode8(s, CODE_NULL, 0); +} + /* Marshaling references to previously-marshaled blocks */ Caml_inline void extern_shared_reference(struct caml_extern_state* s, @@ -807,7 +812,9 @@ static void extern_rec(struct caml_extern_state* s, value v) sp = s->extern_stack; while(1) { - if (Is_long(v)) { + if (v == Val_null) { + extern_null(s); + } else if (Is_long(v)) { extern_int(s, Long_val(v)); } else { @@ -1371,7 +1378,7 @@ intnat reachable_words_once(struct caml_extern_state *s, * out-of-heap blocks, so we end up counting out-of-heap blocks too. */ while (1) { if (Is_long(v)) { - /* Tagged integers contribute 0 to the size, nothing to do */ + /* Tagged integers or nulls contribute 0 to the size, nothing to do */ } else { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); diff --git a/runtime/fiber.c b/runtime/fiber.c index 9ff5091a6e3..3e7448be6d4 100644 --- a/runtime/fiber.c +++ b/runtime/fiber.c @@ -80,6 +80,19 @@ uintnat caml_get_init_stack_wsize (int thread_stack_wsz) else stack_wsize = caml_max_stack_wsize; + /* If we are requesting a large stack (more than a hugepage), then + we'd like the total allocation size to be a multiple of the huge + page size. However, the stack guard pages, headers, etc. have + some overhead, so we want the requested stack size to be a bit + less than a multiple of the hugepage size */ + if (caml_plat_hugepagesize > 0 + && stack_wsize > Wsize_bsize(caml_plat_hugepagesize)) { + /* round down to multiple of hugepage size */ + stack_wsize &= ~(Wsize_bsize(caml_plat_hugepagesize) - 1); + /* 3 pages is enough to cover the overhead */ + stack_wsize -= 3 * Wsize_bsize(caml_plat_pagesize); + } + return stack_wsize; } @@ -116,13 +129,21 @@ struct stack_info** caml_alloc_stack_cache (void) return stack_cache; } -#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED) -// See [alloc_for_stack], below. -static const size_t stack_extra_size_for_mmap = 2 * 1024 * 1024; -#endif +/* Round up to a power of 2 */ +static uintnat round_up_p2(uintnat x, uintnat p2) +{ + CAMLassert (Is_power_of_2(p2)); + return (x + p2 - 1) & ~(p2 - 1); +} +/* Allocate a stack with at least the specified number of words. + The [handler] field of the result is initialised (so Stack_high(...)) is + well-defined), but other fields are uninitialised */ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize) { + /* Ensure 16-byte alignment of the [struct stack_handler*] (e.g. for arm64) */ + const int stack_alignment = 16; + #ifdef USE_MMAP_MAP_STACK size_t len = sizeof(struct stack_info) + sizeof(value) * wosize + @@ -135,6 +156,12 @@ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize) return NULL; si->size = len; + + si->handler = + (struct stack_handler*) + round_up_p2((uintnat)si + sizeof(struct stack_info) + + sizeof(value) * wosize, stack_alignment); + return si; #else #if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED) @@ -148,47 +175,29 @@ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize) * the invalid address is in the range we protect, and will raise a stack * overflow exception accordingly. */ - size_t bsize = Bsize_wsize(wosize); - - // If we were using this for arm64, another 8 bytes is needed below - // (at a lower address than) the struct stack_handler, to obtain the - // correct alignment. - bsize += sizeof(struct stack_handler) + 8; - - int page_size = getpagesize(); - int num_pages = (bsize + page_size - 1) / page_size; - + size_t page_size = caml_plat_pagesize; + size_t len = Bsize_wsize(wosize); + uintnat trailer_size = round_up_p2(sizeof(struct stack_handler), + stack_alignment); + len += trailer_size; + // We need two more pages for stack_info and guard CAMLassert(sizeof(struct stack_info) <= page_size); - // We need one extra page for the guard, and another for the [stack_info]. - size_t len = (num_pages + 2) * page_size; - - // We add 2Mb to the total size we are going to mmap to ensure that, no - // matter what the alignment of the mmapped region is with respect to a - // 2Mb huge page boundary, the guard page will never be coalesced by the - // transparent huge pages infrastructure into the same 2Mb huge page as the - // next (normal) page below the guard. This should ensure that the - // mprotect of the guard page (which splits huge pages or renders them - // ineligible for later coalescing) does not disturb existing huge page - // assignments. - // We could take the size of the [struct stack_info] away from [extra_size] - // (see diagram below), but this seems like unnecessary complexity. + len += 2 * page_size; + len = caml_mem_round_up_mapping_size(len); // Stack layout (higher addresses are at the top): // // -------------------- // struct stack_handler - // 8 bytes on arm64 - // -------------------- + // -------------------- <- 16-aligned // the stack itself // -------------------- <- page-aligned // guard page // -------------------- <- page-aligned // padding to one page // struct stack_info - // -------------------- <- [block], page-aligned - // 2Mb (= extra_size) - // -------------------- <- [stack], returned from [mmap], page-aligned - char* stack; + // -------------------- <- [stack], page/hugepage-aligned (by caml_mem_map) + struct stack_info* stack; #ifdef __linux__ /* On Linux, record the current TID in the mapping name */ char mapping_name[64]; @@ -197,33 +206,39 @@ Caml_inline struct stack_info* alloc_for_stack (mlsize_t wosize) #else const char* mapping_name = "stack"; #endif - stack = caml_mem_map(len + stack_extra_size_for_mmap, 0, mapping_name); - if (stack == MAP_FAILED) { + stack = caml_mem_map(len, 0, mapping_name); + if (stack == NULL) { return NULL; } // mmap is always expected to return a page-aligned value. CAMLassert((uintnat)stack % page_size == 0); - struct stack_info* block = - (struct stack_info*) (stack + stack_extra_size_for_mmap); - - if (mprotect(Protected_stack_page(block, page_size), page_size, PROT_NONE)) { - caml_mem_unmap(stack, len + stack_extra_size_for_mmap); + if (mprotect(Protected_stack_page(stack, page_size), page_size, PROT_NONE)) { + caml_mem_unmap(stack, len); return NULL; } // Assert that the guard page does not impinge on the actual stack area. - CAMLassert((char*) block + len - (sizeof(struct stack_handler) + 8 + bsize) - >= Protected_stack_page(block, page_size) + page_size); + CAMLassert((char*) stack + len - (trailer_size + Bsize_wsize(wosize)) + >= Protected_stack_page(stack, page_size) + page_size); + + stack->size = len; + stack->handler = (struct stack_handler*)((char*)stack + len - trailer_size); + CAMLassert(((uintnat) stack->handler) % stack_alignment == 0); - block->size = len; - return block; + return stack; #else - size_t len = sizeof(struct stack_info) + + size_t len = sizeof(struct stack_info)+ sizeof(value) * wosize + - 8 /* for alignment to 16-bytes, needed for arm64 */ + + stack_alignment + sizeof(struct stack_handler); - return caml_stat_alloc_noexc(len); + struct stack_info* stack = caml_stat_alloc_noexc(len); + if (stack == NULL) return NULL; + stack->handler = + (struct stack_handler*) + round_up_p2((uintnat)stack + sizeof(struct stack_info) + + sizeof(value) * wosize, stack_alignment); + return stack; #endif /* NATIVE_CODE */ #endif /* USE_MMAP_MAP_STACK */ } @@ -252,7 +267,6 @@ alloc_size_class_stack_noexc(mlsize_t wosize, int cache_bucket, value hval, value hexn, value heff, int64_t id) { struct stack_info* stack; - struct stack_handler* hand; struct stack_info **cache = Caml_state->stack_cache; static_assert(sizeof(struct stack_info) % sizeof(value) == 0, ""); @@ -266,7 +280,6 @@ alloc_size_class_stack_noexc(mlsize_t wosize, int cache_bucket, value hval, cache[cache_bucket] = (struct stack_info*)stack->exception_ptr; CAMLassert(stack->cache_bucket == stack_cache_bucket(wosize)); - hand = stack->handler; } else { /* couldn't get a cached stack, so have to create one */ stack = alloc_for_stack(wosize); @@ -275,14 +288,9 @@ alloc_size_class_stack_noexc(mlsize_t wosize, int cache_bucket, value hval, } stack->cache_bucket = cache_bucket; - - /* Ensure 16-byte alignment because some architectures require it */ - hand = (struct stack_handler*) - (((uintnat)stack + sizeof(struct stack_info) + sizeof(value) * wosize + 15) - & ~((uintnat)15)); - stack->handler = hand; } + struct stack_handler* hand = stack->handler; hand->handle_value = hval; hand->handle_exn = hexn; hand->handle_effect = heff; @@ -927,15 +935,6 @@ void caml_free_stack (struct stack_info* stack) CAMLassert(stack->magic == 42); CAMLassert(cache != NULL); -#ifndef USE_MMAP_MAP_STACK -#if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED) - int page_size = getpagesize(); - mprotect((void *) Protected_stack_page(stack, page_size), - page_size, - PROT_READ | PROT_WRITE); -#endif -#endif - if (stack->cache_bucket != -1) { stack->exception_ptr = (void*)(cache[stack->cache_bucket]); @@ -952,9 +951,7 @@ void caml_free_stack (struct stack_info* stack) munmap(stack, stack->size); #else #if defined(NATIVE_CODE) && !defined(STACK_CHECKS_ENABLED) - // See [alloc_for_stack]. - char* mmap_base = ((char *) stack) - stack_extra_size_for_mmap; - caml_mem_unmap(mmap_base, stack->size + stack_extra_size_for_mmap); + caml_mem_unmap(stack, stack->size); #else caml_stat_free(stack); #endif diff --git a/runtime/float32.c b/runtime/float32.c index ca518ecb840..6c4cce4cc7a 100644 --- a/runtime/float32.c +++ b/runtime/float32.c @@ -853,7 +853,7 @@ CAMLexport const struct custom_operations caml_unboxed_float32_array_ops[2] = { custom_fixed_length_default }, }; -CAMLprim value caml_make_unboxed_float32_vect(value len) +static value caml_make_unboxed_float32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ @@ -863,8 +863,23 @@ CAMLprim value caml_make_unboxed_float32_vect(value len) /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + const struct custom_operations* ops = + &caml_unboxed_float32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 1); } CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) diff --git a/runtime/gc_ctrl.c b/runtime/gc_ctrl.c index 87f4d7cb8ac..34eb6d70fc8 100644 --- a/runtime/gc_ctrl.c +++ b/runtime/gc_ctrl.c @@ -20,6 +20,7 @@ #include "caml/finalise.h" #include "caml/gc.h" #include "caml/gc_ctrl.h" +#include "caml/gc_stats.h" #include "caml/major_gc.h" #include "caml/minor_gc.h" #include "caml/shared_heap.h" @@ -53,6 +54,7 @@ extern uintnat caml_minor_heap_max_wsz; /* see domain.c */ extern uintnat caml_custom_work_max_multiplier; /* see major_gc.c */ extern uintnat caml_prelinking_in_use; /* see startup_nat.c */ extern uintnat caml_compact_unmap; /* see shared_heap.c */ +extern uintnat caml_pool_min_chunk_bsz; /* see shared_heap.c */ CAMLprim value caml_gc_quick_stat(value v) { @@ -252,6 +254,7 @@ static value gc_major_exn(int force_compaction) caml_gc_log ("Major GC cycle requested"); caml_empty_minor_heaps_once(); caml_finish_major_cycle(force_compaction); + caml_reset_major_pacing(); value exn = caml_process_pending_actions_exn(); CAML_EV_END(EV_EXPLICIT_GC_MAJOR); return exn; @@ -274,6 +277,7 @@ static value gc_full_major_exn(void) currently-unreachable object to be collected. */ for (i = 0; i < 3; i++) { caml_finish_major_cycle(0); + caml_reset_major_pacing(); exn = caml_process_pending_actions_exn(); if (Is_exception_result(exn)) break; } @@ -310,6 +314,7 @@ CAMLprim value caml_gc_compaction(value v) why this needs three iterations. */ for (i = 0; i < 3; i++) { caml_finish_major_cycle(i == 2); + caml_reset_major_pacing(); exn = caml_process_pending_actions_exn(); if (Is_exception_result(exn)) break; } @@ -358,7 +363,10 @@ void caml_init_gc (void) #ifdef NATIVE_CODE caml_init_frame_descriptors(); #endif - caml_init_domains(caml_params->init_minor_heap_wsz); + caml_init_domains(caml_params->max_domains, + caml_params->init_minor_heap_wsz); + caml_init_gc_stats(caml_params->max_domains); + /* caml_major_heap_increment = major_incr; caml_percent_free = norm_pfree (percent_fr); @@ -402,16 +410,6 @@ CAMLprim value caml_runtime_variant (value unit) extern int caml_parser_trace; -CAMLprim value caml_runtime_parameters (value unit) -{ -#define F_Z ARCH_INTNAT_PRINTF_FORMAT -#define F_S ARCH_SIZET_PRINTF_FORMAT - - CAMLassert (unit == Val_unit); - /* TODO KC */ - return caml_alloc_sprintf ("caml_runtime_parameters not implemented: %d", 0); -} - /* Control runtime warnings */ CAMLprim value caml_ml_enable_runtime_warnings(value vbool) @@ -435,6 +433,7 @@ static struct gc_tweak gc_tweaks[] = { { "custom_work_max_multiplier", &caml_custom_work_max_multiplier, 0 }, { "prelinking_in_use", &caml_prelinking_in_use, 0 }, { "compact_unmap", &caml_compact_unmap, 0 }, + { "pool_min_chunk_size", &caml_pool_min_chunk_bsz, 0 }, }; enum {N_GC_TWEAKS = sizeof(gc_tweaks)/sizeof(gc_tweaks[0])}; @@ -499,3 +498,87 @@ CAMLprim value caml_gc_tweak_list_active(value unit) } CAMLreturn(list); } + +#define F_Z ARCH_INTNAT_PRINTF_FORMAT + +/* Return the OCAMLRUNPARAMS form of any GC tweaks. Returns NULL if + * none are set, or if we can't allocate. */ + +char *format_gc_tweaks(void) +{ + size_t len = 0; + for (size_t i = 0; i < N_GC_TWEAKS; i++) { + uintnat val = *gc_tweaks[i].ptr; + if (val != gc_tweaks[i].initial_value) { + len += (2 /* ',X' */ + + strlen(gc_tweaks[i].name)+1 /* 'tweak_name=' */); + do { /* Count digits. We're not in any great hurry. */ + val /= 10; + ++ len; + } while(val); + } + } + if (!len) { /* no gc_tweaks */ + return NULL; + } + ++ len; /* trailing NUL */ + char *buf = malloc(len); + if (!buf) { + goto fail_alloc; + } + char *p = buf; + + for (size_t i = 0; i < N_GC_TWEAKS; i++) { + uintnat val = *gc_tweaks[i].ptr; + if (val != gc_tweaks[i].initial_value) { + int item_len = snprintf(p, len, ",X%s=%"F_Z"u", + gc_tweaks[i].name, val); + if (item_len >= len) { + /* surprise truncation: could be a race; just stop trying. */ + goto fail_truncate; + } + p += item_len; + len -= item_len; + } + } + return buf; + +fail_truncate: + free(buf); +fail_alloc: + return NULL; +} + +CAMLprim value caml_runtime_parameters (value unit) +{ + CAMLassert (unit == Val_unit); + char *tweaks = format_gc_tweaks(); + char *no_tweaks = ""; + value res = caml_alloc_sprintf + ("b=%d,c=%"F_Z"u,e=%"F_Z"u,i=%"F_Z"u,j=%"F_Z"u," + "l=%"F_Z"u,M=%"F_Z"u,m=%"F_Z"u,n=%"F_Z"u," + "o=%"F_Z"u,p=%"F_Z"u,s=%"F_Z"u,t=%"F_Z"u,v=%"F_Z"u,V=%"F_Z"u,W=%"F_Z"u%s", + /* b */ (int) Caml_state->backtrace_active, + /* c */ caml_params->cleanup_on_exit, + /* e */ caml_params->runtime_events_log_wsize, + /* i */ caml_params->init_main_stack_wsz, + /* j */ caml_params->init_thread_stack_wsz, /* check: new ? */ + /* l */ caml_max_stack_wsize, + /* M */ caml_custom_major_ratio, + /* m */ caml_custom_minor_ratio, + /* n */ caml_custom_minor_max_bsz, + /* o */ caml_percent_free, + /* p */ caml_params->parser_trace, + /* R */ /* missing */ + /* s */ caml_minor_heap_max_wsz, + /* t */ caml_params->trace_level, + /* v */ caml_verb_gc, + /* V */ caml_params->verify_heap, + /* W */ caml_runtime_warnings, + /* X */ tweaks ? tweaks : no_tweaks + ); + if (tweaks) { + free(tweaks); + } + return res; +} diff --git a/runtime/gc_stats.c b/runtime/gc_stats.c index fc809305815..5a09bda4664 100644 --- a/runtime/gc_stats.c +++ b/runtime/gc_stats.c @@ -16,9 +16,11 @@ #define CAML_INTERNALS #include "caml/gc_stats.h" +#include "caml/memory.h" #include "caml/minor_gc.h" #include "caml/platform.h" #include "caml/shared_heap.h" +#include "caml/startup_aux.h" Caml_inline intnat intnat_max(intnat a, intnat b) { return (a > b ? a : b); @@ -76,7 +78,6 @@ void caml_reset_domain_alloc_stats(caml_domain_state *local) local->stat_forced_major_collections = 0; } - /* We handle orphaning allocation stats here, whereas orphaning of heap stats is done in shared_heap.c */ static caml_plat_mutex orphan_lock = CAML_PLAT_MUTEX_INITIALIZER; @@ -101,13 +102,20 @@ void caml_orphan_alloc_stats(caml_domain_state *domain) { caml_plat_unlock(&orphan_lock); } - /* The "sampled stats" of a domain are a recent copy of its domain-local stats, accessed without synchronization and only updated ("sampled") during stop-the-world events -- each minor collection, major cycle (which potentially includes compaction), all of these events could happen during domain termination. */ -static struct gc_stats sampled_gc_stats[Max_domains]; +static struct gc_stats* sampled_gc_stats; + +void caml_init_gc_stats (uintnat max_domains) +{ + sampled_gc_stats = + caml_stat_calloc_noexc(max_domains, sizeof(struct gc_stats)); + if (sampled_gc_stats == NULL) + caml_fatal_error("Failed to allocate sampled_gc_stats"); +} /* Update the sampled stats for the given domain during a STW section. */ void caml_collect_gc_stats_sample_stw(caml_domain_state* domain) @@ -154,7 +162,7 @@ void caml_compute_gc_stats(struct gc_stats* buf) pool_max = buf->heap_stats.pool_max_words; large_max = buf->heap_stats.large_max_words; - for (i=0; imax_domains; i++) { /* For allocation stats, we use the live stats of the current domain and the sampled stats of other domains. diff --git a/runtime/instrtrace.c b/runtime/instrtrace.c index 4aeefad9569..77436a222d4 100644 --- a/runtime/instrtrace.c +++ b/runtime/instrtrace.c @@ -124,6 +124,8 @@ caml_trace_value_file (value v, code_t prog, asize_t proglen, FILE * f) && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) fprintf (f, "=code@%ld", (long) ((code_t) v - prog)); + else if (v == Val_null) + fprintf (f, "=null"); else if (Is_long (v)) fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v)); else if (Stack_base(Caml_state->current_stack) <= (value*)v && diff --git a/runtime/intern.c b/runtime/intern.c index ec3ae7adb5f..4db6560e065 100644 --- a/runtime/intern.c +++ b/runtime/intern.c @@ -569,6 +569,10 @@ static void intern_rec(struct caml_intern_state* s, caml_failwith("input_value: CODE_UNBOXED_INT64 not supported on 32 bit"); break; #endif + case CODE_NULL: + read8s(s); + v = Val_null; + break; case CODE_SHARED8: ofs = read8u(s); read_shared: diff --git a/runtime/major_gc.c b/runtime/major_gc.c index 47efa27b147..2e3fe43bdce 100644 --- a/runtime/major_gc.c +++ b/runtime/major_gc.c @@ -635,6 +635,30 @@ static inline intnat diffmod (uintnat x1, uintnat x2) return (intnat) (x1 - x2); } +/* Reset the work and alloc counters to be equal to each other, by + * setting them both equal to the "larger" (in the wrapping-around + * sense we are using here for work_counter and alloc_counter). + * + * For use at times when we have disturbed the major GC from its usual + * pacing and tempo, for example, after any synchronous major + * collection. + */ + +void caml_reset_major_pacing(void) +{ + bool res; + do { + uintnat alloc = atomic_load(&alloc_counter); + uintnat work = atomic_load(&work_counter); + uintnat target = alloc; + if (diffmod(work, alloc) > 0) { + target = work; + } + res = (atomic_compare_exchange_strong(&alloc_counter, &alloc, target) && + atomic_compare_exchange_strong(&work_counter, &work, target)); + } while (!res); +} + static void update_major_slice_work(intnat howmuch, int may_access_gc_phase) { diff --git a/runtime/memory.c b/runtime/memory.c index fade3ec6c55..68a0fabfba5 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -236,19 +236,14 @@ CAMLexport CAMLweakdef void caml_modify (volatile value *fp, value val) free it. In both cases, you pass as argument the size (in bytes) of the block being allocated or freed. */ -CAMLexport void caml_alloc_dependent_memory (mlsize_t nbytes) +CAMLexport void caml_alloc_dependent_memory (value v, mlsize_t nbytes) { - Caml_state->dependent_size += nbytes / sizeof (value); - Caml_state->dependent_allocated += nbytes / sizeof (value); + /* No-op for now */ } -CAMLexport void caml_free_dependent_memory (mlsize_t nbytes) +CAMLexport void caml_free_dependent_memory (value v, mlsize_t nbytes) { - if (Caml_state->dependent_size < nbytes / sizeof (value)){ - Caml_state->dependent_size = 0; - }else{ - Caml_state->dependent_size -= nbytes / sizeof (value); - } + /* No-op for now */ } /* Use this function to tell the major GC to speed up when you use @@ -398,7 +393,7 @@ CAMLprim value caml_atomic_compare_exchange (value ref, value oldv, value newv) } } -CAMLprim value caml_atomic_cas (value ref, value oldv, value newv) +CAMLprim value caml_atomic_compare_set (value ref, value oldv, value newv) { if (caml_atomic_compare_exchange(ref, oldv, newv) == oldv) { return Val_true; @@ -424,6 +419,81 @@ CAMLprim value caml_atomic_fetch_add (value ref, value incr) return ret; } +CAMLprim value caml_atomic_add (value ref, value incr) +{ + if (caml_domain_alone()) { + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) + Long_val(incr)); + /* no write barrier needed, integer write */ + } else { + atomic_value *p = &Op_atomic_val(ref)[0]; + atomic_fetch_add(p, 2*Long_val(incr)); /* ignore the result */ + atomic_thread_fence(memory_order_release); /* generates `dmb ish` on Arm64*/ + } + return Val_unit; +} + +CAMLprim value caml_atomic_sub (value ref, value incr) +{ + if (caml_domain_alone()) { + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) - Long_val(incr)); + /* no write barrier needed, integer write */ + } else { + atomic_value *p = &Op_atomic_val(ref)[0]; + atomic_fetch_sub(p, 2*Long_val(incr)); /* ignore the result */ + atomic_thread_fence(memory_order_release); /* generates `dmb ish` on Arm64*/ + } + return Val_unit; +} + +CAMLprim value caml_atomic_land (value ref, value incr) +{ + if (caml_domain_alone()) { + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) & Long_val(incr)); + /* no write barrier needed, integer write */ + } else { + atomic_value *p = &Op_atomic_val(ref)[0]; + atomic_fetch_and(p, incr); /* ignore the result */ + atomic_thread_fence(memory_order_release); /* generates `dmb ish` on Arm64*/ + } + return Val_unit; +} + +CAMLprim value caml_atomic_lor (value ref, value incr) +{ + if (caml_domain_alone()) { + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) | Long_val(incr)); + /* no write barrier needed, integer write */ + } else { + atomic_value *p = &Op_atomic_val(ref)[0]; + atomic_fetch_or(p, incr); /* ignore the result */ + atomic_thread_fence(memory_order_release); /* generates `dmb ish` on Arm64*/ + } + return Val_unit; +} + +CAMLprim value caml_atomic_lxor (value ref, value incr) +{ + if (caml_domain_alone()) { + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) ^ Long_val(incr)); + /* no write barrier needed, integer write */ + } else { + atomic_value *p = &Op_atomic_val(ref)[0]; + atomic_fetch_xor(p, 2*Long_val(incr)); /* ignore the result */ + atomic_thread_fence(memory_order_release); /* generates `dmb ish` on Arm64*/ + } + return Val_unit; +} + CAMLexport int caml_is_stack (value v) { int i; @@ -531,7 +601,8 @@ void caml_local_realloc(void) CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } -CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, + reserved_t reserved) { #if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; @@ -541,21 +612,26 @@ CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) if (sp < Caml_state->local_limit) caml_local_realloc(); hp = (header_t*)((char*)Caml_state->local_top + sp); - *hp = Make_header(wosize, tag, NOT_MARKABLE); + *hp = Make_header_with_reserved(wosize, tag, NOT_MARKABLE, reserved); return Val_hp(hp); #else if (wosize <= Max_young_wosize) { - return caml_alloc_small(wosize, tag); + return caml_alloc_small_with_reserved(wosize, tag, reserved); } else { /* The return value is initialised directly using Field. This is invalid if it may create major -> minor pointers. So, perform a minor GC to prevent this. (See caml_make_vect) */ caml_minor_collection(); - return caml_alloc_shr(wosize, tag); + return caml_alloc_shr_reserved(wosize, tag, reserved); } #endif } +CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +{ + return caml_alloc_local_reserved(wosize, tag, 0); +} + CAMLprim value caml_local_stack_offset(value blk) { #ifdef NATIVE_CODE diff --git a/runtime/obj.c b/runtime/obj.c index faffb78941d..42fea79a32c 100644 --- a/runtime/obj.c +++ b/runtime/obj.c @@ -36,7 +36,9 @@ static int obj_tag (value arg) { header_t hd; - if (Is_long (arg)) { + if (arg == Val_null) { + return 1010; /* null_tag */ + } else if (Is_long (arg)) { return 1000; /* int_tag */ } else if ((long) arg & (sizeof (value) - 1)) { return 1002; /* unaligned_tag */ @@ -149,31 +151,80 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg) CAMLparam2 (new_tag_v, arg); CAMLlocal1 (res); mlsize_t sz, i; - tag_t tg; + tag_t tag_for_alloc; + uintnat infix_offset = 0; + + tag_t new_tag = (tag_t)Long_val(new_tag_v); + tag_t existing_tag = Tag_val(arg); + + if ((existing_tag == Closure_tag || existing_tag == Infix_tag + || new_tag == Closure_tag || new_tag == Infix_tag) + && existing_tag != new_tag) { + caml_failwith("Cannot change tags of existing closures or create \ + new closures using [caml_obj_with_tag]"); + } + + if (new_tag == Infix_tag) { + // If we received an infix block, we must return the same; but the whole + // Closure_tag block has to be copied. + infix_offset = Infix_offset_val(arg); + arg -= infix_offset; + tag_for_alloc = Closure_tag; + CAMLassert(Tag_val(arg) == tag_for_alloc); + } else { + tag_for_alloc = new_tag; + } sz = Wosize_val(arg); - tg = (tag_t)Long_val(new_tag_v); - if (sz == 0) CAMLreturn (Atom(tg)); - if (tg >= No_scan_tag) { - res = caml_alloc(sz, tg); + if (sz == 0) { + CAMLassert(new_tag != Infix_tag); + CAMLreturn (Atom(tag_for_alloc)); + } + + if (tag_for_alloc >= No_scan_tag) { + res = caml_alloc(sz, tag_for_alloc); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { reserved_t reserved = Reserved_val(arg); - res = caml_alloc_small_with_reserved(sz, tg, reserved); + res = caml_alloc_small_with_reserved(sz, tag_for_alloc, reserved); for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); } else { mlsize_t scannable_sz = Scannable_wosize_val(arg); reserved_t reserved = Reserved_val(arg); - res = caml_alloc_shr_reserved(sz, tg, reserved); - /* It is safe to use [caml_initialize] even if [tag == Closure_tag] - and some of the "values" being copied are actually code pointers. - That's because the new "value" does not point to the minor heap. */ - for (i = 0; i < scannable_sz; i++) { + res = caml_alloc_shr_reserved(sz, tag_for_alloc, reserved); + + CAMLassert(tag_for_alloc != Infix_tag); + if (tag_for_alloc == Closure_tag) { + // The portion prior to the scannable environment may contain code + // pointers, infix tags, infix tagged zero padding and unboxed numbers. + // The latter in particular must not be copied using [caml_initialize], + // as they might satisfy [Is_young]. + + mlsize_t start_of_scannable_env = Start_env_closinfo(Closinfo_val(arg)); + + // There is always at least one function slot in a closure block at + // the moment. + CAMLassert(start_of_scannable_env >= 2); + + // These two can be equal when there is no scannable environment. + CAMLassert(start_of_scannable_env <= scannable_sz); + + for (i = 0; i < start_of_scannable_env; i++) { + Field(res, i) = Field(arg, i); + } + } else { + i = 0; + } + + // Copy scannable values (for closures, this is only the scannable + // environment). + for (; i < scannable_sz; i++) { caml_initialize(&Field(res, i), Field(arg, i)); } - for (i = scannable_sz; i < sz; i++) { + // Copy any non-scannable flat suffix of a mixed block. + for (; i < sz; i++) { Field(res, i) = Field(arg, i); } @@ -181,6 +232,9 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg) caml_process_pending_actions(); } + res += infix_offset; + CAMLassert(infix_offset == 0 || Tag_val(res) == Infix_tag); + CAMLreturn (res); } @@ -346,3 +400,8 @@ CAMLprim value caml_succ_scannable_prefix_len (value v) { } #endif /* NATIVE_CODE */ } + +CAMLprim value caml_is_null(value v) +{ + return v == Val_null ? Val_true : Val_false; +} diff --git a/runtime/runtime_events.c b/runtime/runtime_events.c index 1fcda8c22f2..1a7ca4aaa5d 100644 --- a/runtime/runtime_events.c +++ b/runtime/runtime_events.c @@ -65,22 +65,22 @@ potentially only read the ring when some anomalous event occurs. No coordination is needed with consumers who read the events - they detect races with the producer and discard events when that happens. -The producer code is contained here . By default a .events file is -created in the current directory (overridable by setting -OCAML_RUNTIME_EVENTS_DIR). This file contains a ring buffer for each possible -domain (Max_domains). It is laid out in a structure that enables sparsity. -On-disk (or in-memory) footprint is proportional to the max number of concurrent -domains the process has ever run. +The producer code is contained here . By default a .events file is created +in the current directory (overridable by setting OCAML_RUNTIME_EVENTS_DIR). +This file contains a ring buffer for each possible domain +(caml_params->max_domains). It is laid out in a structure that enables sparsity. +On-disk (or in-memory) footprint is proportional to the max number of +concurrent domains the process has ever run. On disk structure: ---------------------------------------------------------------- | File header (version, offsets, etc..) | ---------------------------------------------------------------- -| Ring 0..Max_domains metadata | +| Ring 0..caml_params->max_domains metadata | | (head and tail indexes, one per cache line) | ---------------------------------------------------------------- -| Ring 0..Max_domains data | +| Ring 0..caml_params->max_domains data | | (actual ring data, default 2^16 words = 512k bytes) | ---------------------------------------------------------------- | Custom event IDs | @@ -261,7 +261,7 @@ static void runtime_events_create_from_stw_single(void) { current_ring_total_size = RUNTIME_EVENTS_MAX_CUSTOM_EVENTS * sizeof(struct runtime_events_custom_event) + - Max_domains * (ring_size_words * sizeof(uint64_t) + + caml_params->max_domains * (ring_size_words * sizeof(uint64_t) + sizeof(struct runtime_events_buffer_header)) + sizeof(struct runtime_events_metadata_header); @@ -335,12 +335,12 @@ static void runtime_events_create_from_stw_single(void) { close(ring_fd); #endif ring_headers_length = - Max_domains * sizeof(struct runtime_events_buffer_header); + caml_params->max_domains * sizeof(struct runtime_events_buffer_header); ring_data_length = - Max_domains * ring_size_words * sizeof(uint64_t); + caml_params->max_domains * ring_size_words * sizeof(uint64_t); current_metadata->version = RUNTIME_EVENTS_VERSION; - current_metadata->max_domains = Max_domains; + current_metadata->max_domains = caml_params->max_domains; current_metadata->ring_header_size_bytes = sizeof(struct runtime_events_buffer_header); current_metadata->ring_size_bytes = @@ -357,9 +357,11 @@ static void runtime_events_create_from_stw_single(void) { current_metadata->data_offset + ring_data_length; - for (int domain_num = 0; domain_num < Max_domains; domain_num++) { + for (int domain_num = 0; domain_num < caml_params->max_domains; + domain_num++) { /* we initialise each ring's metadata. We use the offset to the headers - and then find the slot for each of domain in Max_domains */ + and then find the slot for each of domain in caml_params->max_domains + */ struct runtime_events_buffer_header *ring_buffer = (struct runtime_events_buffer_header *)((char *)current_metadata + diff --git a/runtime/shared_heap.c b/runtime/shared_heap.c index 85c25e5d0a6..6ab849c61ca 100644 --- a/runtime/shared_heap.c +++ b/runtime/shared_heap.c @@ -38,6 +38,7 @@ #include "caml/weak.h" CAMLexport atomic_uintnat caml_compactions_count; +uintnat caml_pool_min_chunk_bsz = 8 * 1024 * 1024; /* 8 MB */ typedef unsigned int sizeclass; @@ -207,7 +208,9 @@ static pool* pool_acquire(struct caml_heap_state* local) { } else { if (pool_freelist.fresh_pools == 0) { uintnat new_pools = pool_freelist.active_pools * 15 / 100; - if (new_pools < 8) new_pools = 8; + uintnat min_new_pools = + Wsize_bsize(caml_pool_min_chunk_bsz) / POOL_WSIZE; + if (new_pools < min_new_pools) new_pools = min_new_pools; uintnat mapping_size = caml_mem_round_up_mapping_size(Bsize_wsize(POOL_WSIZE) * new_pools); diff --git a/runtime/simd.c b/runtime/simd.c index 0e1e6129f26..3188184ef68 100644 --- a/runtime/simd.c +++ b/runtime/simd.c @@ -75,20 +75,37 @@ CAMLprim value caml_unboxed_vec128_vect_blit(value a1, value ofs1, value a2, return Val_unit; } -CAMLprim value caml_make_unboxed_vec128_vect(value len) { - /* This is only used on 64-bit targets. */ - - mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_vec128_array_wosize) caml_invalid_argument("Array.make"); +static value caml_make_unboxed_vec128_vect0(value len, int local) +{ + /* This is only used on 64-bit targets. */ + + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_unboxed_vec128_array_wosize) + caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = num_elements * 2; + + if (local) + return caml_alloc_custom_local(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); +} - /* [num_fields] does not include the custom operations field. */ - mlsize_t num_fields = num_elements * 2; +CAMLprim value caml_make_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 0); +} - return caml_alloc_custom(&caml_unboxed_vec128_array_ops, num_fields * sizeof(value), 0, 0); +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 1); } CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { - caml_failwith("SIMD is not supported in bytecode mode."); + caml_failwith("SIMD is not supported on this platform."); } #else @@ -102,6 +119,10 @@ CAMLprim value caml_make_unboxed_vec128_vect(value len) { caml_failwith("SIMD is not supported on this platform."); } +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) { + caml_failwith("SIMD is not supported on this platform."); +} + CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { caml_failwith("SIMD is not supported on this platform."); } diff --git a/runtime/startup_aux.c b/runtime/startup_aux.c index 687cd5ca645..e0dcee844f5 100644 --- a/runtime/startup_aux.c +++ b/runtime/startup_aux.c @@ -76,6 +76,7 @@ static void init_startup_params(void) params.init_main_stack_wsz = init_main_stack_wsz; params.init_thread_stack_wsz = 0; params.init_max_stack_wsz = Max_stack_def; + params.max_domains = Max_domains_def; params.runtime_events_log_wsize = Default_runtime_events_log_wsize; #ifdef DEBUG @@ -111,19 +112,14 @@ static void scanmult (char_os *opt, uintnat *var) } } -void caml_parse_ocamlrunparam(void) +static void parse_ocamlrunparam(char_os* opt) { - init_startup_params(); - caml_init_gc_tweaks(); - - char_os *opt = caml_secure_getenv (T("OCAMLRUNPARAM")); - if (opt == NULL) opt = caml_secure_getenv (T("CAMLRUNPARAM")); - if (opt != NULL){ while (*opt != '\0'){ switch (*opt++){ case 'b': scanmult (opt, ¶ms.backtrace_enabled); break; case 'c': scanmult (opt, ¶ms.cleanup_on_exit); break; + case 'd': scanmult (opt, ¶ms.max_domains); break; case 'e': scanmult (opt, ¶ms.runtime_events_log_wsize); break; case 'i': scanmult (opt, ¶ms.init_main_stack_wsz); break; case 'j': scanmult (opt, ¶ms.init_thread_stack_wsz); break; @@ -171,8 +167,38 @@ void caml_parse_ocamlrunparam(void) } } } + + /* Validate */ + if (params.max_domains < 1) { + caml_fatal_error("OCAMLRUNPARAM: max_domains(d) must be at least 1"); + } + if (params.max_domains > Max_domains_max) { + caml_fatal_error("OCAMLRUNPARAM: max_domains(d) is too large. " + "The maximum value is %d.", Max_domains_max); + } } +#ifdef NATIVE_CODE +// Any default parameters added to an ocaml executable by passing -ocamlrunparam +// to the compiler. +// See asmcomp/asmlink.ml +extern char caml_ocamlrunparam[]; +#endif + +void caml_parse_ocamlrunparam(void) +{ + init_startup_params(); + caml_init_gc_tweaks(); + + char_os *opt = caml_secure_getenv (T("OCAMLRUNPARAM")); + if (opt == NULL) opt = caml_secure_getenv (T("CAMLRUNPARAM")); + +#ifdef NATIVE_CODE + parse_ocamlrunparam(caml_ocamlrunparam); +#endif + + parse_ocamlrunparam(opt); +} /* The number of outstanding calls to caml_startup */ static int startup_count = 0; diff --git a/runtime4/alloc.c b/runtime4/alloc.c index 1bb9ff2e196..7821c609a4e 100644 --- a/runtime4/alloc.c +++ b/runtime4/alloc.c @@ -67,6 +67,28 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) { return caml_alloc_with_reserved (wosize, tag, 0); } +/* This is used by the native compiler for large block allocations. */ +CAMLexport value caml_alloc_shr_reserved_check_gc (mlsize_t wosize, tag_t tag, + reserved_t reserved) +{ + CAMLassert (tag < Num_tags); + CAMLassert (tag != Infix_tag); + caml_check_urgent_gc (Val_unit); + value result = caml_alloc_shr_reserved (wosize, tag, reserved); + if (tag < No_scan_tag) { + mlsize_t scannable_wosize = Scannable_wosize_val(result); + for (mlsize_t i = 0; i < scannable_wosize; i++) { + Field (result, i) = Val_unit; + } + } + return result; +} + +CAMLexport value caml_alloc_shr_check_gc (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_reserved_check_gc(wosize, tag, 0); +} + #ifdef NATIVE_CODE CAMLexport value caml_alloc_mixed (mlsize_t wosize, tag_t tag, mlsize_t scannable_prefix) { @@ -74,6 +96,14 @@ CAMLexport value caml_alloc_mixed (mlsize_t wosize, tag_t tag, Reserved_mixed_block_scannable_wosize_native(scannable_prefix); return caml_alloc_with_reserved (wosize, tag, reserved); } + +CAMLexport value caml_alloc_mixed_shr_check_gc (mlsize_t wosize, tag_t tag, + mlsize_t scannable_prefix_len) +{ + reserved_t reserved = + Reserved_mixed_block_scannable_wosize_native(scannable_prefix_len); + return caml_alloc_shr_reserved_check_gc(wosize, tag, reserved); +} #endif // NATIVE_CODE CAMLexport value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t tag, @@ -296,6 +326,8 @@ CAMLprim value caml_update_dummy(value dummy, value newval) tag = Tag_val (newval); + CAMLassert (tag != Infix_tag && tag != Closure_tag); + if (tag == Double_array_tag){ CAMLassert (Wosize_val(newval) == Wosize_val(dummy)); CAMLassert (Tag_val(dummy) != Infix_tag); @@ -304,21 +336,6 @@ CAMLprim value caml_update_dummy(value dummy, value newval) for (i = 0; i < size; i++) { Store_double_flat_field (dummy, i, Double_flat_field (newval, i)); } - } else if (tag == Infix_tag) { - value clos = newval - Infix_offset_hd(Hd_val(newval)); - CAMLassert (Tag_val(clos) == Closure_tag); - CAMLassert (Tag_val(dummy) == Infix_tag); - CAMLassert (Infix_offset_val(dummy) == Infix_offset_val(newval)); - dummy = dummy - Infix_offset_val(dummy); - size = Wosize_val(clos); - CAMLassert (size == Wosize_val(dummy)); - /* It is safe to use [caml_modify] to copy code pointers - from [clos] to [dummy], because the value being overwritten is - an integer, and the new "value" is a pointer outside the minor - heap. */ - for (i = 0; i < size; i++) { - caml_modify (&Field(dummy, i), Field(clos, i)); - } } else { CAMLassert (tag < No_scan_tag); CAMLassert (Tag_val(dummy) != Infix_tag); diff --git a/runtime4/array.c b/runtime4/array.c index ae3306028f6..2d2d67e8f09 100644 --- a/runtime4/array.c +++ b/runtime4/array.c @@ -414,6 +414,18 @@ CAMLprim value caml_floatarray_create_local(value len) return caml_alloc_local (wosize, Double_array_tag); } +// Stubs with consistent naming: + +CAMLprim value caml_make_unboxed_float64_vect(value len) +{ + return caml_floatarray_create(len); +} + +CAMLprim value caml_make_local_unboxed_float64_vect(value len) +{ + return caml_floatarray_create_local(len); +} + /* [len] is a [value] representing number of words or floats */ static value make_vect_gen(value len, value init, int local) { @@ -462,12 +474,12 @@ static value make_vect_gen(value len, value init, int local) for (i = 0; i < size; i++) Field(res, i) = init; } } - // Give the GC a chance to run, and run memprof callbacks + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ if (!local) caml_process_pending_actions (); CAMLreturn (res); } - CAMLprim value caml_make_vect(value len, value init) { return make_vect_gen(len, init, 0); @@ -478,6 +490,151 @@ CAMLprim value caml_make_local_vect(value len, value init) return make_vect_gen(len, init, 1); } +CAMLprim value caml_makearray_dynamic_non_scannable_unboxed_product( + value v_num_components, value v_is_local, + value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + // This function is only used for native code. + + CAMLparam0(); + CAMLlocal1(res); + + mlsize_t num_components = Long_val(v_num_components); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + mlsize_t size; + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + // These arrays are always mixed blocks without packing. + // This currently differs from e.g. int32# array, which is allocated as a + // custom block, and is packed. + int reserved = Reserved_mixed_block_scannable_wosize_native(0); + + size = non_unarized_length * num_components; + if (size == 0) { + res = Atom(0); + } else if (num_components < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local_reserved(size, tag, reserved); + } else if (size <= Max_young_wosize) { + res = caml_alloc_small_with_reserved(size, tag, reserved); + } else { + res = caml_alloc_shr_reserved(size, tag, reserved); + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + // CR mshinwell: the other functions which allocate unboxed number arrays + // should also do this + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + +CAMLprim value caml_makearray_dynamic_scannable_unboxed_product( + value v_init, value v_is_local, value v_non_unarized_length) +{ + // Some of this is similar to [caml_make_vect], above. + + CAMLparam1(v_init); + CAMLlocal1(res); + + mlsize_t num_initializers = Wosize_val(v_init); + int is_local = Bool_val(v_is_local); + mlsize_t non_unarized_length = Long_val(v_non_unarized_length); + + mlsize_t size, i; + + // N.B. [v_init] may be on the local stack! + + if (sizeof(uintnat) != sizeof(double)) { + // Just make things easy as regards maximum array lengths for now. + // This should have been caught in [Lambda_to_flambda]. + caml_invalid_argument( + "%makearray_dynamic: only supported on 64-bit targets " + "(this is a compiler bug)"); + } + + int tag = 0; + + size = non_unarized_length * num_initializers; + if (size == 0) { + res = Atom(0); + } else if (num_initializers < 1) { + // This could happen with void layouts. We don't rule it out in + // [Lambda_to_flambda] since it is in fact ok, if the size is zero. + caml_invalid_argument( + "%makearray_dynamic: the only array that can be initialized with " + "nothing is a zero-length array"); + } else if (size > Max_array_wosize) { + caml_invalid_argument( + "%makearray_dynamic: array size too large (> Max_array_wosize)"); + } else if (is_local) { + res = caml_alloc_local(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else if (size <= Max_young_wosize) { + res = caml_alloc_small(size, tag); + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } else { + int move_init_to_major = 0; + for (mlsize_t i = 0; i < num_initializers; i++) { + if (Is_block(Field(v_init, i)) && Is_young(Field(v_init, i))) { + move_init_to_major = 1; + } + } + if (move_init_to_major) { + /* We don't want to create so many major-to-minor references, + so the contents of [v_init] are moved to the major heap by doing + a minor GC. */ + /* CR mslater/mshinwell: Why is this better than adding them to the + remembered set with caml_initialize? See discussion in a + conversation on: + https://github.com/ocaml-flambda/flambda-backend/pull/3317 + */ + CAML_EV_COUNTER (EV_C_FORCE_MINOR_MAKE_VECT, 1); + caml_minor_collection (); + } +#ifdef DEBUG + for (mlsize_t i = 0; i < num_initializers; i++) { + CAMLassert(!(Is_block(Field(v_init, i)) && Is_young(Field(v_init, i)))); + } +#endif + res = caml_alloc_shr(size, tag); + /* We now know that everything in [v_init] is not in the minor heap, so + there is no need to call [caml_initialize]. */ + for (i = 0; i < size; i++) { + Field(res, i) = Field(v_init, i % num_initializers); + } + } + + /* Give the GC a chance to run, and run memprof callbacks. + This matches the semantics of allocations directly from OCaml code. */ + if (!is_local) caml_process_pending_actions (); + + CAMLreturn(res); +} + /* [len] is a [value] representing number of floats */ /* [ int -> float array ] */ CAMLprim value caml_make_float_vect(value len) @@ -494,18 +651,34 @@ CAMLprim value caml_make_float_vect(value len) #endif } -CAMLprim value caml_make_unboxed_int32_vect(value len) +static value caml_make_unboxed_int32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int32_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int32_array_wosize) + caml_invalid_argument("Array.make"); /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_int32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + struct custom_operations* ops = + &caml_unboxed_int32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int32_vect(value len) +{ + return caml_make_unboxed_int32_vect0(len, 1); } CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) @@ -513,14 +686,28 @@ CAMLprim value caml_make_unboxed_int32_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int32(0)); } -CAMLprim value caml_make_unboxed_int64_vect(value len) +static value caml_make_unboxed_int64_vect0(value len, int local) { mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_int64_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_int64_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_int64_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_int64_vect(value len) +{ + return caml_make_unboxed_int64_vect0(len, 1); } CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) @@ -528,16 +715,30 @@ CAMLprim value caml_make_unboxed_int64_vect_bytecode(value len) return caml_make_vect(len, caml_copy_int64(0)); } -CAMLprim value caml_make_unboxed_nativeint_vect(value len) +static value caml_make_unboxed_nativeint_vect0(value len, int local) { /* This is only used on 64-bit targets. */ mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_nativeint_array_wosize) caml_invalid_argument("Array.make"); + if (num_elements > Max_unboxed_nativeint_array_wosize) + caml_invalid_argument("Array.make"); struct custom_operations* ops = &caml_unboxed_nativeint_array_ops; - return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); + if (local) + return caml_alloc_custom_local(ops, num_elements * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_elements * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_nativeint_vect(value len) +{ + return caml_make_unboxed_nativeint_vect0(len, 1); } CAMLprim value caml_make_unboxed_nativeint_vect_bytecode(value len) @@ -963,3 +1164,6 @@ CAMLprim value caml_array_unsafe_set_indexed_by_nativeint(value, value, value); Array_access_index_by(int64, int64_t, Int64_val) Array_access_index_by(int32, int32_t, Int32_val) Array_access_index_by(nativeint, intnat, Nativeint_val) + +// XXX mshinwell: add the %makearray_dynamic prims here for runtime4 +// once the runtime5 versions have been reviewed and tested diff --git a/runtime4/caml/address_class.h b/runtime4/caml/address_class.h index 5a88ba94f41..570c4a8b447 100644 --- a/runtime4/caml/address_class.h +++ b/runtime4/caml/address_class.h @@ -22,7 +22,7 @@ In "classic mode", naked pointers are allowed, and the implementation uses a page table. A valid value is then either: - - a tagged integer (Is_long or !Is_block from mlvalues.h) + - a tagged integer or a null pointer (Is_long or !Is_block from mlvalues.h) - a pointer to the minor heap (Is_young) - a pointer to the major heap (Is_in_heap) - a pointer to a constant block statically-allocated by OCaml code @@ -45,7 +45,7 @@ To support an implementation without a global page table, runtime code should not rely on Is_in_heap and Is_in_static_data. This corresponds to a simpler model where a valid value is either: - - a tagged integer (Is_long) + - a tagged integer or a null pointer (Is_long) - a pointer to the minor heap (Is_young) - a pointer to a well-formed block outside the minor heap (it may be in the major heap, or static, or a foreign pointer, diff --git a/runtime4/caml/alloc.h b/runtime4/caml/alloc.h index 2c243ccd084..6be06f24d7d 100644 --- a/runtime4/caml/alloc.h +++ b/runtime4/caml/alloc.h @@ -37,6 +37,9 @@ CAMLextern value caml_alloc_mixed (mlsize_t wosize, tag_t, CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t); CAMLextern value caml_alloc_small_with_reserved (mlsize_t wosize, tag_t, reserved_t); +CAMLextern value caml_alloc_shr_check_gc (mlsize_t, tag_t); +CAMLextern value caml_alloc_mixed_shr_check_gc (mlsize_t, tag_t, + mlsize_t scannable_wosize); CAMLextern value caml_alloc_tuple (mlsize_t wosize); CAMLextern value caml_alloc_float_array (mlsize_t len); CAMLextern value caml_alloc_string (mlsize_t len); /* len in bytes (chars) */ diff --git a/runtime4/caml/custom.h b/runtime4/caml/custom.h index 62dec5c6302..a141ed005d3 100644 --- a/runtime4/caml/custom.h +++ b/runtime4/caml/custom.h @@ -61,10 +61,28 @@ CAMLextern value caml_alloc_custom(struct custom_operations * ops, mlsize_t mem, /*resources consumed*/ mlsize_t max /*max resources*/); +// The local version will fail if a finalizer is supplied in the [ops], +// since finalizers on locally-allocated values are not yet supported. +CAMLextern value caml_alloc_custom_local(struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + CAMLextern value caml_alloc_custom_mem(struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem /*memory consumed*/); + /* [caml_alloc_custom_dep] allocates a custom block with dependent memory + (memory outside the heap that will be reclaimed when the block is + finalized). If [mem] is greater than [custom_minor_max_size] (see gc.mli) + the block is allocated directly in the major heap. + The program must call [caml_free_dependent_memory] when the memory is + reclaimed. + */ +CAMLextern value caml_alloc_custom_dep(struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem /*dep memory in bytes*/); + CAMLextern void caml_register_custom_operations(struct custom_operations * ops); /* Global variable moved to Caml_state in 4.10 */ diff --git a/runtime4/caml/intext.h b/runtime4/caml/intext.h index 5303627362b..f043386aee2 100644 --- a/runtime4/caml/intext.h +++ b/runtime4/caml/intext.h @@ -80,7 +80,9 @@ #define CODE_CUSTOM 0x12 /* deprecated */ #define CODE_CUSTOM_LEN 0x18 #define CODE_CUSTOM_FIXED 0x19 -#define CODE_UNBOXED_INT64 0x1a + +#define CODE_UNBOXED_INT64 0x1a // Jane Street extensions +#define CODE_NULL 0x1f #if ARCH_FLOAT_ENDIANNESS == 0x76543210 #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG diff --git a/runtime4/caml/m.h.in b/runtime4/caml/m.h.in index 003c4aabb0f..585d38a74ef 100644 --- a/runtime4/caml/m.h.in +++ b/runtime4/caml/m.h.in @@ -84,7 +84,7 @@ #undef WITH_FRAME_POINTERS -#undef NO_NAKED_POINTERS +#define NO_NAKED_POINTERS 1 #undef NAKED_POINTERS_CHECKER diff --git a/runtime4/caml/memory.h b/runtime4/caml/memory.h index e5204f92f96..66e3fe520e4 100644 --- a/runtime4/caml/memory.h +++ b/runtime4/caml/memory.h @@ -55,10 +55,11 @@ CAMLextern value caml_alloc_shr_no_track_noexc (mlsize_t, tag_t); CAMLextern value caml_alloc_shr_for_minor_gc (mlsize_t, tag_t, header_t); CAMLextern value caml_alloc_local(mlsize_t, tag_t); +CAMLextern value caml_alloc_local_reserved(mlsize_t, tag_t, reserved_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); -CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); -CAMLextern void caml_free_dependent_memory (mlsize_t bsz); +CAMLextern void caml_alloc_dependent_memory (value v, mlsize_t bsz); +CAMLextern void caml_free_dependent_memory (value v, mlsize_t bsz); CAMLextern void caml_modify (value *, value); CAMLextern void caml_modify_local (value obj, intnat i, value val); CAMLextern void caml_initialize (value *, value); diff --git a/runtime4/caml/misc.h b/runtime4/caml/misc.h index d8d1009a549..913137d23e6 100644 --- a/runtime4/caml/misc.h +++ b/runtime4/caml/misc.h @@ -461,7 +461,7 @@ int caml_runtime_warnings_active(void); 00 -> free words in minor heap 01 -> fields of free list blocks in major heap 03 -> heap chunks deallocated by heap shrinking - 04 -> fields deallocated by [caml_obj_truncate] + 04 -> fields deallocated by [caml_obj_truncate], which is no longer available 05 -> unused child pointers in large free blocks 10 -> uninitialised fields of minor objects 11 -> uninitialised fields of major objects diff --git a/runtime4/caml/mlvalues.h b/runtime4/caml/mlvalues.h index 8556655f423..3aceb1665dc 100644 --- a/runtime4/caml/mlvalues.h +++ b/runtime4/caml/mlvalues.h @@ -71,9 +71,63 @@ typedef uintnat mark_t; #include "domain_state.h" +/* The null pointer value. */ +#define Val_null ((value) 0) + /* Longs vs blocks. */ -#define Is_long(x) (((x) & 1) != 0) -#define Is_block(x) (((x) & 1) == 0) + +#ifdef __x86_64__ +// Specialize the implementation of Is_block and Is_long on x86-64. +// +// Is_block(x) returns 1 if the least significant bit of x is 0, and x != 0. +// Normally, that is translated into 4 assembly instructions. +// +// However, we can use TZCNT to compute Is_block(x) in just one instruction. +// TZCNT counts the number of trailing zeros in x, setting the carry flag +// to 1 if x == 0 and setting the zero flag to 1 if the LSB of x is 1. +// Therefore, Is_block(x) == 1 iff CF == 0 && ZF == 0. +// We discard the output register as unnecessary. +// +// Similarly, after TZCNT, Is_long(x) == 1 iff CF == 1 || ZF == 1. +// +// Unfortunately, we can't port this optimization to ARM, since CTZ +// there does not set any flags. +// +// On platforms prior to Haswell, TZCNT is not available and is silently +// interpreted as BSF, producing undefined results when x == 0. +// We don't have any CPUs with those architectures, so this seems fine. +Caml_inline int Is_block(value x) { + int result; + value never_used; + __asm__ ( + "tzcnt %2, %1" + : "=@cca" (result), "=r" (never_used) + : "r" (x) + : "cc" + ); + return result; +} + +Caml_inline int Is_long(value x) { + int result; + value never_used; + __asm__ ( + "tzcnt %2, %1" + : "=@ccbe" (result), "=r" (never_used) + : "r" (x) + : "cc" + ); + return result; +} +#else +Caml_inline int Is_long(value x) { + return ((x & 1) != 0 || x == 0); +} + +Caml_inline int Is_block(value x) { + return ((x & 1) == 0 && x != 0); +} +#endif /* Conversion macro names are always of the form "to_from". */ /* Example: Val_long as in "Val from long" or "Val of long". */ @@ -414,8 +468,7 @@ CAMLextern value caml_hash_variant(char const * tag); #define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ /* Abstract things. Their contents is not traced by the GC; therefore they - must not contain any [value]. Must have odd number so that headers with - this tag cannot be mistaken for pointers (see caml_obj_truncate). + must not contain any [value]. */ #define Abstract_tag 251 #define Data_abstract_val(v) ((void*) Op_val(v)) diff --git a/runtime4/compare.c b/runtime4/compare.c index d86a53f9d95..666ca89dd5a 100644 --- a/runtime4/compare.c +++ b/runtime4/compare.c @@ -124,6 +124,8 @@ static intnat do_compare_val(struct compare_stack* stk, if (v1 == v2 && total) goto next_item; if (Is_long(v1)) { if (v1 == v2) goto next_item; + if (v1 == Val_null) return LESS; /* v1 null < v2 non-null */ + if (v2 == Val_null) return GREATER; /* v1 non-null > v2 null */ if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ @@ -166,7 +168,7 @@ static intnat do_compare_val(struct compare_stack* stk, } default: /*fallthrough*/; } - return GREATER; /* v1 block > v2 long */ + return GREATER; /* v1 block > v2 long or null */ } /* If one of the objects is outside the heap (but is not an atom), use address comparison. Since both addresses are 2-aligned, diff --git a/runtime4/custom.c b/runtime4/custom.c index 37d88f48cdc..1ca5ebe2662 100644 --- a/runtime4/custom.c +++ b/runtime4/custom.c @@ -35,7 +35,8 @@ static value alloc_custom_gen (struct custom_operations * ops, mlsize_t mem, mlsize_t max_major, mlsize_t mem_minor, - mlsize_t max_minor) + mlsize_t max_minor, + int local) { mlsize_t wosize; CAMLparam0(); @@ -46,7 +47,12 @@ static value alloc_custom_gen (struct custom_operations * ops, CAMLassert (mem_minor <= mem); wosize = 1 + (bsz + sizeof(value) - 1) / sizeof(value); - if (wosize <= Max_young_wosize) { + if (local) { + CAMLassert(ops->finalize == NULL); + result = caml_alloc_local(wosize, Custom_tag); + Custom_ops_val(result) = ops; + } + else if (wosize <= Max_young_wosize) { result = caml_alloc_small(wosize, Custom_tag); Custom_ops_val(result) = ops; if (ops->finalize != NULL || mem != 0) { @@ -81,7 +87,19 @@ CAMLexport value caml_alloc_custom(struct custom_operations * ops, mlsize_t mem, mlsize_t max) { - return alloc_custom_gen (ops, bsz, mem, max, mem, max); + return alloc_custom_gen (ops, bsz, mem, max, mem, max, 0); +} + +CAMLexport value caml_alloc_custom_local(struct custom_operations * ops, + uintnat bsz, + mlsize_t mem, + mlsize_t max) +{ + if (ops->finalize != NULL) + caml_invalid_argument( + "caml_alloc_custom_local: finalizers not supported"); + + return alloc_custom_gen (ops, bsz, mem, max, mem, max, 1); } CAMLexport value caml_alloc_custom_mem(struct custom_operations * ops, @@ -103,11 +121,18 @@ CAMLexport value caml_alloc_custom_mem(struct custom_operations * ops, Bsize_wsize (Caml_state->stat_heap_wsz) / 150 * caml_custom_major_ratio; mlsize_t max_minor = Bsize_wsize (Caml_state->minor_heap_wsz) / 100 * caml_custom_minor_ratio; - value v = alloc_custom_gen (ops, bsz, mem, max_major, mem_minor, max_minor); + value v = + alloc_custom_gen (ops, bsz, mem, max_major, mem_minor, max_minor, 0); caml_memprof_track_custom(v, mem); return v; } +CAMLexport value caml_alloc_custom_dep(struct custom_operations * ops, + uintnat size, mlsize_t mem) +{ + return caml_alloc_custom_mem(ops, size, mem); +} + struct custom_operations_list { struct custom_operations * ops; struct custom_operations_list * next; diff --git a/runtime4/extern.c b/runtime4/extern.c index 7910d83de20..9b6f81b537f 100644 --- a/runtime4/extern.c +++ b/runtime4/extern.c @@ -525,6 +525,11 @@ Caml_inline void extern_unboxed_int(intnat n) writecode64(CODE_UNBOXED_INT64, n); } +Caml_inline void extern_null(void) +{ + writecode8(CODE_NULL, 0); +} + /* Marshaling references to previously-marshaled blocks */ Caml_inline void extern_shared_reference(uintnat d) @@ -725,7 +730,9 @@ static void extern_rec(value v) sp = extern_stack; while(1) { - if (Is_long(v)) { + if (v == Val_null) { + extern_null(); + } else if (Is_long(v)) { extern_int(Long_val(v)); } else if (! (Is_in_value_area(v))) { @@ -1223,8 +1230,8 @@ intnat reachable_words_once(value root, intnat identifier, value sizes_by_root_i CAMLassert(identifier >= 0); while (1) { - if (Is_long(v)) { - /* Tagged integers contribute 0 to the size, nothing to do */ + if (Is_long(v) || v == Val_null) { + /* Tagged integers or nulls contribute 0 to the size, nothing to do */ } else if (! Is_in_heap_or_young(v)) { /* Out-of-heap blocks contribute 0 to the size, nothing to do */ /* However, in no-naked-pointers mode, we don't distinguish diff --git a/runtime4/float32.c b/runtime4/float32.c index aa046e9e865..5261e191efe 100644 --- a/runtime4/float32.c +++ b/runtime4/float32.c @@ -852,7 +852,7 @@ CAMLexport struct custom_operations caml_unboxed_float32_array_ops[2] = { custom_fixed_length_default }, }; -CAMLprim value caml_make_unboxed_float32_vect(value len) +static value caml_make_unboxed_float32_vect0(value len, int local) { /* This is only used on 64-bit targets. */ @@ -862,8 +862,23 @@ CAMLprim value caml_make_unboxed_float32_vect(value len) /* [num_fields] does not include the custom operations field. */ mlsize_t num_fields = num_elements / 2 + num_elements % 2; - return caml_alloc_custom(&caml_unboxed_float32_array_ops[num_elements % 2], - num_fields * sizeof(value), 0, 0); + struct custom_operations* ops = + &caml_unboxed_float32_array_ops[num_elements % 2]; + + if (local) + return caml_alloc_custom_local(ops, num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(ops, num_fields * sizeof(value), 0, 0); +} + +CAMLprim value caml_make_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 0); +} + +CAMLprim value caml_make_local_unboxed_float32_vect(value len) +{ + return caml_make_unboxed_float32_vect0(len, 1); } CAMLprim value caml_make_unboxed_float32_vect_bytecode(value len) diff --git a/runtime4/instrtrace.c b/runtime4/instrtrace.c index a37c3f97542..f36a0eafc43 100644 --- a/runtime4/instrtrace.c +++ b/runtime4/instrtrace.c @@ -188,6 +188,8 @@ caml_trace_value_file (value v, code_t prog, asize_t proglen, FILE * f) && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) fprintf (f, "=code@%ld", (long) ((code_t) v - prog)); + else if (v == Val_null) + fprintf (f, "=null"); else if (Is_long (v)) fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v)); else if ((void*)v >= (void*)Caml_state->stack_low diff --git a/runtime4/intern.c b/runtime4/intern.c index c8936baa419..94497796cb4 100644 --- a/runtime4/intern.c +++ b/runtime4/intern.c @@ -437,6 +437,10 @@ static void intern_rec(value *dest) caml_failwith("input_value: CODE_UNBOXED_INT64 not supported on 32 bit"); break; #endif + case CODE_NULL: + read8s(); + v = Val_null; + break; case CODE_SHARED8: ofs = read8u(); read_shared: diff --git a/runtime4/major_gc.c b/runtime4/major_gc.c index 5b2e2d8e2c2..3d0a0e1111a 100644 --- a/runtime4/major_gc.c +++ b/runtime4/major_gc.c @@ -614,11 +614,6 @@ Caml_inline void prefetch_block(value v) caml_prefetch(&Field(v, 3)); } -Caml_inline uintnat rotate1(uintnat x) -{ - return (x << ((sizeof x)*8 - 1)) | (x >> 1); -} - Caml_noinline static intnat do_some_marking #ifndef CAML_INSTR (intnat work) @@ -633,11 +628,7 @@ Caml_noinline static intnat do_some_marking /* These global values are cached in locals, so that they can be stored in registers */ struct mark_stack stk = *Caml_state->mark_stack; - uintnat young_start = (uintnat)Val_hp(Caml_state->young_start); - uintnat half_young_len = - ((uintnat)Caml_state->young_end - (uintnat)Caml_state->young_start) >> 1; -#define Is_block_and_not_young(v) \ - (((intnat)rotate1((uintnat)v - young_start)) >= (intnat)half_young_len) +#define Is_block_and_not_young(v) Is_block(v) && !Is_young(v) #ifdef NO_NAKED_POINTERS #define Is_major_block(v) Is_block_and_not_young(v) #else diff --git a/runtime4/memory.c b/runtime4/memory.c index 1d2081d0bfb..711d2d046d4 100644 --- a/runtime4/memory.c +++ b/runtime4/memory.c @@ -587,19 +587,14 @@ CAMLexport value caml_alloc_shr_no_track_noexc (mlsize_t wosize, tag_t tag) free it. In both cases, you pass as argument the size (in bytes) of the block being allocated or freed. */ -CAMLexport void caml_alloc_dependent_memory (mlsize_t nbytes) +CAMLexport void caml_alloc_dependent_memory (value v, mlsize_t nbytes) { - caml_dependent_size += nbytes / sizeof (value); - caml_dependent_allocated += nbytes / sizeof (value); + /* No-op for now */ } -CAMLexport void caml_free_dependent_memory (mlsize_t nbytes) +CAMLexport void caml_free_dependent_memory (value v, mlsize_t nbytes) { - if (caml_dependent_size < nbytes / sizeof (value)){ - caml_dependent_size = 0; - }else{ - caml_dependent_size -= nbytes / sizeof (value); - } + /* No-op for now */ } /* Use this function to tell the major GC to speed up when you use @@ -798,7 +793,8 @@ void caml_local_realloc(void) CAMLassert(Caml_state->local_limit <= Caml_state->local_sp); } -CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +CAMLexport value caml_alloc_local_reserved(mlsize_t wosize, tag_t tag, + reserved_t reserved) { #if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; @@ -808,21 +804,26 @@ CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) if (sp < Caml_state->local_limit) caml_local_realloc(); hp = (header_t*)((char*)Caml_state->local_top + sp); - *hp = Make_header(wosize, tag, Local_unmarked); + *hp = Make_header_with_profinfo(wosize, tag, Local_unmarked, reserved); return Val_hp(hp); #else if (wosize <= Max_young_wosize) { - return caml_alloc_small(wosize, tag); + return caml_alloc_small_with_reserved(wosize, tag, reserved); } else { /* The return value is initialised directly using Field. This is invalid if it may create major -> minor pointers. So, perform a minor GC to prevent this. (See caml_make_vect) */ caml_minor_collection(); - return caml_alloc_shr(wosize, tag); + return caml_alloc_shr_reserved(wosize, tag, reserved); } #endif } +CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) +{ + return caml_alloc_local_reserved(wosize, tag, 0); +} + CAMLprim value caml_local_stack_offset(value blk) { #ifdef NATIVE_CODE diff --git a/runtime4/misc.c b/runtime4/misc.c index 8a60aa2b4f1..c25857335f7 100644 --- a/runtime4/misc.c +++ b/runtime4/misc.c @@ -263,7 +263,7 @@ CAMLprim value caml_atomic_compare_exchange(value ref, value oldv, value newv) } } -CAMLprim value caml_atomic_cas(value ref, value oldv, value newv) +CAMLprim value caml_atomic_compare_set(value ref, value oldv, value newv) { if (caml_atomic_compare_exchange(ref, oldv, newv) == oldv) { return Val_true; @@ -289,6 +289,46 @@ CAMLprim value caml_atomic_fetch_add(value ref, value incr) return ret; } +CAMLprim value caml_atomic_add(value ref, value incr) +{ + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) + Long_val(incr)); + return Val_unit; +} + +CAMLprim value caml_atomic_sub(value ref, value incr) +{ + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) - Long_val(incr)); + return Val_unit; +} + +CAMLprim value caml_atomic_land(value ref, value incr) +{ + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) & Long_val(incr)); + return Val_unit; +} + +CAMLprim value caml_atomic_lor(value ref, value incr) +{ + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) | Long_val(incr)); + return Val_unit; +} + +CAMLprim value caml_atomic_lxor(value ref, value incr) +{ + value* p = Op_val(ref); + CAMLassert(Is_long(*p)); + *p = Val_long(Long_val(*p) ^ Long_val(incr)); + return Val_unit; +} + // Dummy implementations so effect.ml can compile CAMLprim value caml_continuation_use_noexc(void) diff --git a/runtime4/obj.c b/runtime4/obj.c index b67233151ba..c2d41c3d383 100644 --- a/runtime4/obj.c +++ b/runtime4/obj.c @@ -32,7 +32,9 @@ static int obj_tag (value arg) { - if (Is_long (arg)){ + if (arg == Val_null) { + return 1010; /* null_tag */ + } else if (Is_long (arg)) { return 1000; /* int_tag */ }else if ((long) arg & (sizeof (value) - 1)){ return 1002; /* unaligned_tag */ @@ -154,37 +156,90 @@ CAMLprim value caml_obj_with_tag(value new_tag_v, value arg) CAMLparam2 (new_tag_v, arg); CAMLlocal1 (res); mlsize_t sz, i; - tag_t tg; + tag_t tag_for_alloc; + uintnat infix_offset = 0; + + tag_t new_tag = (tag_t)Long_val(new_tag_v); + tag_t existing_tag = Tag_val(arg); + + if ((existing_tag == Closure_tag || existing_tag == Infix_tag + || new_tag == Closure_tag || new_tag == Infix_tag) + && existing_tag != new_tag) { + caml_failwith("Cannot change tags of existing closures or create \ + new closures using [caml_obj_with_tag]"); + } + + if (new_tag == Infix_tag) { + // If we received an infix block, we must return the same; but the whole + // Closure_tag block has to be copied. + infix_offset = Infix_offset_val(arg); + arg -= infix_offset; + tag_for_alloc = Closure_tag; + CAMLassert(Tag_val(arg) == tag_for_alloc); + } else { + tag_for_alloc = new_tag; + } sz = Wosize_val(arg); - tg = (tag_t)Long_val(new_tag_v); - if (sz == 0) CAMLreturn (Atom(tg)); - if (tg >= No_scan_tag) { - res = caml_alloc(sz, tg); + if (sz == 0) { + CAMLassert(new_tag != Infix_tag); + CAMLreturn (Atom(tag_for_alloc)); + } + + if (tag_for_alloc >= No_scan_tag) { + res = caml_alloc(sz, tag_for_alloc); memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); } else if (sz <= Max_young_wosize) { reserved_t reserved = Reserved_val(arg); - res = caml_alloc_small_with_reserved(sz, tg, reserved); + res = caml_alloc_small_with_reserved(sz, tag_for_alloc, reserved); for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); } else { mlsize_t scannable_sz = Scannable_wosize_val(arg); reserved_t reserved = Reserved_val(arg); - res = caml_alloc_shr_reserved(sz, tg, reserved); - /* It is safe to use [caml_initialize] even if [tag == Closure_tag] - and some of the "values" being copied are actually code pointers. - That's because the new "value" does not point to the minor heap. */ - for (i = 0; i < scannable_sz; i++) { + res = caml_alloc_shr_reserved(sz, tag_for_alloc, reserved); + + CAMLassert(tag_for_alloc != Infix_tag); + if (tag_for_alloc == Closure_tag) { + // The portion prior to the scannable environment may contain code + // pointers, infix tags, infix tagged zero padding and unboxed numbers. + // The latter in particular must not be copied using [caml_initialize], + // as they might satisfy [Is_young]. + + mlsize_t start_of_scannable_env = Start_env_closinfo(Closinfo_val(arg)); + + // There is always at least one function slot in a closure block at + // the moment. + CAMLassert(start_of_scannable_env >= 2); + + // These two can be equal when there is no scannable environment. + CAMLassert(start_of_scannable_env <= scannable_sz); + + for (i = 0; i < start_of_scannable_env; i++) { + Field(res, i) = Field(arg, i); + } + } else { + i = 0; + } + + // Copy scannable values (for closures, this is only the scannable + // environment). + for (; i < scannable_sz; i++) { caml_initialize(&Field(res, i), Field(arg, i)); } - for (i = scannable_sz; i < sz; i++) { + // Copy any non-scannable flat suffix of a mixed block. + for (; i < sz; i++) { Field(res, i) = Field(arg, i); } /* Give gc a chance to run, and run memprof callbacks */ caml_process_pending_actions(); } + + res += infix_offset; + CAMLassert(infix_offset == 0 || Tag_val(res) == Infix_tag); + CAMLreturn (res); } @@ -194,69 +249,6 @@ CAMLprim value caml_obj_dup(value arg) return caml_obj_with_tag(Val_long(Tag_val(arg)), arg); } -/* Shorten the given block to the given size and return void. - Raise Invalid_argument if the given size is less than or equal - to 0 or greater than the current size. - - algorithm: - Change the length field of the header. Make up a black object - with the leftover part of the object: this is needed in the major - heap and harmless in the minor heap. The object cannot be white - because there may still be references to it in the ref table. By - using a black object we ensure that the ref table will be emptied - before the block is reallocated (since there must be a minor - collection within each major cycle). - - [newsize] is a value encoding a number of fields (words, except - for float arrays on 32-bit architectures). -*/ -CAMLprim value caml_obj_truncate (value v, value newsize) -{ - mlsize_t new_wosize = Long_val (newsize); - header_t hd = Hd_val (v); - tag_t tag = Tag_hd (hd); - color_t color = Color_hd (hd); - color_t frag_color = Is_young(v) ? 0 : Caml_black; - mlsize_t wosize = Wosize_hd (hd); - mlsize_t i; - - if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#2520 */ - - if (new_wosize <= 0 || new_wosize > wosize){ - caml_invalid_argument ("Obj.truncate"); - } - if (new_wosize == wosize) return Val_unit; - /* PR#2400: since we're about to lose our references to the elements - beyond new_wosize in v, erase them explicitly so that the GC - can darken them as appropriate. */ - if (tag < No_scan_tag) { - mlsize_t scannable_wosize = Scannable_wosize_hd(hd); - for (i = new_wosize; i < scannable_wosize; i++){ - caml_modify(&Field(v, i), Val_unit); -#ifdef DEBUG - Field (v, i) = Debug_free_truncate; -#endif - } -#ifdef DEBUG - /* Unless we're in debug mode, it's not necessary to empty out - the non-scannable suffix, as the GC knows not to look there - anyway. - */ - for (; i < wosize; i++) { - Field (v, i) = Debug_free_truncate; - } -#endif - } - /* We must use an odd tag for the header of the leftovers so it does not - look like a pointer because there may be some references to it in - ref_table. */ - Field (v, new_wosize) = - Make_header (Wosize_whsize (wosize-new_wosize), Abstract_tag, frag_color); - Hd_val (v) = - Make_header_with_profinfo (new_wosize, tag, color, Profinfo_val(v)); - return Val_unit; -} - CAMLprim value caml_obj_add_offset (value v, value offset) { return v + (unsigned long) Int32_val (offset); @@ -381,3 +373,8 @@ CAMLprim value caml_succ_scannable_prefix_len (value v) { } #endif /* NATIVE_CODE */ } + +CAMLprim value caml_is_null(value v) +{ + return v == Val_null ? Val_true : Val_false; +} diff --git a/runtime4/roots_nat.c b/runtime4/roots_nat.c index fefc75ac760..b238588505d 100644 --- a/runtime4/roots_nat.c +++ b/runtime4/roots_nat.c @@ -651,8 +651,7 @@ void caml_do_local_roots_nat(scanning_action maj, scanning_action min, value * regs; frame_descr * d; uintnat h; - int i, j, n, ofs; - unsigned short * p; + int i, j; value * root; struct caml__roots_block *lr; @@ -678,17 +677,21 @@ void caml_do_local_roots_nat(scanning_action maj, scanning_action min, for (p = dl->live_ofs, n = dl->num_live; n > 0; n--, p++) { uint32_t ofs = *p; if (ofs & 1) { - root = regs + (ofs >> 1); + /* Negative offset to scan xmm registers in amd64. */ + root = regs + (((int32_t)ofs) >> 1); } else { root = (value *)(sp + ofs); } visit(maj, min, root); } } else { + unsigned short * p; + unsigned short n; for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { - ofs = *p; + unsigned short ofs = *p; if (ofs & 1) { - root = regs + (ofs >> 1); + /* Negative offset to scan xmm registers in amd64. */ + root = regs + (((signed short)ofs) >> 1); } else { root = (value *)(sp + ofs); } diff --git a/runtime4/simd.c b/runtime4/simd.c index a9ae173772b..48986e06b2b 100644 --- a/runtime4/simd.c +++ b/runtime4/simd.c @@ -73,20 +73,37 @@ CAMLprim value caml_unboxed_vec128_vect_blit(value a1, value ofs1, value a2, return Val_unit; } -CAMLprim value caml_make_unboxed_vec128_vect(value len) { - /* This is only used on 64-bit targets. */ - - mlsize_t num_elements = Long_val(len); - if (num_elements > Max_unboxed_vec128_array_wosize) caml_invalid_argument("Array.make"); +static value caml_make_unboxed_vec128_vect0(value len, int local) +{ + /* This is only used on 64-bit targets. */ + + mlsize_t num_elements = Long_val(len); + if (num_elements > Max_unboxed_vec128_array_wosize) + caml_invalid_argument("Array.make"); + + /* [num_fields] does not include the custom operations field. */ + mlsize_t num_fields = num_elements * 2; + + if (local) + return caml_alloc_custom_local(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); + else + return caml_alloc_custom(&caml_unboxed_vec128_array_ops, + num_fields * sizeof(value), 0, 0); +} - /* [num_fields] does not include the custom operations field. */ - mlsize_t num_fields = num_elements * 2; +CAMLprim value caml_make_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 0); +} - return caml_alloc_custom(&caml_unboxed_vec128_array_ops, num_fields * sizeof(value), 0, 0); +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) +{ + return caml_make_unboxed_vec128_vect0(len, 1); } CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { - caml_failwith("SIMD is not supported in bytecode mode."); + caml_failwith("SIMD is not supported on this platform."); } #else @@ -100,6 +117,10 @@ CAMLprim value caml_make_unboxed_vec128_vect(value len) { caml_failwith("SIMD is not supported on this platform."); } +CAMLprim value caml_make_local_unboxed_vec128_vect(value len) { + caml_failwith("SIMD is not supported on this platform."); +} + CAMLprim value caml_make_unboxed_vec128_vect_bytecode(value len) { caml_failwith("SIMD is not supported on this platform."); } diff --git a/runtime4/startup_aux.c b/runtime4/startup_aux.c index b6a120b5ddb..168976aa626 100644 --- a/runtime4/startup_aux.c +++ b/runtime4/startup_aux.c @@ -100,13 +100,9 @@ static void scanmult (char_os *opt, uintnat *var) } } -void caml_parse_ocamlrunparam(void) +static void parse_ocamlrunparam(char_os* opt) { - char_os *opt = caml_secure_getenv (T("OCAMLRUNPARAM")); uintnat p; - - if (opt == NULL) opt = caml_secure_getenv (T("CAMLRUNPARAM")); - if (opt != NULL){ while (*opt != '\0'){ switch (*opt++){ @@ -138,6 +134,26 @@ void caml_parse_ocamlrunparam(void) } } +#ifdef NATIVE_CODE +// Any default parameters added to an ocaml executable by passing -ocamlrunparam +// to the compiler. +// See asmcomp/asmlink.ml +extern char caml_ocamlrunparam[]; +#endif + +void caml_parse_ocamlrunparam(void) +{ + char_os *opt = caml_secure_getenv (T("OCAMLRUNPARAM")); + + if (opt == NULL) opt = caml_secure_getenv (T("CAMLRUNPARAM")); + +#ifdef NATIVE_CODE + parse_ocamlrunparam(caml_ocamlrunparam); +#endif + + parse_ocamlrunparam(opt); +} + /* The number of outstanding calls to caml_startup */ static int startup_count = 0; diff --git a/stdlib/atomic.ml b/stdlib/atomic.ml index 9a60e2c0b44..73c3f43daee 100644 --- a/stdlib/atomic.ml +++ b/stdlib/atomic.ml @@ -21,9 +21,14 @@ external exchange : 'a t -> 'a -> 'a = "%atomic_exchange" external compare_and_set : 'a t -> 'a -> 'a -> bool = "%atomic_cas" external compare_exchange : 'a t -> 'a -> 'a -> 'a = "%atomic_compare_exchange" external fetch_and_add : int t -> int -> int = "%atomic_fetch_add" +external add : int t -> int -> unit = "%atomic_add" +external sub : int t -> int -> unit = "%atomic_sub" +external logand : int t -> int -> unit = "%atomic_land" +external logor : int t -> int -> unit = "%atomic_lor" +external logxor : int t -> int -> unit = "%atomic_lxor" external ignore : 'a -> unit = "%ignore" let set r x = ignore (exchange r x) -let incr r = ignore (fetch_and_add r 1) -let decr r = ignore (fetch_and_add r (-1)) +let incr r = add r 1 +let decr r = sub r 1 diff --git a/stdlib/atomic.mli b/stdlib/atomic.mli index ef6cab8f7df..5f01c6dd332 100644 --- a/stdlib/atomic.mli +++ b/stdlib/atomic.mli @@ -70,6 +70,21 @@ val compare_exchange : 'a t -> 'a -> 'a -> 'a and returns the current value (before the increment). *) val fetch_and_add : int t -> int -> int +(** [add r i] atomically adds [i] onto [r]. *) +val add : int t -> int -> unit + +(** [sub r i] atomically subtracts [i] onto [r]. *) +val sub : int t -> int -> unit + +(** [logand r i] atomically bitwise-ands [i] onto [r]. *) +val logand : int t -> int -> unit + +(** [logor r i] atomically bitwise-ors [i] onto [r]. *) +val logor : int t -> int -> unit + +(** [logxor r i] atomically bitwise-xors [i] onto [r]. *) +val logxor : int t -> int -> unit + (** [incr r] atomically increments the value of [r] by [1]. *) val incr : int t -> unit diff --git a/stdlib/obj.ml b/stdlib/obj.ml index 8b01a5408e1..4bed007603f 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -84,6 +84,10 @@ let int_tag = 1000 let out_of_heap_tag = 1001 let unaligned_tag = 1002 +(* [null_tag] is not exposed in the interface of [Stdlib.Obj] + since [Stdlib.Obj.tag] accepts only non-null values. *) +let[@warning "-32"] null_tag = 1010 + module Extension_constructor = struct type t = extension_constructor diff --git a/test_register_compatible_vectorized.cmx.dump.expected b/test_register_compatible_vectorized.cmx.dump.expected new file mode 100644 index 00000000000..e69de29bb2d diff --git a/testsuite/tests/capsule-api/data.ml b/testsuite/tests/capsule-api/data.ml index 9c81c44612f..9cfeac2f9c1 100644 --- a/testsuite/tests/capsule-api/data.ml +++ b/testsuite/tests/capsule-api/data.ml @@ -176,30 +176,43 @@ let () = assert (Capsule.Data.project ptr' = 111) ;; - -(* [protect]. *) +(* [with_password]. *) exception Exn of string let () = - match Capsule.protect (fun () -> "ok") with + match Capsule.with_password (fun _password -> "ok") with | s -> assert (s = "ok") | exception _ -> assert false ;; let () = - match Capsule.protect (fun () -> Exn "ok") with + match Capsule.with_password (fun _password -> Exn "ok") with | Exn s -> assert (s = "ok") | _ -> assert false ;; let () = - match Capsule.protect (fun () -> reraise (Exn "fail")) with - | exception (Capsule.Protected (mut, exn)) -> - let s = Capsule.Mutex.with_lock mut (fun password -> - Capsule.Data.extract password (fun exn -> - match exn with - | Exn s -> s - | _ -> assert false) exn) in - assert (s = "fail") + match Capsule.with_password (fun _password -> reraise (Exn "fail")) with + | exception (Exn s) -> assert (s = "fail") + | _ -> assert false +;; + +let () = + match Capsule.with_password (fun (Capsule.Password.P password) -> + let data = Capsule.Data.create (fun () -> "fail") in + let msg = Capsule.Data.extract password (fun s : string -> s) data in + reraise (Exn msg)) + with + | exception (Exn s) -> assert (s = "fail") + | _ -> assert false +;; + +let () = + match Capsule.with_password (fun (Capsule.Password.P password) -> + let data = Capsule.Data.create (fun () -> "fail") in + let () = Capsule.Data.extract password (fun s -> reraise (Exn s)) data in + ()) + with + | exception (Exn s) -> assert (s = "fail") | _ -> assert false ;; diff --git a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference index 7a75bc5e8d3..084fcdc96a5 100644 --- a/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference @@ -89,13 +89,13 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11]) Tpat_var "fib" - value_mode global,many,nonportable;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) + value_mode global,many,nonportable,unyielding;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34]) Texp_function - alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended]) + alloc_mode global,many,nonportable,unyielding;id(modevar#7[aliased,contended .. unique,uncontended]) [] Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34]) - alloc_mode global,many,nonportable;aliased,uncontended + alloc_mode global,many,nonportable,unyielding;aliased,uncontended value [ @@ -110,7 +110,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern (test_locations.ml[19,572+4]..test_locations.ml[19,572+5]) Tpat_var "n" - value_mode global,many,portable;unique,uncontended + value_mode global,many,portable,unyielding;unique,uncontended expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34]) Texp_apply apply_mode Tail diff --git a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference index 93910acca50..ea4b6f36a1e 100644 --- a/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference +++ b/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference @@ -89,13 +89,13 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern Tpat_var "fib" - value_mode global,many,nonportable;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) + value_mode global,many,nonportable,unyielding;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) expression Texp_function - alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended]) + alloc_mode global,many,nonportable,unyielding;id(modevar#7[aliased,contended .. unique,uncontended]) [] Tfunction_cases - alloc_mode global,many,nonportable;aliased,uncontended + alloc_mode global,many,nonportable,unyielding;aliased,uncontended value [ @@ -110,7 +110,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern Tpat_var "n" - value_mode global,many,portable;unique,uncontended + value_mode global,many,portable,unyielding;unique,uncontended expression Texp_apply apply_mode Tail diff --git a/testsuite/tests/letrec-check/unboxed.ml b/testsuite/tests/letrec-check/unboxed.ml index 2ebc1c74e69..8e80fa719eb 100644 --- a/testsuite/tests/letrec-check/unboxed.ml +++ b/testsuite/tests/letrec-check/unboxed.ml @@ -23,14 +23,17 @@ Line 2, characters 12-19: Error: This kind of expression is not allowed as right-hand side of "let rec" |}];; +(* This test was made to error by disallowing singleton recursive unboxed types. + We keep it in case these are re-allowed, in which case it should error with: + [This kind of expression is not allowed as right-hand side of "let rec"] *) type r = A of r [@@unboxed] let rec y = A y;; [%%expect{| -type r = A of r [@@unboxed] -Line 2, characters 12-15: -2 | let rec y = A y;; - ^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" +Line 1, characters 0-27: +1 | type r = A of r [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "r" is recursive without boxing: + "r" contains "r" |}];; (* This test is not allowed if 'a' is unboxed, but should be accepted diff --git a/testsuite/tests/lib-atomic/test_atomic.ml b/testsuite/tests/lib-atomic/test_atomic.ml index fba6952cfff..1ed681f0b85 100644 --- a/testsuite/tests/lib-atomic/test_atomic.ml +++ b/testsuite/tests/lib-atomic/test_atomic.ml @@ -26,6 +26,12 @@ let () = assert ((Atomic.incr r; Atomic.get r) = 5) let () = assert ((Atomic.decr r; Atomic.get r) = 4) +let () = assert ((Atomic.add r 3; Atomic.get r) = 7) +let () = assert ((Atomic.sub r 3; Atomic.get r) = 4) +let () = assert ((Atomic.logand r 2; Atomic.get r) = 0) +let () = assert ((Atomic.logor r 2; Atomic.get r) = 2) +let () = assert ((Atomic.logxor r 3; Atomic.get r) = 1) + let () = let r = Atomic.make 0 in let cur = Atomic.get r in @@ -37,3 +43,26 @@ let () = let cur = Atomic.get r in ignore (Atomic.incr r, Atomic.decr r); assert (Atomic.get r = cur) + +(* Test primitives with non-immediate types *) + +let a = ref 1 +let r = Atomic.make a +let () = assert (Atomic.get r == a) + +let b = ref 2 +let () = Atomic.set r b +let () = assert (Atomic.get r == b) + +let c = ref 3 +let () = assert (Atomic.exchange r c == b) + +let d = ref 4 +let () = assert (Atomic.compare_and_set r c d = true) +let () = assert (Atomic.get r == d) + +let e = ref (-4) +let () = assert (Atomic.compare_and_set r c e = false) +let () = assert (Atomic.get r == d) + +let () = assert (Atomic.compare_and_set r c d = false) diff --git a/testsuite/tests/lib-atomic/test_atomic_cmpxchg.ml b/testsuite/tests/lib-atomic/test_atomic_cmpxchg.ml index d14896d57d5..c77a34bea1b 100644 --- a/testsuite/tests/lib-atomic/test_atomic_cmpxchg.ml +++ b/testsuite/tests/lib-atomic/test_atomic_cmpxchg.ml @@ -16,3 +16,27 @@ let () = assert (Atomic.get r = 4) let () = assert (Atomic.compare_exchange r 3 4 = 4) let () = assert (Atomic.get r = 4) + +(* Test primitives with non-immediate types *) + +let a = ref 1 +let r = Atomic.make a +let () = assert (Atomic.get r == a) + +let b = ref 2 +let () = Atomic.set r b +let () = assert (Atomic.get r == b) + +let c = ref 3 +let () = assert (Atomic.exchange r c == b) + +let d = ref 4 +let () = assert (Atomic.compare_exchange r c d == c) +let () = assert (Atomic.get r == d) + +let e = ref (-4) +let () = assert (Atomic.compare_exchange r c e == d) +let () = assert (Atomic.get r == d) + +let () = assert (Atomic.compare_exchange r c d == d) +let () = assert (Atomic.get r == d) diff --git a/testsuite/tests/lib-atomic/test_atomic_domain.ml b/testsuite/tests/lib-atomic/test_atomic_domain.ml new file mode 100644 index 00000000000..469e8f6b727 --- /dev/null +++ b/testsuite/tests/lib-atomic/test_atomic_domain.ml @@ -0,0 +1,77 @@ +(* TEST + runtime5; + native; + bytecode; +*) + +let[@alert "-unsafe_parallelism"] () = Domain.spawn (fun () -> + let r = Atomic.make 1 in + let () = assert (Atomic.get r = 1) in + + let () = Atomic.set r 2 in + let () = assert (Atomic.get r = 2) in + + let () = assert (Atomic.exchange r 3 = 2) in + + let () = assert (Atomic.compare_and_set r 3 4 = true) in + let () = assert (Atomic.get r = 4) in + + let () = assert (Atomic.compare_and_set r 3 (-4) = false) in + let () = assert (Atomic.get r = 4 ) in + + let () = assert (Atomic.compare_and_set r 3 4 = false) in + + let () = assert (Atomic.fetch_and_add r 2 = 4) in + let () = assert (Atomic.get r = 6) in + + let () = assert (Atomic.fetch_and_add r (-2) = 6) in + let () = assert (Atomic.get r = 4) in + + let () = assert ((Atomic.incr r; Atomic.get r) = 5) in + + let () = assert ((Atomic.decr r; Atomic.get r) = 4) in + + let () = assert ((Atomic.add r 3; Atomic.get r) = 7) in + let () = assert ((Atomic.sub r 3; Atomic.get r) = 4) in + let () = assert ((Atomic.logand r 2; Atomic.get r) = 0) in + let () = assert ((Atomic.logor r 2; Atomic.get r) = 2) in + let () = assert ((Atomic.logxor r 3; Atomic.get r) = 1) in + + let () = + let r = Atomic.make 0 in + let cur = Atomic.get r in + ignore (Atomic.set r (cur + 1), Atomic.set r (cur - 1)); + assert (Atomic.get r <> cur) + in + + let () = + let r = Atomic.make 0 in + let cur = Atomic.get r in + ignore (Atomic.incr r, Atomic.decr r); + assert (Atomic.get r = cur) + in + + (* Test primitives with non-immediate types *) + + let a = ref 1 in + let r = Atomic.make a in + let () = assert (Atomic.get r == a) in + + let b = ref 2 in + let () = Atomic.set r b in + let () = assert (Atomic.get r == b) in + + let c = ref 3 in + let () = assert (Atomic.exchange r c == b) in + + let d = ref 4 in + let () = assert (Atomic.compare_and_set r c d = true) in + let () = assert (Atomic.get r == d) in + + let e = ref (-4) in + let () = assert (Atomic.compare_and_set r c e = false) in + let () = assert (Atomic.get r == d) in + + let () = assert (Atomic.compare_and_set r c d = false) in + + ()) |> Domain.join diff --git a/testsuite/tests/lib-obj/obj_dup_closures.ml b/testsuite/tests/lib-obj/obj_dup_closures.ml new file mode 100644 index 00000000000..644a6bc6a48 --- /dev/null +++ b/testsuite/tests/lib-obj/obj_dup_closures.ml @@ -0,0 +1,5264 @@ +(* TEST *) + +[@@@ocaml.flambda_oclassic] + +external int_as_pointer : _ -> int = "%int_as_pointer" + +module Int64_u = struct + external to_int64 : int64# -> (int64[@local_opt]) = "%box_int64" + [@@warning "-187"] + + external of_int64 : (int64[@local_opt]) -> int64# = "%unbox_int64" + [@@warning "-187"] + + let equal x y = Int64.equal (to_int64 x) (to_int64 y) +end + +let minor_heap_size_in_bytes = + assert (Sys.word_size = 64); + (Gc.get ()).minor_heap_size * Sys.word_size / 8 + +let[@opaque] rand_near_minor_heap () = + let r = ref () in + let i : int = Obj.magic (int_as_pointer r) in + let b = minor_heap_size_in_bytes / 2 in + let n = (Random.int b - (b / 2)) * 2 in + Int64_u.of_int64 (Int64.of_int ((i * 2) + n)) + +let[@opaque] rand_string () = + match Random.int 3 with + | 0 -> "goat" + | 1 -> "sheep" + | 2 -> "cow" + | _ -> assert false + +(* Example flambda2 output: + +(c1_1arg/870UV) = + (set_of_closures Heap + ({((c1_1arg/4 ∷ 𝕍*|Null) camlObj_dup_closures__c1_1arg_4_22_code)}) + (env {((i64_1/0 ∷ ℕ𝟞𝟜) i64_1/864UV)})) +(c2_1arg/879UV) = + (set_of_closures Heap + ({((c2_1arg/5 ∷ 𝕍*|Null) camlObj_dup_closures__c2_1arg_5_23_code)}) + (env {((i64_2/1 ∷ ℕ𝟞𝟜) i64_2/865UV) ((x/2 ∷ 𝕍) x/868UV)})) +(c3_1arg/892UV) = + (set_of_closures Heap + ({((c3_1arg/6 ∷ 𝕍*|Null) camlObj_dup_closures__c3_1arg_6_24_code)}) + (env {((x/3 ∷ 𝕍) x/868UV)})) +(c1_2arg/904UV) = + (set_of_closures Heap + ({((c1_2arg/7 ∷ 𝕍*|Null) camlObj_dup_closures__c1_2arg_7_25_code)}) + (env {((i64_3/4 ∷ ℕ𝟞𝟜) i64_3/866UV)})) +(c2_2arg/914UV) = + (set_of_closures Heap + ({((c2_2arg/8 ∷ 𝕍*|Null) camlObj_dup_closures__c2_2arg_8_26_code)}) + (env {((i64_4/5 ∷ ℕ𝟞𝟜) i64_4/867UV) ((x/6 ∷ 𝕍) x/868UV)})) +(c3_2arg/928UV) = + (set_of_closures Heap + ({((c3_2arg/9 ∷ 𝕍*|Null) camlObj_dup_closures__c3_2arg_9_27_code)}) + (env {((x/7 ∷ 𝕍) x/868UV)})) +(rec_c1_1arg/941UV rec_c2_1arg/942UV rec_c3_1arg/943UV rec_c1_2arg/944UV + rec_c2_2arg/945UV rec_c3_2arg/946UV) = + (set_of_closures Heap + ({((rec_c1_1arg/10 ∷ 𝕍*|Null) camlObj_dup_closures__rec_c1_1arg_10_28_code) + ((rec_c2_1arg/11 ∷ 𝕍*|Null) camlObj_dup_closures__rec_c2_1arg_11_29_code) + ((rec_c3_1arg/12 ∷ 𝕍*|Null) camlObj_dup_closures__rec_c3_1arg_12_30_code) + ((rec_c1_2arg/13 ∷ 𝕍*|Null) camlObj_dup_closures__rec_c1_2arg_13_31_code) + ((rec_c2_2arg/14 ∷ 𝕍*|Null) camlObj_dup_closures__rec_c2_2arg_14_32_code) + ((rec_c3_2arg/15 ∷ 𝕍*|Null) camlObj_dup_closures__rec_c3_2arg_15_33_code)}) + (env + {((i64_1/8 ∷ ℕ𝟞𝟜) i64_1/864UV) ((i64_2/9 ∷ ℕ𝟞𝟜) i64_2/865UV) + ((i64_3/10 ∷ ℕ𝟞𝟜) i64_3/866UV) ((i64_4/11 ∷ ℕ𝟞𝟜) i64_4/867UV) + ((x/12 ∷ 𝕍) x/868UV)})) +*) + +let[@opaque] make_small_closures (i64_1 : int64#) (i64_2 : int64#) + (i64_3 : int64#) (i64_4 : int64#) (x : string) = + (* Two-word function slot (i.e. one argument) cases *) + let[@opaque] c1_1arg () = + (* Only an unboxed environment *) + i64_1 + in + let[@opaque] c2_1arg () = + (* An unboxed environment plus a scannable environment *) + let (_i : int) = Sys.opaque_identity (String.length x) in + i64_2 + in + let[@opaque] c3_1arg () = + (* Only a scannable environment *) + let (_i : int) = Sys.opaque_identity (String.length x) in + 100 + in + (* Three-word function slot (i.e. more than one argument) cases *) + let[@opaque] c1_2arg () () = i64_3 in + let[@opaque] c2_2arg () () = + let (_i : int) = Sys.opaque_identity (String.length x) in + i64_4 + in + let[@opaque] c3_2arg () () = + let (_i : int) = Sys.opaque_identity (String.length x) in + 200 + in + (* Cases to exercise [Infix_tag] logic *) + let[@opaque] rec rec_c1_1arg () = i64_1 + and[@opaque] rec_c2_1arg () = + let (_i : int) = Sys.opaque_identity (String.length x) in + i64_2 + and[@opaque] rec_c3_1arg () = + let (_i : int) = Sys.opaque_identity (String.length x) in + 300 + and[@opaque] rec_c1_2arg () () = + let (_ : int64#) = Sys.opaque_identity i64_3 in + rec_c1_1arg () + and[@opaque] rec_c2_2arg () () = + let (_i : int) = Sys.opaque_identity (String.length x) in + let (_ : int64#) = Sys.opaque_identity i64_4 in + rec_c2_1arg () + and[@opaque] rec_c3_2arg () () = + let (_i : int) = Sys.opaque_identity (String.length x) in + rec_c3_1arg () + in + ( c1_1arg, + c2_1arg, + c3_1arg, + c1_2arg, + c2_2arg, + c3_2arg, + rec_c1_1arg, + rec_c2_1arg, + rec_c3_1arg, + rec_c1_2arg, + rec_c2_2arg, + rec_c3_2arg ) + +let[@opaque] check_results small_or_large + (i64_1 : int64#) (i64_2 : int64#) (i64_3 : int64#) + (i64_4 : int64#) (x : string) + ( c1_1arg, + c2_1arg, + c3_1arg, + c1_2arg, + c2_2arg, + c3_2arg, + rec_c1_1arg, + rec_c2_1arg, + rec_c3_1arg, + rec_c1_2arg, + rec_c2_2arg, + rec_c3_2arg ) = + let check name b = + if not b then failwith (small_or_large ^ ": " ^ name) + in + check "c1_1" (Int64_u.equal (c1_1arg ()) i64_1); + check "c2_1" (Int64_u.equal (c2_1arg ()) i64_2); + check "c3_1" (Int.equal (c3_1arg ()) 100); + check "c1_2" (Int64_u.equal (c1_2arg () ()) i64_3); + check "c2_2" (Int64_u.equal (c2_2arg () ()) i64_4); + check "c3_2" (Int.equal (c3_2arg () ()) 200); + check "rec_c1_1" (Int64_u.equal (rec_c1_1arg ()) i64_1); + check "rec_c2_1" (Int64_u.equal (rec_c2_1arg ()) i64_2); + check "rec_c3_1" (Int.equal (rec_c3_1arg ()) 300); + check "rec_c1_2" (Int64_u.equal (rec_c1_2arg () ()) i64_1); + check "rec_c2_2" (Int64_u.equal (rec_c2_2arg () ()) i64_2); + check "rec_c3_2" (Int.equal (rec_c3_2arg () ()) 300) + +let check_tag_and_size v1 v2 = + let v1 = Obj.repr v1 in + let v2 = Obj.repr v2 in + assert (Obj.tag v1 = Obj.tag v2); + assert (Obj.size v1 = Obj.size v2) + +let check_one_small_closures () = + let i64_1 = rand_near_minor_heap () in + let i64_2 = rand_near_minor_heap () in + let i64_3 = rand_near_minor_heap () in + let i64_4 = rand_near_minor_heap () in + let x = rand_string () in + let ( c1_1arg_original, + c2_1arg_original, + c3_1arg_original, + c1_2arg_original, + c2_2arg_original, + c3_2arg_original, + rec_c1_1arg_original, + rec_c2_1arg_original, + rec_c3_1arg_original, + rec_c1_2arg_original, + rec_c2_2arg_original, + rec_c3_2arg_original ) = + make_small_closures i64_1 i64_2 i64_3 i64_4 x + in + let dup (type a) (x : a) : a = Obj.(obj (dup (repr x))) in + let c1_1arg = dup c1_1arg_original in + let c2_1arg = dup c2_1arg_original in + let c3_1arg = dup c3_1arg_original in + let c1_2arg = dup c1_2arg_original in + let c2_2arg = dup c2_2arg_original in + let c3_2arg = dup c3_2arg_original in + let rec_c1_1arg = dup rec_c1_1arg_original in + let rec_c2_1arg = dup rec_c2_1arg_original in + let rec_c3_1arg = dup rec_c3_1arg_original in + let rec_c1_2arg = dup rec_c1_2arg_original in + let rec_c2_2arg = dup rec_c2_2arg_original in + let rec_c3_2arg = dup rec_c3_2arg_original in + Gc.compact (); + check_tag_and_size c1_1arg c1_1arg_original; + check_tag_and_size c2_1arg c2_1arg_original; + check_tag_and_size c3_1arg c3_1arg_original; + check_tag_and_size c1_2arg c1_2arg_original; + check_tag_and_size c2_2arg c2_2arg_original; + check_tag_and_size c3_2arg c3_2arg_original; + check_tag_and_size rec_c1_1arg rec_c1_1arg_original; + check_tag_and_size rec_c2_1arg rec_c2_1arg_original; + check_tag_and_size rec_c3_1arg rec_c3_1arg_original; + check_tag_and_size rec_c1_2arg rec_c1_2arg_original; + check_tag_and_size rec_c2_2arg rec_c2_2arg_original; + check_tag_and_size rec_c3_2arg rec_c3_2arg_original; + check_results "small" i64_1 i64_2 i64_3 i64_4 x + ( c1_1arg, + c2_1arg, + c3_1arg, + c1_2arg, + c2_2arg, + c3_2arg, + rec_c1_1arg, + rec_c2_1arg, + rec_c3_1arg, + rec_c1_2arg, + rec_c2_2arg, + rec_c3_2arg ) + +(* Same as above, but with extra environment slots to make sure the + closures get allocated on the major heap when duplicated. + We assume Max_young_wosize = 256. +*) +let[@opaque] make_large_closures (i64_1 : int64#) (i64_2 : int64#) + (i64_3 : int64#) (i64_4 : int64#) + (padding_i64_0 : int64#) + (padding_i64_1 : int64#) + (padding_i64_2 : int64#) + (padding_i64_3 : int64#) + (padding_i64_4 : int64#) + (padding_i64_5 : int64#) + (padding_i64_6 : int64#) + (padding_i64_7 : int64#) + (padding_i64_8 : int64#) + (padding_i64_9 : int64#) + (padding_i64_10 : int64#) + (padding_i64_11 : int64#) + (padding_i64_12 : int64#) + (padding_i64_13 : int64#) + (padding_i64_14 : int64#) + (padding_i64_15 : int64#) + (padding_i64_16 : int64#) + (padding_i64_17 : int64#) + (padding_i64_18 : int64#) + (padding_i64_19 : int64#) + (padding_i64_20 : int64#) + (padding_i64_21 : int64#) + (padding_i64_22 : int64#) + (padding_i64_23 : int64#) + (padding_i64_24 : int64#) + (padding_i64_25 : int64#) + (padding_i64_26 : int64#) + (padding_i64_27 : int64#) + (padding_i64_28 : int64#) + (padding_i64_29 : int64#) + (padding_i64_30 : int64#) + (padding_i64_31 : int64#) + (padding_i64_32 : int64#) + (padding_i64_33 : int64#) + (padding_i64_34 : int64#) + (padding_i64_35 : int64#) + (padding_i64_36 : int64#) + (padding_i64_37 : int64#) + (padding_i64_38 : int64#) + (padding_i64_39 : int64#) + (padding_i64_40 : int64#) + (padding_i64_41 : int64#) + (padding_i64_42 : int64#) + (padding_i64_43 : int64#) + (padding_i64_44 : int64#) + (padding_i64_45 : int64#) + (padding_i64_46 : int64#) + (padding_i64_47 : int64#) + (padding_i64_48 : int64#) + (padding_i64_49 : int64#) + (padding_i64_50 : int64#) + (padding_i64_51 : int64#) + (padding_i64_52 : int64#) + (padding_i64_53 : int64#) + (padding_i64_54 : int64#) + (padding_i64_55 : int64#) + (padding_i64_56 : int64#) + (padding_i64_57 : int64#) + (padding_i64_58 : int64#) + (padding_i64_59 : int64#) + (padding_i64_60 : int64#) + (padding_i64_61 : int64#) + (padding_i64_62 : int64#) + (padding_i64_63 : int64#) + (padding_i64_64 : int64#) + (padding_i64_65 : int64#) + (padding_i64_66 : int64#) + (padding_i64_67 : int64#) + (padding_i64_68 : int64#) + (padding_i64_69 : int64#) + (padding_i64_70 : int64#) + (padding_i64_71 : int64#) + (padding_i64_72 : int64#) + (padding_i64_73 : int64#) + (padding_i64_74 : int64#) + (padding_i64_75 : int64#) + (padding_i64_76 : int64#) + (padding_i64_77 : int64#) + (padding_i64_78 : int64#) + (padding_i64_79 : int64#) + (padding_i64_80 : int64#) + (padding_i64_81 : int64#) + (padding_i64_82 : int64#) + (padding_i64_83 : int64#) + (padding_i64_84 : int64#) + (padding_i64_85 : int64#) + (padding_i64_86 : int64#) + (padding_i64_87 : int64#) + (padding_i64_88 : int64#) + (padding_i64_89 : int64#) + (padding_i64_90 : int64#) + (padding_i64_91 : int64#) + (padding_i64_92 : int64#) + (padding_i64_93 : int64#) + (padding_i64_94 : int64#) + (padding_i64_95 : int64#) + (padding_i64_96 : int64#) + (padding_i64_97 : int64#) + (padding_i64_98 : int64#) + (padding_i64_99 : int64#) + (padding_i64_100 : int64#) + (padding_i64_101 : int64#) + (padding_i64_102 : int64#) + (padding_i64_103 : int64#) + (padding_i64_104 : int64#) + (padding_i64_105 : int64#) + (padding_i64_106 : int64#) + (padding_i64_107 : int64#) + (padding_i64_108 : int64#) + (padding_i64_109 : int64#) + (padding_i64_110 : int64#) + (padding_i64_111 : int64#) + (padding_i64_112 : int64#) + (padding_i64_113 : int64#) + (padding_i64_114 : int64#) + (padding_i64_115 : int64#) + (padding_i64_116 : int64#) + (padding_i64_117 : int64#) + (padding_i64_118 : int64#) + (padding_i64_119 : int64#) + (padding_i64_120 : int64#) + (padding_i64_121 : int64#) + (padding_i64_122 : int64#) + (padding_i64_123 : int64#) + (padding_i64_124 : int64#) + (padding_i64_125 : int64#) + (padding_i64_126 : int64#) + (padding_i64_127 : int64#) + (padding_i64_128 : int64#) + (padding_i64_129 : int64#) + (padding_i64_130 : int64#) + (padding_i64_131 : int64#) + (padding_i64_132 : int64#) + (padding_i64_133 : int64#) + (padding_i64_134 : int64#) + (padding_i64_135 : int64#) + (padding_i64_136 : int64#) + (padding_i64_137 : int64#) + (padding_i64_138 : int64#) + (padding_i64_139 : int64#) + (padding_i64_140 : int64#) + (padding_i64_141 : int64#) + (padding_i64_142 : int64#) + (padding_i64_143 : int64#) + (padding_i64_144 : int64#) + (padding_i64_145 : int64#) + (padding_i64_146 : int64#) + (padding_i64_147 : int64#) + (padding_i64_148 : int64#) + (padding_i64_149 : int64#) + (padding_i64_150 : int64#) + (padding_i64_151 : int64#) + (padding_i64_152 : int64#) + (padding_i64_153 : int64#) + (padding_i64_154 : int64#) + (padding_i64_155 : int64#) + (padding_i64_156 : int64#) + (padding_i64_157 : int64#) + (padding_i64_158 : int64#) + (padding_i64_159 : int64#) + (padding_i64_160 : int64#) + (padding_i64_161 : int64#) + (padding_i64_162 : int64#) + (padding_i64_163 : int64#) + (padding_i64_164 : int64#) + (padding_i64_165 : int64#) + (padding_i64_166 : int64#) + (padding_i64_167 : int64#) + (padding_i64_168 : int64#) + (padding_i64_169 : int64#) + (padding_i64_170 : int64#) + (padding_i64_171 : int64#) + (padding_i64_172 : int64#) + (padding_i64_173 : int64#) + (padding_i64_174 : int64#) + (padding_i64_175 : int64#) + (padding_i64_176 : int64#) + (padding_i64_177 : int64#) + (padding_i64_178 : int64#) + (padding_i64_179 : int64#) + (padding_i64_180 : int64#) + (padding_i64_181 : int64#) + (padding_i64_182 : int64#) + (padding_i64_183 : int64#) + (padding_i64_184 : int64#) + (padding_i64_185 : int64#) + (padding_i64_186 : int64#) + (padding_i64_187 : int64#) + (padding_i64_188 : int64#) + (padding_i64_189 : int64#) + (padding_i64_190 : int64#) + (padding_i64_191 : int64#) + (padding_i64_192 : int64#) + (padding_i64_193 : int64#) + (padding_i64_194 : int64#) + (padding_i64_195 : int64#) + (padding_i64_196 : int64#) + (padding_i64_197 : int64#) + (padding_i64_198 : int64#) + (padding_i64_199 : int64#) + (padding_i64_200 : int64#) + (padding_i64_201 : int64#) + (padding_i64_202 : int64#) + (padding_i64_203 : int64#) + (padding_i64_204 : int64#) + (padding_i64_205 : int64#) + (padding_i64_206 : int64#) + (padding_i64_207 : int64#) + (padding_i64_208 : int64#) + (padding_i64_209 : int64#) + (padding_i64_210 : int64#) + (padding_i64_211 : int64#) + (padding_i64_212 : int64#) + (padding_i64_213 : int64#) + (padding_i64_214 : int64#) + (padding_i64_215 : int64#) + (padding_i64_216 : int64#) + (padding_i64_217 : int64#) + (padding_i64_218 : int64#) + (padding_i64_219 : int64#) + (padding_i64_220 : int64#) + (padding_i64_221 : int64#) + (padding_i64_222 : int64#) + (padding_i64_223 : int64#) + (padding_i64_224 : int64#) + (padding_i64_225 : int64#) + (padding_i64_226 : int64#) + (padding_i64_227 : int64#) + (padding_i64_228 : int64#) + (padding_i64_229 : int64#) + (padding_i64_230 : int64#) + (padding_i64_231 : int64#) + (padding_i64_232 : int64#) + (padding_i64_233 : int64#) + (padding_i64_234 : int64#) + (padding_i64_235 : int64#) + (padding_i64_236 : int64#) + (padding_i64_237 : int64#) + (padding_i64_238 : int64#) + (padding_i64_239 : int64#) + (padding_i64_240 : int64#) + (padding_i64_241 : int64#) + (padding_i64_242 : int64#) + (padding_i64_243 : int64#) + (padding_i64_244 : int64#) + (padding_i64_245 : int64#) + (padding_i64_246 : int64#) + (padding_i64_247 : int64#) + (padding_i64_248 : int64#) + (padding_i64_249 : int64#) + (padding_i64_250 : int64#) + (padding_i64_251 : int64#) + (padding_i64_252 : int64#) + (padding_i64_253 : int64#) + (padding_i64_254 : int64#) + (padding_i64_255 : int64#) + (padding_i64_256 : int64#) + (padding_i64_257 : int64#) + (padding_i64_258 : int64#) + (padding_i64_259 : int64#) + (padding_i64_260 : int64#) + (padding_i64_261 : int64#) + (padding_i64_262 : int64#) + (padding_i64_263 : int64#) + (padding_i64_264 : int64#) + (padding_i64_265 : int64#) + (padding_i64_266 : int64#) + (padding_i64_267 : int64#) + (padding_i64_268 : int64#) + (padding_i64_269 : int64#) + (padding_i64_270 : int64#) + (padding_0 : string) + (padding_1 : string) + (padding_2 : string) + (padding_3 : string) + (padding_4 : string) + (padding_5 : string) + (padding_6 : string) + (padding_7 : string) + (padding_8 : string) + (padding_9 : string) + (padding_10 : string) + (padding_11 : string) + (padding_12 : string) + (padding_13 : string) + (padding_14 : string) + (padding_15 : string) + (padding_16 : string) + (padding_17 : string) + (padding_18 : string) + (padding_19 : string) + (padding_20 : string) + (padding_21 : string) + (padding_22 : string) + (padding_23 : string) + (padding_24 : string) + (padding_25 : string) + (padding_26 : string) + (padding_27 : string) + (padding_28 : string) + (padding_29 : string) + (padding_30 : string) + (padding_31 : string) + (padding_32 : string) + (padding_33 : string) + (padding_34 : string) + (padding_35 : string) + (padding_36 : string) + (padding_37 : string) + (padding_38 : string) + (padding_39 : string) + (padding_40 : string) + (padding_41 : string) + (padding_42 : string) + (padding_43 : string) + (padding_44 : string) + (padding_45 : string) + (padding_46 : string) + (padding_47 : string) + (padding_48 : string) + (padding_49 : string) + (padding_50 : string) + (padding_51 : string) + (padding_52 : string) + (padding_53 : string) + (padding_54 : string) + (padding_55 : string) + (padding_56 : string) + (padding_57 : string) + (padding_58 : string) + (padding_59 : string) + (padding_60 : string) + (padding_61 : string) + (padding_62 : string) + (padding_63 : string) + (padding_64 : string) + (padding_65 : string) + (padding_66 : string) + (padding_67 : string) + (padding_68 : string) + (padding_69 : string) + (padding_70 : string) + (padding_71 : string) + (padding_72 : string) + (padding_73 : string) + (padding_74 : string) + (padding_75 : string) + (padding_76 : string) + (padding_77 : string) + (padding_78 : string) + (padding_79 : string) + (padding_80 : string) + (padding_81 : string) + (padding_82 : string) + (padding_83 : string) + (padding_84 : string) + (padding_85 : string) + (padding_86 : string) + (padding_87 : string) + (padding_88 : string) + (padding_89 : string) + (padding_90 : string) + (padding_91 : string) + (padding_92 : string) + (padding_93 : string) + (padding_94 : string) + (padding_95 : string) + (padding_96 : string) + (padding_97 : string) + (padding_98 : string) + (padding_99 : string) + (padding_100 : string) + (padding_101 : string) + (padding_102 : string) + (padding_103 : string) + (padding_104 : string) + (padding_105 : string) + (padding_106 : string) + (padding_107 : string) + (padding_108 : string) + (padding_109 : string) + (padding_110 : string) + (padding_111 : string) + (padding_112 : string) + (padding_113 : string) + (padding_114 : string) + (padding_115 : string) + (padding_116 : string) + (padding_117 : string) + (padding_118 : string) + (padding_119 : string) + (padding_120 : string) + (padding_121 : string) + (padding_122 : string) + (padding_123 : string) + (padding_124 : string) + (padding_125 : string) + (padding_126 : string) + (padding_127 : string) + (padding_128 : string) + (padding_129 : string) + (padding_130 : string) + (padding_131 : string) + (padding_132 : string) + (padding_133 : string) + (padding_134 : string) + (padding_135 : string) + (padding_136 : string) + (padding_137 : string) + (padding_138 : string) + (padding_139 : string) + (padding_140 : string) + (padding_141 : string) + (padding_142 : string) + (padding_143 : string) + (padding_144 : string) + (padding_145 : string) + (padding_146 : string) + (padding_147 : string) + (padding_148 : string) + (padding_149 : string) + (padding_150 : string) + (padding_151 : string) + (padding_152 : string) + (padding_153 : string) + (padding_154 : string) + (padding_155 : string) + (padding_156 : string) + (padding_157 : string) + (padding_158 : string) + (padding_159 : string) + (padding_160 : string) + (padding_161 : string) + (padding_162 : string) + (padding_163 : string) + (padding_164 : string) + (padding_165 : string) + (padding_166 : string) + (padding_167 : string) + (padding_168 : string) + (padding_169 : string) + (padding_170 : string) + (padding_171 : string) + (padding_172 : string) + (padding_173 : string) + (padding_174 : string) + (padding_175 : string) + (padding_176 : string) + (padding_177 : string) + (padding_178 : string) + (padding_179 : string) + (padding_180 : string) + (padding_181 : string) + (padding_182 : string) + (padding_183 : string) + (padding_184 : string) + (padding_185 : string) + (padding_186 : string) + (padding_187 : string) + (padding_188 : string) + (padding_189 : string) + (padding_190 : string) + (padding_191 : string) + (padding_192 : string) + (padding_193 : string) + (padding_194 : string) + (padding_195 : string) + (padding_196 : string) + (padding_197 : string) + (padding_198 : string) + (padding_199 : string) + (padding_200 : string) + (padding_201 : string) + (padding_202 : string) + (padding_203 : string) + (padding_204 : string) + (padding_205 : string) + (padding_206 : string) + (padding_207 : string) + (padding_208 : string) + (padding_209 : string) + (padding_210 : string) + (padding_211 : string) + (padding_212 : string) + (padding_213 : string) + (padding_214 : string) + (padding_215 : string) + (padding_216 : string) + (padding_217 : string) + (padding_218 : string) + (padding_219 : string) + (padding_220 : string) + (padding_221 : string) + (padding_222 : string) + (padding_223 : string) + (padding_224 : string) + (padding_225 : string) + (padding_226 : string) + (padding_227 : string) + (padding_228 : string) + (padding_229 : string) + (padding_230 : string) + (padding_231 : string) + (padding_232 : string) + (padding_233 : string) + (padding_234 : string) + (padding_235 : string) + (padding_236 : string) + (padding_237 : string) + (padding_238 : string) + (padding_239 : string) + (padding_240 : string) + (padding_241 : string) + (padding_242 : string) + (padding_243 : string) + (padding_244 : string) + (padding_245 : string) + (padding_246 : string) + (padding_247 : string) + (padding_248 : string) + (padding_249 : string) + (padding_250 : string) + (padding_251 : string) + (padding_252 : string) + (padding_253 : string) + (padding_254 : string) + (padding_255 : string) + (padding_256 : string) + (padding_257 : string) + (padding_258 : string) + (padding_259 : string) + (padding_260 : string) + (padding_261 : string) + (padding_262 : string) + (padding_263 : string) + (padding_264 : string) + (padding_265 : string) + (padding_266 : string) + (padding_267 : string) + (padding_268 : string) + (padding_269 : string) + (padding_270 : string) + (x : string) = + (* Two-word function slot (i.e. one argument) cases *) + let[@opaque] c1_1arg () = + (* Only an unboxed environment *) + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + i64_1 + in + let[@opaque] c2_1arg () = + (* An unboxed environment plus a scannable environment *) + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + i64_2 + in + let[@opaque] c3_1arg () = + (* Only a scannable environment *) + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_1 in + let (_ : string) = Sys.opaque_identity padding_2 in + let (_ : string) = Sys.opaque_identity padding_3 in + let (_ : string) = Sys.opaque_identity padding_4 in + let (_ : string) = Sys.opaque_identity padding_5 in + let (_ : string) = Sys.opaque_identity padding_6 in + let (_ : string) = Sys.opaque_identity padding_7 in + let (_ : string) = Sys.opaque_identity padding_8 in + let (_ : string) = Sys.opaque_identity padding_9 in + let (_ : string) = Sys.opaque_identity padding_10 in + let (_ : string) = Sys.opaque_identity padding_11 in + let (_ : string) = Sys.opaque_identity padding_12 in + let (_ : string) = Sys.opaque_identity padding_13 in + let (_ : string) = Sys.opaque_identity padding_14 in + let (_ : string) = Sys.opaque_identity padding_15 in + let (_ : string) = Sys.opaque_identity padding_16 in + let (_ : string) = Sys.opaque_identity padding_17 in + let (_ : string) = Sys.opaque_identity padding_18 in + let (_ : string) = Sys.opaque_identity padding_19 in + let (_ : string) = Sys.opaque_identity padding_20 in + let (_ : string) = Sys.opaque_identity padding_21 in + let (_ : string) = Sys.opaque_identity padding_22 in + let (_ : string) = Sys.opaque_identity padding_23 in + let (_ : string) = Sys.opaque_identity padding_24 in + let (_ : string) = Sys.opaque_identity padding_25 in + let (_ : string) = Sys.opaque_identity padding_26 in + let (_ : string) = Sys.opaque_identity padding_27 in + let (_ : string) = Sys.opaque_identity padding_28 in + let (_ : string) = Sys.opaque_identity padding_29 in + let (_ : string) = Sys.opaque_identity padding_30 in + let (_ : string) = Sys.opaque_identity padding_31 in + let (_ : string) = Sys.opaque_identity padding_32 in + let (_ : string) = Sys.opaque_identity padding_33 in + let (_ : string) = Sys.opaque_identity padding_34 in + let (_ : string) = Sys.opaque_identity padding_35 in + let (_ : string) = Sys.opaque_identity padding_36 in + let (_ : string) = Sys.opaque_identity padding_37 in + let (_ : string) = Sys.opaque_identity padding_38 in + let (_ : string) = Sys.opaque_identity padding_39 in + let (_ : string) = Sys.opaque_identity padding_40 in + let (_ : string) = Sys.opaque_identity padding_41 in + let (_ : string) = Sys.opaque_identity padding_42 in + let (_ : string) = Sys.opaque_identity padding_43 in + let (_ : string) = Sys.opaque_identity padding_44 in + let (_ : string) = Sys.opaque_identity padding_45 in + let (_ : string) = Sys.opaque_identity padding_46 in + let (_ : string) = Sys.opaque_identity padding_47 in + let (_ : string) = Sys.opaque_identity padding_48 in + let (_ : string) = Sys.opaque_identity padding_49 in + let (_ : string) = Sys.opaque_identity padding_50 in + let (_ : string) = Sys.opaque_identity padding_51 in + let (_ : string) = Sys.opaque_identity padding_52 in + let (_ : string) = Sys.opaque_identity padding_53 in + let (_ : string) = Sys.opaque_identity padding_54 in + let (_ : string) = Sys.opaque_identity padding_55 in + let (_ : string) = Sys.opaque_identity padding_56 in + let (_ : string) = Sys.opaque_identity padding_57 in + let (_ : string) = Sys.opaque_identity padding_58 in + let (_ : string) = Sys.opaque_identity padding_59 in + let (_ : string) = Sys.opaque_identity padding_60 in + let (_ : string) = Sys.opaque_identity padding_61 in + let (_ : string) = Sys.opaque_identity padding_62 in + let (_ : string) = Sys.opaque_identity padding_63 in + let (_ : string) = Sys.opaque_identity padding_64 in + let (_ : string) = Sys.opaque_identity padding_65 in + let (_ : string) = Sys.opaque_identity padding_66 in + let (_ : string) = Sys.opaque_identity padding_67 in + let (_ : string) = Sys.opaque_identity padding_68 in + let (_ : string) = Sys.opaque_identity padding_69 in + let (_ : string) = Sys.opaque_identity padding_70 in + let (_ : string) = Sys.opaque_identity padding_71 in + let (_ : string) = Sys.opaque_identity padding_72 in + let (_ : string) = Sys.opaque_identity padding_73 in + let (_ : string) = Sys.opaque_identity padding_74 in + let (_ : string) = Sys.opaque_identity padding_75 in + let (_ : string) = Sys.opaque_identity padding_76 in + let (_ : string) = Sys.opaque_identity padding_77 in + let (_ : string) = Sys.opaque_identity padding_78 in + let (_ : string) = Sys.opaque_identity padding_79 in + let (_ : string) = Sys.opaque_identity padding_80 in + let (_ : string) = Sys.opaque_identity padding_81 in + let (_ : string) = Sys.opaque_identity padding_82 in + let (_ : string) = Sys.opaque_identity padding_83 in + let (_ : string) = Sys.opaque_identity padding_84 in + let (_ : string) = Sys.opaque_identity padding_85 in + let (_ : string) = Sys.opaque_identity padding_86 in + let (_ : string) = Sys.opaque_identity padding_87 in + let (_ : string) = Sys.opaque_identity padding_88 in + let (_ : string) = Sys.opaque_identity padding_89 in + let (_ : string) = Sys.opaque_identity padding_90 in + let (_ : string) = Sys.opaque_identity padding_91 in + let (_ : string) = Sys.opaque_identity padding_92 in + let (_ : string) = Sys.opaque_identity padding_93 in + let (_ : string) = Sys.opaque_identity padding_94 in + let (_ : string) = Sys.opaque_identity padding_95 in + let (_ : string) = Sys.opaque_identity padding_96 in + let (_ : string) = Sys.opaque_identity padding_97 in + let (_ : string) = Sys.opaque_identity padding_98 in + let (_ : string) = Sys.opaque_identity padding_99 in + let (_ : string) = Sys.opaque_identity padding_100 in + let (_ : string) = Sys.opaque_identity padding_101 in + let (_ : string) = Sys.opaque_identity padding_102 in + let (_ : string) = Sys.opaque_identity padding_103 in + let (_ : string) = Sys.opaque_identity padding_104 in + let (_ : string) = Sys.opaque_identity padding_105 in + let (_ : string) = Sys.opaque_identity padding_106 in + let (_ : string) = Sys.opaque_identity padding_107 in + let (_ : string) = Sys.opaque_identity padding_108 in + let (_ : string) = Sys.opaque_identity padding_109 in + let (_ : string) = Sys.opaque_identity padding_110 in + let (_ : string) = Sys.opaque_identity padding_111 in + let (_ : string) = Sys.opaque_identity padding_112 in + let (_ : string) = Sys.opaque_identity padding_113 in + let (_ : string) = Sys.opaque_identity padding_114 in + let (_ : string) = Sys.opaque_identity padding_115 in + let (_ : string) = Sys.opaque_identity padding_116 in + let (_ : string) = Sys.opaque_identity padding_117 in + let (_ : string) = Sys.opaque_identity padding_118 in + let (_ : string) = Sys.opaque_identity padding_119 in + let (_ : string) = Sys.opaque_identity padding_120 in + let (_ : string) = Sys.opaque_identity padding_121 in + let (_ : string) = Sys.opaque_identity padding_122 in + let (_ : string) = Sys.opaque_identity padding_123 in + let (_ : string) = Sys.opaque_identity padding_124 in + let (_ : string) = Sys.opaque_identity padding_125 in + let (_ : string) = Sys.opaque_identity padding_126 in + let (_ : string) = Sys.opaque_identity padding_127 in + let (_ : string) = Sys.opaque_identity padding_128 in + let (_ : string) = Sys.opaque_identity padding_129 in + let (_ : string) = Sys.opaque_identity padding_130 in + let (_ : string) = Sys.opaque_identity padding_131 in + let (_ : string) = Sys.opaque_identity padding_132 in + let (_ : string) = Sys.opaque_identity padding_133 in + let (_ : string) = Sys.opaque_identity padding_134 in + let (_ : string) = Sys.opaque_identity padding_135 in + let (_ : string) = Sys.opaque_identity padding_136 in + let (_ : string) = Sys.opaque_identity padding_137 in + let (_ : string) = Sys.opaque_identity padding_138 in + let (_ : string) = Sys.opaque_identity padding_139 in + let (_ : string) = Sys.opaque_identity padding_140 in + let (_ : string) = Sys.opaque_identity padding_141 in + let (_ : string) = Sys.opaque_identity padding_142 in + let (_ : string) = Sys.opaque_identity padding_143 in + let (_ : string) = Sys.opaque_identity padding_144 in + let (_ : string) = Sys.opaque_identity padding_145 in + let (_ : string) = Sys.opaque_identity padding_146 in + let (_ : string) = Sys.opaque_identity padding_147 in + let (_ : string) = Sys.opaque_identity padding_148 in + let (_ : string) = Sys.opaque_identity padding_149 in + let (_ : string) = Sys.opaque_identity padding_150 in + let (_ : string) = Sys.opaque_identity padding_151 in + let (_ : string) = Sys.opaque_identity padding_152 in + let (_ : string) = Sys.opaque_identity padding_153 in + let (_ : string) = Sys.opaque_identity padding_154 in + let (_ : string) = Sys.opaque_identity padding_155 in + let (_ : string) = Sys.opaque_identity padding_156 in + let (_ : string) = Sys.opaque_identity padding_157 in + let (_ : string) = Sys.opaque_identity padding_158 in + let (_ : string) = Sys.opaque_identity padding_159 in + let (_ : string) = Sys.opaque_identity padding_160 in + let (_ : string) = Sys.opaque_identity padding_161 in + let (_ : string) = Sys.opaque_identity padding_162 in + let (_ : string) = Sys.opaque_identity padding_163 in + let (_ : string) = Sys.opaque_identity padding_164 in + let (_ : string) = Sys.opaque_identity padding_165 in + let (_ : string) = Sys.opaque_identity padding_166 in + let (_ : string) = Sys.opaque_identity padding_167 in + let (_ : string) = Sys.opaque_identity padding_168 in + let (_ : string) = Sys.opaque_identity padding_169 in + let (_ : string) = Sys.opaque_identity padding_170 in + let (_ : string) = Sys.opaque_identity padding_171 in + let (_ : string) = Sys.opaque_identity padding_172 in + let (_ : string) = Sys.opaque_identity padding_173 in + let (_ : string) = Sys.opaque_identity padding_174 in + let (_ : string) = Sys.opaque_identity padding_175 in + let (_ : string) = Sys.opaque_identity padding_176 in + let (_ : string) = Sys.opaque_identity padding_177 in + let (_ : string) = Sys.opaque_identity padding_178 in + let (_ : string) = Sys.opaque_identity padding_179 in + let (_ : string) = Sys.opaque_identity padding_180 in + let (_ : string) = Sys.opaque_identity padding_181 in + let (_ : string) = Sys.opaque_identity padding_182 in + let (_ : string) = Sys.opaque_identity padding_183 in + let (_ : string) = Sys.opaque_identity padding_184 in + let (_ : string) = Sys.opaque_identity padding_185 in + let (_ : string) = Sys.opaque_identity padding_186 in + let (_ : string) = Sys.opaque_identity padding_187 in + let (_ : string) = Sys.opaque_identity padding_188 in + let (_ : string) = Sys.opaque_identity padding_189 in + let (_ : string) = Sys.opaque_identity padding_190 in + let (_ : string) = Sys.opaque_identity padding_191 in + let (_ : string) = Sys.opaque_identity padding_192 in + let (_ : string) = Sys.opaque_identity padding_193 in + let (_ : string) = Sys.opaque_identity padding_194 in + let (_ : string) = Sys.opaque_identity padding_195 in + let (_ : string) = Sys.opaque_identity padding_196 in + let (_ : string) = Sys.opaque_identity padding_197 in + let (_ : string) = Sys.opaque_identity padding_198 in + let (_ : string) = Sys.opaque_identity padding_199 in + let (_ : string) = Sys.opaque_identity padding_200 in + let (_ : string) = Sys.opaque_identity padding_201 in + let (_ : string) = Sys.opaque_identity padding_202 in + let (_ : string) = Sys.opaque_identity padding_203 in + let (_ : string) = Sys.opaque_identity padding_204 in + let (_ : string) = Sys.opaque_identity padding_205 in + let (_ : string) = Sys.opaque_identity padding_206 in + let (_ : string) = Sys.opaque_identity padding_207 in + let (_ : string) = Sys.opaque_identity padding_208 in + let (_ : string) = Sys.opaque_identity padding_209 in + let (_ : string) = Sys.opaque_identity padding_210 in + let (_ : string) = Sys.opaque_identity padding_211 in + let (_ : string) = Sys.opaque_identity padding_212 in + let (_ : string) = Sys.opaque_identity padding_213 in + let (_ : string) = Sys.opaque_identity padding_214 in + let (_ : string) = Sys.opaque_identity padding_215 in + let (_ : string) = Sys.opaque_identity padding_216 in + let (_ : string) = Sys.opaque_identity padding_217 in + let (_ : string) = Sys.opaque_identity padding_218 in + let (_ : string) = Sys.opaque_identity padding_219 in + let (_ : string) = Sys.opaque_identity padding_220 in + let (_ : string) = Sys.opaque_identity padding_221 in + let (_ : string) = Sys.opaque_identity padding_222 in + let (_ : string) = Sys.opaque_identity padding_223 in + let (_ : string) = Sys.opaque_identity padding_224 in + let (_ : string) = Sys.opaque_identity padding_225 in + let (_ : string) = Sys.opaque_identity padding_226 in + let (_ : string) = Sys.opaque_identity padding_227 in + let (_ : string) = Sys.opaque_identity padding_228 in + let (_ : string) = Sys.opaque_identity padding_229 in + let (_ : string) = Sys.opaque_identity padding_230 in + let (_ : string) = Sys.opaque_identity padding_231 in + let (_ : string) = Sys.opaque_identity padding_232 in + let (_ : string) = Sys.opaque_identity padding_233 in + let (_ : string) = Sys.opaque_identity padding_234 in + let (_ : string) = Sys.opaque_identity padding_235 in + let (_ : string) = Sys.opaque_identity padding_236 in + let (_ : string) = Sys.opaque_identity padding_237 in + let (_ : string) = Sys.opaque_identity padding_238 in + let (_ : string) = Sys.opaque_identity padding_239 in + let (_ : string) = Sys.opaque_identity padding_240 in + let (_ : string) = Sys.opaque_identity padding_241 in + let (_ : string) = Sys.opaque_identity padding_242 in + let (_ : string) = Sys.opaque_identity padding_243 in + let (_ : string) = Sys.opaque_identity padding_244 in + let (_ : string) = Sys.opaque_identity padding_245 in + let (_ : string) = Sys.opaque_identity padding_246 in + let (_ : string) = Sys.opaque_identity padding_247 in + let (_ : string) = Sys.opaque_identity padding_248 in + let (_ : string) = Sys.opaque_identity padding_249 in + let (_ : string) = Sys.opaque_identity padding_250 in + let (_ : string) = Sys.opaque_identity padding_251 in + let (_ : string) = Sys.opaque_identity padding_252 in + let (_ : string) = Sys.opaque_identity padding_253 in + let (_ : string) = Sys.opaque_identity padding_254 in + let (_ : string) = Sys.opaque_identity padding_255 in + let (_ : string) = Sys.opaque_identity padding_256 in + let (_ : string) = Sys.opaque_identity padding_257 in + let (_ : string) = Sys.opaque_identity padding_258 in + let (_ : string) = Sys.opaque_identity padding_259 in + let (_ : string) = Sys.opaque_identity padding_260 in + let (_ : string) = Sys.opaque_identity padding_261 in + let (_ : string) = Sys.opaque_identity padding_262 in + let (_ : string) = Sys.opaque_identity padding_263 in + let (_ : string) = Sys.opaque_identity padding_264 in + let (_ : string) = Sys.opaque_identity padding_265 in + let (_ : string) = Sys.opaque_identity padding_266 in + let (_ : string) = Sys.opaque_identity padding_267 in + let (_ : string) = Sys.opaque_identity padding_268 in + let (_ : string) = Sys.opaque_identity padding_269 in + let (_ : string) = Sys.opaque_identity padding_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + 100 + in + (* Three-word function slot (i.e. more than one argument) cases *) + let[@opaque] c1_2arg () () = + (* Only an unboxed environment *) + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + i64_3 + in + let[@opaque] c2_2arg () () = + (* An unboxed environment plus a scannable environment *) + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + i64_4 + in + let[@opaque] c3_2arg () () = + (* Only a scannable environment *) + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_1 in + let (_ : string) = Sys.opaque_identity padding_2 in + let (_ : string) = Sys.opaque_identity padding_3 in + let (_ : string) = Sys.opaque_identity padding_4 in + let (_ : string) = Sys.opaque_identity padding_5 in + let (_ : string) = Sys.opaque_identity padding_6 in + let (_ : string) = Sys.opaque_identity padding_7 in + let (_ : string) = Sys.opaque_identity padding_8 in + let (_ : string) = Sys.opaque_identity padding_9 in + let (_ : string) = Sys.opaque_identity padding_10 in + let (_ : string) = Sys.opaque_identity padding_11 in + let (_ : string) = Sys.opaque_identity padding_12 in + let (_ : string) = Sys.opaque_identity padding_13 in + let (_ : string) = Sys.opaque_identity padding_14 in + let (_ : string) = Sys.opaque_identity padding_15 in + let (_ : string) = Sys.opaque_identity padding_16 in + let (_ : string) = Sys.opaque_identity padding_17 in + let (_ : string) = Sys.opaque_identity padding_18 in + let (_ : string) = Sys.opaque_identity padding_19 in + let (_ : string) = Sys.opaque_identity padding_20 in + let (_ : string) = Sys.opaque_identity padding_21 in + let (_ : string) = Sys.opaque_identity padding_22 in + let (_ : string) = Sys.opaque_identity padding_23 in + let (_ : string) = Sys.opaque_identity padding_24 in + let (_ : string) = Sys.opaque_identity padding_25 in + let (_ : string) = Sys.opaque_identity padding_26 in + let (_ : string) = Sys.opaque_identity padding_27 in + let (_ : string) = Sys.opaque_identity padding_28 in + let (_ : string) = Sys.opaque_identity padding_29 in + let (_ : string) = Sys.opaque_identity padding_30 in + let (_ : string) = Sys.opaque_identity padding_31 in + let (_ : string) = Sys.opaque_identity padding_32 in + let (_ : string) = Sys.opaque_identity padding_33 in + let (_ : string) = Sys.opaque_identity padding_34 in + let (_ : string) = Sys.opaque_identity padding_35 in + let (_ : string) = Sys.opaque_identity padding_36 in + let (_ : string) = Sys.opaque_identity padding_37 in + let (_ : string) = Sys.opaque_identity padding_38 in + let (_ : string) = Sys.opaque_identity padding_39 in + let (_ : string) = Sys.opaque_identity padding_40 in + let (_ : string) = Sys.opaque_identity padding_41 in + let (_ : string) = Sys.opaque_identity padding_42 in + let (_ : string) = Sys.opaque_identity padding_43 in + let (_ : string) = Sys.opaque_identity padding_44 in + let (_ : string) = Sys.opaque_identity padding_45 in + let (_ : string) = Sys.opaque_identity padding_46 in + let (_ : string) = Sys.opaque_identity padding_47 in + let (_ : string) = Sys.opaque_identity padding_48 in + let (_ : string) = Sys.opaque_identity padding_49 in + let (_ : string) = Sys.opaque_identity padding_50 in + let (_ : string) = Sys.opaque_identity padding_51 in + let (_ : string) = Sys.opaque_identity padding_52 in + let (_ : string) = Sys.opaque_identity padding_53 in + let (_ : string) = Sys.opaque_identity padding_54 in + let (_ : string) = Sys.opaque_identity padding_55 in + let (_ : string) = Sys.opaque_identity padding_56 in + let (_ : string) = Sys.opaque_identity padding_57 in + let (_ : string) = Sys.opaque_identity padding_58 in + let (_ : string) = Sys.opaque_identity padding_59 in + let (_ : string) = Sys.opaque_identity padding_60 in + let (_ : string) = Sys.opaque_identity padding_61 in + let (_ : string) = Sys.opaque_identity padding_62 in + let (_ : string) = Sys.opaque_identity padding_63 in + let (_ : string) = Sys.opaque_identity padding_64 in + let (_ : string) = Sys.opaque_identity padding_65 in + let (_ : string) = Sys.opaque_identity padding_66 in + let (_ : string) = Sys.opaque_identity padding_67 in + let (_ : string) = Sys.opaque_identity padding_68 in + let (_ : string) = Sys.opaque_identity padding_69 in + let (_ : string) = Sys.opaque_identity padding_70 in + let (_ : string) = Sys.opaque_identity padding_71 in + let (_ : string) = Sys.opaque_identity padding_72 in + let (_ : string) = Sys.opaque_identity padding_73 in + let (_ : string) = Sys.opaque_identity padding_74 in + let (_ : string) = Sys.opaque_identity padding_75 in + let (_ : string) = Sys.opaque_identity padding_76 in + let (_ : string) = Sys.opaque_identity padding_77 in + let (_ : string) = Sys.opaque_identity padding_78 in + let (_ : string) = Sys.opaque_identity padding_79 in + let (_ : string) = Sys.opaque_identity padding_80 in + let (_ : string) = Sys.opaque_identity padding_81 in + let (_ : string) = Sys.opaque_identity padding_82 in + let (_ : string) = Sys.opaque_identity padding_83 in + let (_ : string) = Sys.opaque_identity padding_84 in + let (_ : string) = Sys.opaque_identity padding_85 in + let (_ : string) = Sys.opaque_identity padding_86 in + let (_ : string) = Sys.opaque_identity padding_87 in + let (_ : string) = Sys.opaque_identity padding_88 in + let (_ : string) = Sys.opaque_identity padding_89 in + let (_ : string) = Sys.opaque_identity padding_90 in + let (_ : string) = Sys.opaque_identity padding_91 in + let (_ : string) = Sys.opaque_identity padding_92 in + let (_ : string) = Sys.opaque_identity padding_93 in + let (_ : string) = Sys.opaque_identity padding_94 in + let (_ : string) = Sys.opaque_identity padding_95 in + let (_ : string) = Sys.opaque_identity padding_96 in + let (_ : string) = Sys.opaque_identity padding_97 in + let (_ : string) = Sys.opaque_identity padding_98 in + let (_ : string) = Sys.opaque_identity padding_99 in + let (_ : string) = Sys.opaque_identity padding_100 in + let (_ : string) = Sys.opaque_identity padding_101 in + let (_ : string) = Sys.opaque_identity padding_102 in + let (_ : string) = Sys.opaque_identity padding_103 in + let (_ : string) = Sys.opaque_identity padding_104 in + let (_ : string) = Sys.opaque_identity padding_105 in + let (_ : string) = Sys.opaque_identity padding_106 in + let (_ : string) = Sys.opaque_identity padding_107 in + let (_ : string) = Sys.opaque_identity padding_108 in + let (_ : string) = Sys.opaque_identity padding_109 in + let (_ : string) = Sys.opaque_identity padding_110 in + let (_ : string) = Sys.opaque_identity padding_111 in + let (_ : string) = Sys.opaque_identity padding_112 in + let (_ : string) = Sys.opaque_identity padding_113 in + let (_ : string) = Sys.opaque_identity padding_114 in + let (_ : string) = Sys.opaque_identity padding_115 in + let (_ : string) = Sys.opaque_identity padding_116 in + let (_ : string) = Sys.opaque_identity padding_117 in + let (_ : string) = Sys.opaque_identity padding_118 in + let (_ : string) = Sys.opaque_identity padding_119 in + let (_ : string) = Sys.opaque_identity padding_120 in + let (_ : string) = Sys.opaque_identity padding_121 in + let (_ : string) = Sys.opaque_identity padding_122 in + let (_ : string) = Sys.opaque_identity padding_123 in + let (_ : string) = Sys.opaque_identity padding_124 in + let (_ : string) = Sys.opaque_identity padding_125 in + let (_ : string) = Sys.opaque_identity padding_126 in + let (_ : string) = Sys.opaque_identity padding_127 in + let (_ : string) = Sys.opaque_identity padding_128 in + let (_ : string) = Sys.opaque_identity padding_129 in + let (_ : string) = Sys.opaque_identity padding_130 in + let (_ : string) = Sys.opaque_identity padding_131 in + let (_ : string) = Sys.opaque_identity padding_132 in + let (_ : string) = Sys.opaque_identity padding_133 in + let (_ : string) = Sys.opaque_identity padding_134 in + let (_ : string) = Sys.opaque_identity padding_135 in + let (_ : string) = Sys.opaque_identity padding_136 in + let (_ : string) = Sys.opaque_identity padding_137 in + let (_ : string) = Sys.opaque_identity padding_138 in + let (_ : string) = Sys.opaque_identity padding_139 in + let (_ : string) = Sys.opaque_identity padding_140 in + let (_ : string) = Sys.opaque_identity padding_141 in + let (_ : string) = Sys.opaque_identity padding_142 in + let (_ : string) = Sys.opaque_identity padding_143 in + let (_ : string) = Sys.opaque_identity padding_144 in + let (_ : string) = Sys.opaque_identity padding_145 in + let (_ : string) = Sys.opaque_identity padding_146 in + let (_ : string) = Sys.opaque_identity padding_147 in + let (_ : string) = Sys.opaque_identity padding_148 in + let (_ : string) = Sys.opaque_identity padding_149 in + let (_ : string) = Sys.opaque_identity padding_150 in + let (_ : string) = Sys.opaque_identity padding_151 in + let (_ : string) = Sys.opaque_identity padding_152 in + let (_ : string) = Sys.opaque_identity padding_153 in + let (_ : string) = Sys.opaque_identity padding_154 in + let (_ : string) = Sys.opaque_identity padding_155 in + let (_ : string) = Sys.opaque_identity padding_156 in + let (_ : string) = Sys.opaque_identity padding_157 in + let (_ : string) = Sys.opaque_identity padding_158 in + let (_ : string) = Sys.opaque_identity padding_159 in + let (_ : string) = Sys.opaque_identity padding_160 in + let (_ : string) = Sys.opaque_identity padding_161 in + let (_ : string) = Sys.opaque_identity padding_162 in + let (_ : string) = Sys.opaque_identity padding_163 in + let (_ : string) = Sys.opaque_identity padding_164 in + let (_ : string) = Sys.opaque_identity padding_165 in + let (_ : string) = Sys.opaque_identity padding_166 in + let (_ : string) = Sys.opaque_identity padding_167 in + let (_ : string) = Sys.opaque_identity padding_168 in + let (_ : string) = Sys.opaque_identity padding_169 in + let (_ : string) = Sys.opaque_identity padding_170 in + let (_ : string) = Sys.opaque_identity padding_171 in + let (_ : string) = Sys.opaque_identity padding_172 in + let (_ : string) = Sys.opaque_identity padding_173 in + let (_ : string) = Sys.opaque_identity padding_174 in + let (_ : string) = Sys.opaque_identity padding_175 in + let (_ : string) = Sys.opaque_identity padding_176 in + let (_ : string) = Sys.opaque_identity padding_177 in + let (_ : string) = Sys.opaque_identity padding_178 in + let (_ : string) = Sys.opaque_identity padding_179 in + let (_ : string) = Sys.opaque_identity padding_180 in + let (_ : string) = Sys.opaque_identity padding_181 in + let (_ : string) = Sys.opaque_identity padding_182 in + let (_ : string) = Sys.opaque_identity padding_183 in + let (_ : string) = Sys.opaque_identity padding_184 in + let (_ : string) = Sys.opaque_identity padding_185 in + let (_ : string) = Sys.opaque_identity padding_186 in + let (_ : string) = Sys.opaque_identity padding_187 in + let (_ : string) = Sys.opaque_identity padding_188 in + let (_ : string) = Sys.opaque_identity padding_189 in + let (_ : string) = Sys.opaque_identity padding_190 in + let (_ : string) = Sys.opaque_identity padding_191 in + let (_ : string) = Sys.opaque_identity padding_192 in + let (_ : string) = Sys.opaque_identity padding_193 in + let (_ : string) = Sys.opaque_identity padding_194 in + let (_ : string) = Sys.opaque_identity padding_195 in + let (_ : string) = Sys.opaque_identity padding_196 in + let (_ : string) = Sys.opaque_identity padding_197 in + let (_ : string) = Sys.opaque_identity padding_198 in + let (_ : string) = Sys.opaque_identity padding_199 in + let (_ : string) = Sys.opaque_identity padding_200 in + let (_ : string) = Sys.opaque_identity padding_201 in + let (_ : string) = Sys.opaque_identity padding_202 in + let (_ : string) = Sys.opaque_identity padding_203 in + let (_ : string) = Sys.opaque_identity padding_204 in + let (_ : string) = Sys.opaque_identity padding_205 in + let (_ : string) = Sys.opaque_identity padding_206 in + let (_ : string) = Sys.opaque_identity padding_207 in + let (_ : string) = Sys.opaque_identity padding_208 in + let (_ : string) = Sys.opaque_identity padding_209 in + let (_ : string) = Sys.opaque_identity padding_210 in + let (_ : string) = Sys.opaque_identity padding_211 in + let (_ : string) = Sys.opaque_identity padding_212 in + let (_ : string) = Sys.opaque_identity padding_213 in + let (_ : string) = Sys.opaque_identity padding_214 in + let (_ : string) = Sys.opaque_identity padding_215 in + let (_ : string) = Sys.opaque_identity padding_216 in + let (_ : string) = Sys.opaque_identity padding_217 in + let (_ : string) = Sys.opaque_identity padding_218 in + let (_ : string) = Sys.opaque_identity padding_219 in + let (_ : string) = Sys.opaque_identity padding_220 in + let (_ : string) = Sys.opaque_identity padding_221 in + let (_ : string) = Sys.opaque_identity padding_222 in + let (_ : string) = Sys.opaque_identity padding_223 in + let (_ : string) = Sys.opaque_identity padding_224 in + let (_ : string) = Sys.opaque_identity padding_225 in + let (_ : string) = Sys.opaque_identity padding_226 in + let (_ : string) = Sys.opaque_identity padding_227 in + let (_ : string) = Sys.opaque_identity padding_228 in + let (_ : string) = Sys.opaque_identity padding_229 in + let (_ : string) = Sys.opaque_identity padding_230 in + let (_ : string) = Sys.opaque_identity padding_231 in + let (_ : string) = Sys.opaque_identity padding_232 in + let (_ : string) = Sys.opaque_identity padding_233 in + let (_ : string) = Sys.opaque_identity padding_234 in + let (_ : string) = Sys.opaque_identity padding_235 in + let (_ : string) = Sys.opaque_identity padding_236 in + let (_ : string) = Sys.opaque_identity padding_237 in + let (_ : string) = Sys.opaque_identity padding_238 in + let (_ : string) = Sys.opaque_identity padding_239 in + let (_ : string) = Sys.opaque_identity padding_240 in + let (_ : string) = Sys.opaque_identity padding_241 in + let (_ : string) = Sys.opaque_identity padding_242 in + let (_ : string) = Sys.opaque_identity padding_243 in + let (_ : string) = Sys.opaque_identity padding_244 in + let (_ : string) = Sys.opaque_identity padding_245 in + let (_ : string) = Sys.opaque_identity padding_246 in + let (_ : string) = Sys.opaque_identity padding_247 in + let (_ : string) = Sys.opaque_identity padding_248 in + let (_ : string) = Sys.opaque_identity padding_249 in + let (_ : string) = Sys.opaque_identity padding_250 in + let (_ : string) = Sys.opaque_identity padding_251 in + let (_ : string) = Sys.opaque_identity padding_252 in + let (_ : string) = Sys.opaque_identity padding_253 in + let (_ : string) = Sys.opaque_identity padding_254 in + let (_ : string) = Sys.opaque_identity padding_255 in + let (_ : string) = Sys.opaque_identity padding_256 in + let (_ : string) = Sys.opaque_identity padding_257 in + let (_ : string) = Sys.opaque_identity padding_258 in + let (_ : string) = Sys.opaque_identity padding_259 in + let (_ : string) = Sys.opaque_identity padding_260 in + let (_ : string) = Sys.opaque_identity padding_261 in + let (_ : string) = Sys.opaque_identity padding_262 in + let (_ : string) = Sys.opaque_identity padding_263 in + let (_ : string) = Sys.opaque_identity padding_264 in + let (_ : string) = Sys.opaque_identity padding_265 in + let (_ : string) = Sys.opaque_identity padding_266 in + let (_ : string) = Sys.opaque_identity padding_267 in + let (_ : string) = Sys.opaque_identity padding_268 in + let (_ : string) = Sys.opaque_identity padding_269 in + let (_ : string) = Sys.opaque_identity padding_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + 200 + in + (* Cases to exercise [Infix_tag] logic *) + let[@opaque] rec rec_c1_1arg () = + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + i64_1 + and[@opaque] rec_c2_1arg () = + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + i64_2 + and[@opaque] rec_c3_1arg () = + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_1 in + let (_ : string) = Sys.opaque_identity padding_2 in + let (_ : string) = Sys.opaque_identity padding_3 in + let (_ : string) = Sys.opaque_identity padding_4 in + let (_ : string) = Sys.opaque_identity padding_5 in + let (_ : string) = Sys.opaque_identity padding_6 in + let (_ : string) = Sys.opaque_identity padding_7 in + let (_ : string) = Sys.opaque_identity padding_8 in + let (_ : string) = Sys.opaque_identity padding_9 in + let (_ : string) = Sys.opaque_identity padding_10 in + let (_ : string) = Sys.opaque_identity padding_11 in + let (_ : string) = Sys.opaque_identity padding_12 in + let (_ : string) = Sys.opaque_identity padding_13 in + let (_ : string) = Sys.opaque_identity padding_14 in + let (_ : string) = Sys.opaque_identity padding_15 in + let (_ : string) = Sys.opaque_identity padding_16 in + let (_ : string) = Sys.opaque_identity padding_17 in + let (_ : string) = Sys.opaque_identity padding_18 in + let (_ : string) = Sys.opaque_identity padding_19 in + let (_ : string) = Sys.opaque_identity padding_20 in + let (_ : string) = Sys.opaque_identity padding_21 in + let (_ : string) = Sys.opaque_identity padding_22 in + let (_ : string) = Sys.opaque_identity padding_23 in + let (_ : string) = Sys.opaque_identity padding_24 in + let (_ : string) = Sys.opaque_identity padding_25 in + let (_ : string) = Sys.opaque_identity padding_26 in + let (_ : string) = Sys.opaque_identity padding_27 in + let (_ : string) = Sys.opaque_identity padding_28 in + let (_ : string) = Sys.opaque_identity padding_29 in + let (_ : string) = Sys.opaque_identity padding_30 in + let (_ : string) = Sys.opaque_identity padding_31 in + let (_ : string) = Sys.opaque_identity padding_32 in + let (_ : string) = Sys.opaque_identity padding_33 in + let (_ : string) = Sys.opaque_identity padding_34 in + let (_ : string) = Sys.opaque_identity padding_35 in + let (_ : string) = Sys.opaque_identity padding_36 in + let (_ : string) = Sys.opaque_identity padding_37 in + let (_ : string) = Sys.opaque_identity padding_38 in + let (_ : string) = Sys.opaque_identity padding_39 in + let (_ : string) = Sys.opaque_identity padding_40 in + let (_ : string) = Sys.opaque_identity padding_41 in + let (_ : string) = Sys.opaque_identity padding_42 in + let (_ : string) = Sys.opaque_identity padding_43 in + let (_ : string) = Sys.opaque_identity padding_44 in + let (_ : string) = Sys.opaque_identity padding_45 in + let (_ : string) = Sys.opaque_identity padding_46 in + let (_ : string) = Sys.opaque_identity padding_47 in + let (_ : string) = Sys.opaque_identity padding_48 in + let (_ : string) = Sys.opaque_identity padding_49 in + let (_ : string) = Sys.opaque_identity padding_50 in + let (_ : string) = Sys.opaque_identity padding_51 in + let (_ : string) = Sys.opaque_identity padding_52 in + let (_ : string) = Sys.opaque_identity padding_53 in + let (_ : string) = Sys.opaque_identity padding_54 in + let (_ : string) = Sys.opaque_identity padding_55 in + let (_ : string) = Sys.opaque_identity padding_56 in + let (_ : string) = Sys.opaque_identity padding_57 in + let (_ : string) = Sys.opaque_identity padding_58 in + let (_ : string) = Sys.opaque_identity padding_59 in + let (_ : string) = Sys.opaque_identity padding_60 in + let (_ : string) = Sys.opaque_identity padding_61 in + let (_ : string) = Sys.opaque_identity padding_62 in + let (_ : string) = Sys.opaque_identity padding_63 in + let (_ : string) = Sys.opaque_identity padding_64 in + let (_ : string) = Sys.opaque_identity padding_65 in + let (_ : string) = Sys.opaque_identity padding_66 in + let (_ : string) = Sys.opaque_identity padding_67 in + let (_ : string) = Sys.opaque_identity padding_68 in + let (_ : string) = Sys.opaque_identity padding_69 in + let (_ : string) = Sys.opaque_identity padding_70 in + let (_ : string) = Sys.opaque_identity padding_71 in + let (_ : string) = Sys.opaque_identity padding_72 in + let (_ : string) = Sys.opaque_identity padding_73 in + let (_ : string) = Sys.opaque_identity padding_74 in + let (_ : string) = Sys.opaque_identity padding_75 in + let (_ : string) = Sys.opaque_identity padding_76 in + let (_ : string) = Sys.opaque_identity padding_77 in + let (_ : string) = Sys.opaque_identity padding_78 in + let (_ : string) = Sys.opaque_identity padding_79 in + let (_ : string) = Sys.opaque_identity padding_80 in + let (_ : string) = Sys.opaque_identity padding_81 in + let (_ : string) = Sys.opaque_identity padding_82 in + let (_ : string) = Sys.opaque_identity padding_83 in + let (_ : string) = Sys.opaque_identity padding_84 in + let (_ : string) = Sys.opaque_identity padding_85 in + let (_ : string) = Sys.opaque_identity padding_86 in + let (_ : string) = Sys.opaque_identity padding_87 in + let (_ : string) = Sys.opaque_identity padding_88 in + let (_ : string) = Sys.opaque_identity padding_89 in + let (_ : string) = Sys.opaque_identity padding_90 in + let (_ : string) = Sys.opaque_identity padding_91 in + let (_ : string) = Sys.opaque_identity padding_92 in + let (_ : string) = Sys.opaque_identity padding_93 in + let (_ : string) = Sys.opaque_identity padding_94 in + let (_ : string) = Sys.opaque_identity padding_95 in + let (_ : string) = Sys.opaque_identity padding_96 in + let (_ : string) = Sys.opaque_identity padding_97 in + let (_ : string) = Sys.opaque_identity padding_98 in + let (_ : string) = Sys.opaque_identity padding_99 in + let (_ : string) = Sys.opaque_identity padding_100 in + let (_ : string) = Sys.opaque_identity padding_101 in + let (_ : string) = Sys.opaque_identity padding_102 in + let (_ : string) = Sys.opaque_identity padding_103 in + let (_ : string) = Sys.opaque_identity padding_104 in + let (_ : string) = Sys.opaque_identity padding_105 in + let (_ : string) = Sys.opaque_identity padding_106 in + let (_ : string) = Sys.opaque_identity padding_107 in + let (_ : string) = Sys.opaque_identity padding_108 in + let (_ : string) = Sys.opaque_identity padding_109 in + let (_ : string) = Sys.opaque_identity padding_110 in + let (_ : string) = Sys.opaque_identity padding_111 in + let (_ : string) = Sys.opaque_identity padding_112 in + let (_ : string) = Sys.opaque_identity padding_113 in + let (_ : string) = Sys.opaque_identity padding_114 in + let (_ : string) = Sys.opaque_identity padding_115 in + let (_ : string) = Sys.opaque_identity padding_116 in + let (_ : string) = Sys.opaque_identity padding_117 in + let (_ : string) = Sys.opaque_identity padding_118 in + let (_ : string) = Sys.opaque_identity padding_119 in + let (_ : string) = Sys.opaque_identity padding_120 in + let (_ : string) = Sys.opaque_identity padding_121 in + let (_ : string) = Sys.opaque_identity padding_122 in + let (_ : string) = Sys.opaque_identity padding_123 in + let (_ : string) = Sys.opaque_identity padding_124 in + let (_ : string) = Sys.opaque_identity padding_125 in + let (_ : string) = Sys.opaque_identity padding_126 in + let (_ : string) = Sys.opaque_identity padding_127 in + let (_ : string) = Sys.opaque_identity padding_128 in + let (_ : string) = Sys.opaque_identity padding_129 in + let (_ : string) = Sys.opaque_identity padding_130 in + let (_ : string) = Sys.opaque_identity padding_131 in + let (_ : string) = Sys.opaque_identity padding_132 in + let (_ : string) = Sys.opaque_identity padding_133 in + let (_ : string) = Sys.opaque_identity padding_134 in + let (_ : string) = Sys.opaque_identity padding_135 in + let (_ : string) = Sys.opaque_identity padding_136 in + let (_ : string) = Sys.opaque_identity padding_137 in + let (_ : string) = Sys.opaque_identity padding_138 in + let (_ : string) = Sys.opaque_identity padding_139 in + let (_ : string) = Sys.opaque_identity padding_140 in + let (_ : string) = Sys.opaque_identity padding_141 in + let (_ : string) = Sys.opaque_identity padding_142 in + let (_ : string) = Sys.opaque_identity padding_143 in + let (_ : string) = Sys.opaque_identity padding_144 in + let (_ : string) = Sys.opaque_identity padding_145 in + let (_ : string) = Sys.opaque_identity padding_146 in + let (_ : string) = Sys.opaque_identity padding_147 in + let (_ : string) = Sys.opaque_identity padding_148 in + let (_ : string) = Sys.opaque_identity padding_149 in + let (_ : string) = Sys.opaque_identity padding_150 in + let (_ : string) = Sys.opaque_identity padding_151 in + let (_ : string) = Sys.opaque_identity padding_152 in + let (_ : string) = Sys.opaque_identity padding_153 in + let (_ : string) = Sys.opaque_identity padding_154 in + let (_ : string) = Sys.opaque_identity padding_155 in + let (_ : string) = Sys.opaque_identity padding_156 in + let (_ : string) = Sys.opaque_identity padding_157 in + let (_ : string) = Sys.opaque_identity padding_158 in + let (_ : string) = Sys.opaque_identity padding_159 in + let (_ : string) = Sys.opaque_identity padding_160 in + let (_ : string) = Sys.opaque_identity padding_161 in + let (_ : string) = Sys.opaque_identity padding_162 in + let (_ : string) = Sys.opaque_identity padding_163 in + let (_ : string) = Sys.opaque_identity padding_164 in + let (_ : string) = Sys.opaque_identity padding_165 in + let (_ : string) = Sys.opaque_identity padding_166 in + let (_ : string) = Sys.opaque_identity padding_167 in + let (_ : string) = Sys.opaque_identity padding_168 in + let (_ : string) = Sys.opaque_identity padding_169 in + let (_ : string) = Sys.opaque_identity padding_170 in + let (_ : string) = Sys.opaque_identity padding_171 in + let (_ : string) = Sys.opaque_identity padding_172 in + let (_ : string) = Sys.opaque_identity padding_173 in + let (_ : string) = Sys.opaque_identity padding_174 in + let (_ : string) = Sys.opaque_identity padding_175 in + let (_ : string) = Sys.opaque_identity padding_176 in + let (_ : string) = Sys.opaque_identity padding_177 in + let (_ : string) = Sys.opaque_identity padding_178 in + let (_ : string) = Sys.opaque_identity padding_179 in + let (_ : string) = Sys.opaque_identity padding_180 in + let (_ : string) = Sys.opaque_identity padding_181 in + let (_ : string) = Sys.opaque_identity padding_182 in + let (_ : string) = Sys.opaque_identity padding_183 in + let (_ : string) = Sys.opaque_identity padding_184 in + let (_ : string) = Sys.opaque_identity padding_185 in + let (_ : string) = Sys.opaque_identity padding_186 in + let (_ : string) = Sys.opaque_identity padding_187 in + let (_ : string) = Sys.opaque_identity padding_188 in + let (_ : string) = Sys.opaque_identity padding_189 in + let (_ : string) = Sys.opaque_identity padding_190 in + let (_ : string) = Sys.opaque_identity padding_191 in + let (_ : string) = Sys.opaque_identity padding_192 in + let (_ : string) = Sys.opaque_identity padding_193 in + let (_ : string) = Sys.opaque_identity padding_194 in + let (_ : string) = Sys.opaque_identity padding_195 in + let (_ : string) = Sys.opaque_identity padding_196 in + let (_ : string) = Sys.opaque_identity padding_197 in + let (_ : string) = Sys.opaque_identity padding_198 in + let (_ : string) = Sys.opaque_identity padding_199 in + let (_ : string) = Sys.opaque_identity padding_200 in + let (_ : string) = Sys.opaque_identity padding_201 in + let (_ : string) = Sys.opaque_identity padding_202 in + let (_ : string) = Sys.opaque_identity padding_203 in + let (_ : string) = Sys.opaque_identity padding_204 in + let (_ : string) = Sys.opaque_identity padding_205 in + let (_ : string) = Sys.opaque_identity padding_206 in + let (_ : string) = Sys.opaque_identity padding_207 in + let (_ : string) = Sys.opaque_identity padding_208 in + let (_ : string) = Sys.opaque_identity padding_209 in + let (_ : string) = Sys.opaque_identity padding_210 in + let (_ : string) = Sys.opaque_identity padding_211 in + let (_ : string) = Sys.opaque_identity padding_212 in + let (_ : string) = Sys.opaque_identity padding_213 in + let (_ : string) = Sys.opaque_identity padding_214 in + let (_ : string) = Sys.opaque_identity padding_215 in + let (_ : string) = Sys.opaque_identity padding_216 in + let (_ : string) = Sys.opaque_identity padding_217 in + let (_ : string) = Sys.opaque_identity padding_218 in + let (_ : string) = Sys.opaque_identity padding_219 in + let (_ : string) = Sys.opaque_identity padding_220 in + let (_ : string) = Sys.opaque_identity padding_221 in + let (_ : string) = Sys.opaque_identity padding_222 in + let (_ : string) = Sys.opaque_identity padding_223 in + let (_ : string) = Sys.opaque_identity padding_224 in + let (_ : string) = Sys.opaque_identity padding_225 in + let (_ : string) = Sys.opaque_identity padding_226 in + let (_ : string) = Sys.opaque_identity padding_227 in + let (_ : string) = Sys.opaque_identity padding_228 in + let (_ : string) = Sys.opaque_identity padding_229 in + let (_ : string) = Sys.opaque_identity padding_230 in + let (_ : string) = Sys.opaque_identity padding_231 in + let (_ : string) = Sys.opaque_identity padding_232 in + let (_ : string) = Sys.opaque_identity padding_233 in + let (_ : string) = Sys.opaque_identity padding_234 in + let (_ : string) = Sys.opaque_identity padding_235 in + let (_ : string) = Sys.opaque_identity padding_236 in + let (_ : string) = Sys.opaque_identity padding_237 in + let (_ : string) = Sys.opaque_identity padding_238 in + let (_ : string) = Sys.opaque_identity padding_239 in + let (_ : string) = Sys.opaque_identity padding_240 in + let (_ : string) = Sys.opaque_identity padding_241 in + let (_ : string) = Sys.opaque_identity padding_242 in + let (_ : string) = Sys.opaque_identity padding_243 in + let (_ : string) = Sys.opaque_identity padding_244 in + let (_ : string) = Sys.opaque_identity padding_245 in + let (_ : string) = Sys.opaque_identity padding_246 in + let (_ : string) = Sys.opaque_identity padding_247 in + let (_ : string) = Sys.opaque_identity padding_248 in + let (_ : string) = Sys.opaque_identity padding_249 in + let (_ : string) = Sys.opaque_identity padding_250 in + let (_ : string) = Sys.opaque_identity padding_251 in + let (_ : string) = Sys.opaque_identity padding_252 in + let (_ : string) = Sys.opaque_identity padding_253 in + let (_ : string) = Sys.opaque_identity padding_254 in + let (_ : string) = Sys.opaque_identity padding_255 in + let (_ : string) = Sys.opaque_identity padding_256 in + let (_ : string) = Sys.opaque_identity padding_257 in + let (_ : string) = Sys.opaque_identity padding_258 in + let (_ : string) = Sys.opaque_identity padding_259 in + let (_ : string) = Sys.opaque_identity padding_260 in + let (_ : string) = Sys.opaque_identity padding_261 in + let (_ : string) = Sys.opaque_identity padding_262 in + let (_ : string) = Sys.opaque_identity padding_263 in + let (_ : string) = Sys.opaque_identity padding_264 in + let (_ : string) = Sys.opaque_identity padding_265 in + let (_ : string) = Sys.opaque_identity padding_266 in + let (_ : string) = Sys.opaque_identity padding_267 in + let (_ : string) = Sys.opaque_identity padding_268 in + let (_ : string) = Sys.opaque_identity padding_269 in + let (_ : string) = Sys.opaque_identity padding_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + 300 + and[@opaque] rec_c1_2arg () () = + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + let (_ : int64#) = Sys.opaque_identity i64_3 in + rec_c1_1arg () + and[@opaque] rec_c2_2arg () () = + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_0 in + let (_ : int64#) = Sys.opaque_identity padding_i64_1 in + let (_ : int64#) = Sys.opaque_identity padding_i64_2 in + let (_ : int64#) = Sys.opaque_identity padding_i64_3 in + let (_ : int64#) = Sys.opaque_identity padding_i64_4 in + let (_ : int64#) = Sys.opaque_identity padding_i64_5 in + let (_ : int64#) = Sys.opaque_identity padding_i64_6 in + let (_ : int64#) = Sys.opaque_identity padding_i64_7 in + let (_ : int64#) = Sys.opaque_identity padding_i64_8 in + let (_ : int64#) = Sys.opaque_identity padding_i64_9 in + let (_ : int64#) = Sys.opaque_identity padding_i64_10 in + let (_ : int64#) = Sys.opaque_identity padding_i64_11 in + let (_ : int64#) = Sys.opaque_identity padding_i64_12 in + let (_ : int64#) = Sys.opaque_identity padding_i64_13 in + let (_ : int64#) = Sys.opaque_identity padding_i64_14 in + let (_ : int64#) = Sys.opaque_identity padding_i64_15 in + let (_ : int64#) = Sys.opaque_identity padding_i64_16 in + let (_ : int64#) = Sys.opaque_identity padding_i64_17 in + let (_ : int64#) = Sys.opaque_identity padding_i64_18 in + let (_ : int64#) = Sys.opaque_identity padding_i64_19 in + let (_ : int64#) = Sys.opaque_identity padding_i64_20 in + let (_ : int64#) = Sys.opaque_identity padding_i64_21 in + let (_ : int64#) = Sys.opaque_identity padding_i64_22 in + let (_ : int64#) = Sys.opaque_identity padding_i64_23 in + let (_ : int64#) = Sys.opaque_identity padding_i64_24 in + let (_ : int64#) = Sys.opaque_identity padding_i64_25 in + let (_ : int64#) = Sys.opaque_identity padding_i64_26 in + let (_ : int64#) = Sys.opaque_identity padding_i64_27 in + let (_ : int64#) = Sys.opaque_identity padding_i64_28 in + let (_ : int64#) = Sys.opaque_identity padding_i64_29 in + let (_ : int64#) = Sys.opaque_identity padding_i64_30 in + let (_ : int64#) = Sys.opaque_identity padding_i64_31 in + let (_ : int64#) = Sys.opaque_identity padding_i64_32 in + let (_ : int64#) = Sys.opaque_identity padding_i64_33 in + let (_ : int64#) = Sys.opaque_identity padding_i64_34 in + let (_ : int64#) = Sys.opaque_identity padding_i64_35 in + let (_ : int64#) = Sys.opaque_identity padding_i64_36 in + let (_ : int64#) = Sys.opaque_identity padding_i64_37 in + let (_ : int64#) = Sys.opaque_identity padding_i64_38 in + let (_ : int64#) = Sys.opaque_identity padding_i64_39 in + let (_ : int64#) = Sys.opaque_identity padding_i64_40 in + let (_ : int64#) = Sys.opaque_identity padding_i64_41 in + let (_ : int64#) = Sys.opaque_identity padding_i64_42 in + let (_ : int64#) = Sys.opaque_identity padding_i64_43 in + let (_ : int64#) = Sys.opaque_identity padding_i64_44 in + let (_ : int64#) = Sys.opaque_identity padding_i64_45 in + let (_ : int64#) = Sys.opaque_identity padding_i64_46 in + let (_ : int64#) = Sys.opaque_identity padding_i64_47 in + let (_ : int64#) = Sys.opaque_identity padding_i64_48 in + let (_ : int64#) = Sys.opaque_identity padding_i64_49 in + let (_ : int64#) = Sys.opaque_identity padding_i64_50 in + let (_ : int64#) = Sys.opaque_identity padding_i64_51 in + let (_ : int64#) = Sys.opaque_identity padding_i64_52 in + let (_ : int64#) = Sys.opaque_identity padding_i64_53 in + let (_ : int64#) = Sys.opaque_identity padding_i64_54 in + let (_ : int64#) = Sys.opaque_identity padding_i64_55 in + let (_ : int64#) = Sys.opaque_identity padding_i64_56 in + let (_ : int64#) = Sys.opaque_identity padding_i64_57 in + let (_ : int64#) = Sys.opaque_identity padding_i64_58 in + let (_ : int64#) = Sys.opaque_identity padding_i64_59 in + let (_ : int64#) = Sys.opaque_identity padding_i64_60 in + let (_ : int64#) = Sys.opaque_identity padding_i64_61 in + let (_ : int64#) = Sys.opaque_identity padding_i64_62 in + let (_ : int64#) = Sys.opaque_identity padding_i64_63 in + let (_ : int64#) = Sys.opaque_identity padding_i64_64 in + let (_ : int64#) = Sys.opaque_identity padding_i64_65 in + let (_ : int64#) = Sys.opaque_identity padding_i64_66 in + let (_ : int64#) = Sys.opaque_identity padding_i64_67 in + let (_ : int64#) = Sys.opaque_identity padding_i64_68 in + let (_ : int64#) = Sys.opaque_identity padding_i64_69 in + let (_ : int64#) = Sys.opaque_identity padding_i64_70 in + let (_ : int64#) = Sys.opaque_identity padding_i64_71 in + let (_ : int64#) = Sys.opaque_identity padding_i64_72 in + let (_ : int64#) = Sys.opaque_identity padding_i64_73 in + let (_ : int64#) = Sys.opaque_identity padding_i64_74 in + let (_ : int64#) = Sys.opaque_identity padding_i64_75 in + let (_ : int64#) = Sys.opaque_identity padding_i64_76 in + let (_ : int64#) = Sys.opaque_identity padding_i64_77 in + let (_ : int64#) = Sys.opaque_identity padding_i64_78 in + let (_ : int64#) = Sys.opaque_identity padding_i64_79 in + let (_ : int64#) = Sys.opaque_identity padding_i64_80 in + let (_ : int64#) = Sys.opaque_identity padding_i64_81 in + let (_ : int64#) = Sys.opaque_identity padding_i64_82 in + let (_ : int64#) = Sys.opaque_identity padding_i64_83 in + let (_ : int64#) = Sys.opaque_identity padding_i64_84 in + let (_ : int64#) = Sys.opaque_identity padding_i64_85 in + let (_ : int64#) = Sys.opaque_identity padding_i64_86 in + let (_ : int64#) = Sys.opaque_identity padding_i64_87 in + let (_ : int64#) = Sys.opaque_identity padding_i64_88 in + let (_ : int64#) = Sys.opaque_identity padding_i64_89 in + let (_ : int64#) = Sys.opaque_identity padding_i64_90 in + let (_ : int64#) = Sys.opaque_identity padding_i64_91 in + let (_ : int64#) = Sys.opaque_identity padding_i64_92 in + let (_ : int64#) = Sys.opaque_identity padding_i64_93 in + let (_ : int64#) = Sys.opaque_identity padding_i64_94 in + let (_ : int64#) = Sys.opaque_identity padding_i64_95 in + let (_ : int64#) = Sys.opaque_identity padding_i64_96 in + let (_ : int64#) = Sys.opaque_identity padding_i64_97 in + let (_ : int64#) = Sys.opaque_identity padding_i64_98 in + let (_ : int64#) = Sys.opaque_identity padding_i64_99 in + let (_ : int64#) = Sys.opaque_identity padding_i64_100 in + let (_ : int64#) = Sys.opaque_identity padding_i64_101 in + let (_ : int64#) = Sys.opaque_identity padding_i64_102 in + let (_ : int64#) = Sys.opaque_identity padding_i64_103 in + let (_ : int64#) = Sys.opaque_identity padding_i64_104 in + let (_ : int64#) = Sys.opaque_identity padding_i64_105 in + let (_ : int64#) = Sys.opaque_identity padding_i64_106 in + let (_ : int64#) = Sys.opaque_identity padding_i64_107 in + let (_ : int64#) = Sys.opaque_identity padding_i64_108 in + let (_ : int64#) = Sys.opaque_identity padding_i64_109 in + let (_ : int64#) = Sys.opaque_identity padding_i64_110 in + let (_ : int64#) = Sys.opaque_identity padding_i64_111 in + let (_ : int64#) = Sys.opaque_identity padding_i64_112 in + let (_ : int64#) = Sys.opaque_identity padding_i64_113 in + let (_ : int64#) = Sys.opaque_identity padding_i64_114 in + let (_ : int64#) = Sys.opaque_identity padding_i64_115 in + let (_ : int64#) = Sys.opaque_identity padding_i64_116 in + let (_ : int64#) = Sys.opaque_identity padding_i64_117 in + let (_ : int64#) = Sys.opaque_identity padding_i64_118 in + let (_ : int64#) = Sys.opaque_identity padding_i64_119 in + let (_ : int64#) = Sys.opaque_identity padding_i64_120 in + let (_ : int64#) = Sys.opaque_identity padding_i64_121 in + let (_ : int64#) = Sys.opaque_identity padding_i64_122 in + let (_ : int64#) = Sys.opaque_identity padding_i64_123 in + let (_ : int64#) = Sys.opaque_identity padding_i64_124 in + let (_ : int64#) = Sys.opaque_identity padding_i64_125 in + let (_ : int64#) = Sys.opaque_identity padding_i64_126 in + let (_ : int64#) = Sys.opaque_identity padding_i64_127 in + let (_ : int64#) = Sys.opaque_identity padding_i64_128 in + let (_ : int64#) = Sys.opaque_identity padding_i64_129 in + let (_ : int64#) = Sys.opaque_identity padding_i64_130 in + let (_ : int64#) = Sys.opaque_identity padding_i64_131 in + let (_ : int64#) = Sys.opaque_identity padding_i64_132 in + let (_ : int64#) = Sys.opaque_identity padding_i64_133 in + let (_ : int64#) = Sys.opaque_identity padding_i64_134 in + let (_ : int64#) = Sys.opaque_identity padding_i64_135 in + let (_ : int64#) = Sys.opaque_identity padding_i64_136 in + let (_ : int64#) = Sys.opaque_identity padding_i64_137 in + let (_ : int64#) = Sys.opaque_identity padding_i64_138 in + let (_ : int64#) = Sys.opaque_identity padding_i64_139 in + let (_ : int64#) = Sys.opaque_identity padding_i64_140 in + let (_ : int64#) = Sys.opaque_identity padding_i64_141 in + let (_ : int64#) = Sys.opaque_identity padding_i64_142 in + let (_ : int64#) = Sys.opaque_identity padding_i64_143 in + let (_ : int64#) = Sys.opaque_identity padding_i64_144 in + let (_ : int64#) = Sys.opaque_identity padding_i64_145 in + let (_ : int64#) = Sys.opaque_identity padding_i64_146 in + let (_ : int64#) = Sys.opaque_identity padding_i64_147 in + let (_ : int64#) = Sys.opaque_identity padding_i64_148 in + let (_ : int64#) = Sys.opaque_identity padding_i64_149 in + let (_ : int64#) = Sys.opaque_identity padding_i64_150 in + let (_ : int64#) = Sys.opaque_identity padding_i64_151 in + let (_ : int64#) = Sys.opaque_identity padding_i64_152 in + let (_ : int64#) = Sys.opaque_identity padding_i64_153 in + let (_ : int64#) = Sys.opaque_identity padding_i64_154 in + let (_ : int64#) = Sys.opaque_identity padding_i64_155 in + let (_ : int64#) = Sys.opaque_identity padding_i64_156 in + let (_ : int64#) = Sys.opaque_identity padding_i64_157 in + let (_ : int64#) = Sys.opaque_identity padding_i64_158 in + let (_ : int64#) = Sys.opaque_identity padding_i64_159 in + let (_ : int64#) = Sys.opaque_identity padding_i64_160 in + let (_ : int64#) = Sys.opaque_identity padding_i64_161 in + let (_ : int64#) = Sys.opaque_identity padding_i64_162 in + let (_ : int64#) = Sys.opaque_identity padding_i64_163 in + let (_ : int64#) = Sys.opaque_identity padding_i64_164 in + let (_ : int64#) = Sys.opaque_identity padding_i64_165 in + let (_ : int64#) = Sys.opaque_identity padding_i64_166 in + let (_ : int64#) = Sys.opaque_identity padding_i64_167 in + let (_ : int64#) = Sys.opaque_identity padding_i64_168 in + let (_ : int64#) = Sys.opaque_identity padding_i64_169 in + let (_ : int64#) = Sys.opaque_identity padding_i64_170 in + let (_ : int64#) = Sys.opaque_identity padding_i64_171 in + let (_ : int64#) = Sys.opaque_identity padding_i64_172 in + let (_ : int64#) = Sys.opaque_identity padding_i64_173 in + let (_ : int64#) = Sys.opaque_identity padding_i64_174 in + let (_ : int64#) = Sys.opaque_identity padding_i64_175 in + let (_ : int64#) = Sys.opaque_identity padding_i64_176 in + let (_ : int64#) = Sys.opaque_identity padding_i64_177 in + let (_ : int64#) = Sys.opaque_identity padding_i64_178 in + let (_ : int64#) = Sys.opaque_identity padding_i64_179 in + let (_ : int64#) = Sys.opaque_identity padding_i64_180 in + let (_ : int64#) = Sys.opaque_identity padding_i64_181 in + let (_ : int64#) = Sys.opaque_identity padding_i64_182 in + let (_ : int64#) = Sys.opaque_identity padding_i64_183 in + let (_ : int64#) = Sys.opaque_identity padding_i64_184 in + let (_ : int64#) = Sys.opaque_identity padding_i64_185 in + let (_ : int64#) = Sys.opaque_identity padding_i64_186 in + let (_ : int64#) = Sys.opaque_identity padding_i64_187 in + let (_ : int64#) = Sys.opaque_identity padding_i64_188 in + let (_ : int64#) = Sys.opaque_identity padding_i64_189 in + let (_ : int64#) = Sys.opaque_identity padding_i64_190 in + let (_ : int64#) = Sys.opaque_identity padding_i64_191 in + let (_ : int64#) = Sys.opaque_identity padding_i64_192 in + let (_ : int64#) = Sys.opaque_identity padding_i64_193 in + let (_ : int64#) = Sys.opaque_identity padding_i64_194 in + let (_ : int64#) = Sys.opaque_identity padding_i64_195 in + let (_ : int64#) = Sys.opaque_identity padding_i64_196 in + let (_ : int64#) = Sys.opaque_identity padding_i64_197 in + let (_ : int64#) = Sys.opaque_identity padding_i64_198 in + let (_ : int64#) = Sys.opaque_identity padding_i64_199 in + let (_ : int64#) = Sys.opaque_identity padding_i64_200 in + let (_ : int64#) = Sys.opaque_identity padding_i64_201 in + let (_ : int64#) = Sys.opaque_identity padding_i64_202 in + let (_ : int64#) = Sys.opaque_identity padding_i64_203 in + let (_ : int64#) = Sys.opaque_identity padding_i64_204 in + let (_ : int64#) = Sys.opaque_identity padding_i64_205 in + let (_ : int64#) = Sys.opaque_identity padding_i64_206 in + let (_ : int64#) = Sys.opaque_identity padding_i64_207 in + let (_ : int64#) = Sys.opaque_identity padding_i64_208 in + let (_ : int64#) = Sys.opaque_identity padding_i64_209 in + let (_ : int64#) = Sys.opaque_identity padding_i64_210 in + let (_ : int64#) = Sys.opaque_identity padding_i64_211 in + let (_ : int64#) = Sys.opaque_identity padding_i64_212 in + let (_ : int64#) = Sys.opaque_identity padding_i64_213 in + let (_ : int64#) = Sys.opaque_identity padding_i64_214 in + let (_ : int64#) = Sys.opaque_identity padding_i64_215 in + let (_ : int64#) = Sys.opaque_identity padding_i64_216 in + let (_ : int64#) = Sys.opaque_identity padding_i64_217 in + let (_ : int64#) = Sys.opaque_identity padding_i64_218 in + let (_ : int64#) = Sys.opaque_identity padding_i64_219 in + let (_ : int64#) = Sys.opaque_identity padding_i64_220 in + let (_ : int64#) = Sys.opaque_identity padding_i64_221 in + let (_ : int64#) = Sys.opaque_identity padding_i64_222 in + let (_ : int64#) = Sys.opaque_identity padding_i64_223 in + let (_ : int64#) = Sys.opaque_identity padding_i64_224 in + let (_ : int64#) = Sys.opaque_identity padding_i64_225 in + let (_ : int64#) = Sys.opaque_identity padding_i64_226 in + let (_ : int64#) = Sys.opaque_identity padding_i64_227 in + let (_ : int64#) = Sys.opaque_identity padding_i64_228 in + let (_ : int64#) = Sys.opaque_identity padding_i64_229 in + let (_ : int64#) = Sys.opaque_identity padding_i64_230 in + let (_ : int64#) = Sys.opaque_identity padding_i64_231 in + let (_ : int64#) = Sys.opaque_identity padding_i64_232 in + let (_ : int64#) = Sys.opaque_identity padding_i64_233 in + let (_ : int64#) = Sys.opaque_identity padding_i64_234 in + let (_ : int64#) = Sys.opaque_identity padding_i64_235 in + let (_ : int64#) = Sys.opaque_identity padding_i64_236 in + let (_ : int64#) = Sys.opaque_identity padding_i64_237 in + let (_ : int64#) = Sys.opaque_identity padding_i64_238 in + let (_ : int64#) = Sys.opaque_identity padding_i64_239 in + let (_ : int64#) = Sys.opaque_identity padding_i64_240 in + let (_ : int64#) = Sys.opaque_identity padding_i64_241 in + let (_ : int64#) = Sys.opaque_identity padding_i64_242 in + let (_ : int64#) = Sys.opaque_identity padding_i64_243 in + let (_ : int64#) = Sys.opaque_identity padding_i64_244 in + let (_ : int64#) = Sys.opaque_identity padding_i64_245 in + let (_ : int64#) = Sys.opaque_identity padding_i64_246 in + let (_ : int64#) = Sys.opaque_identity padding_i64_247 in + let (_ : int64#) = Sys.opaque_identity padding_i64_248 in + let (_ : int64#) = Sys.opaque_identity padding_i64_249 in + let (_ : int64#) = Sys.opaque_identity padding_i64_250 in + let (_ : int64#) = Sys.opaque_identity padding_i64_251 in + let (_ : int64#) = Sys.opaque_identity padding_i64_252 in + let (_ : int64#) = Sys.opaque_identity padding_i64_253 in + let (_ : int64#) = Sys.opaque_identity padding_i64_254 in + let (_ : int64#) = Sys.opaque_identity padding_i64_255 in + let (_ : int64#) = Sys.opaque_identity padding_i64_256 in + let (_ : int64#) = Sys.opaque_identity padding_i64_257 in + let (_ : int64#) = Sys.opaque_identity padding_i64_258 in + let (_ : int64#) = Sys.opaque_identity padding_i64_259 in + let (_ : int64#) = Sys.opaque_identity padding_i64_260 in + let (_ : int64#) = Sys.opaque_identity padding_i64_261 in + let (_ : int64#) = Sys.opaque_identity padding_i64_262 in + let (_ : int64#) = Sys.opaque_identity padding_i64_263 in + let (_ : int64#) = Sys.opaque_identity padding_i64_264 in + let (_ : int64#) = Sys.opaque_identity padding_i64_265 in + let (_ : int64#) = Sys.opaque_identity padding_i64_266 in + let (_ : int64#) = Sys.opaque_identity padding_i64_267 in + let (_ : int64#) = Sys.opaque_identity padding_i64_268 in + let (_ : int64#) = Sys.opaque_identity padding_i64_269 in + let (_ : int64#) = Sys.opaque_identity padding_i64_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + let (_ : int64#) = Sys.opaque_identity i64_4 in + rec_c2_1arg () + and[@opaque] rec_c3_2arg () () = + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_0 in + let (_ : string) = Sys.opaque_identity padding_1 in + let (_ : string) = Sys.opaque_identity padding_2 in + let (_ : string) = Sys.opaque_identity padding_3 in + let (_ : string) = Sys.opaque_identity padding_4 in + let (_ : string) = Sys.opaque_identity padding_5 in + let (_ : string) = Sys.opaque_identity padding_6 in + let (_ : string) = Sys.opaque_identity padding_7 in + let (_ : string) = Sys.opaque_identity padding_8 in + let (_ : string) = Sys.opaque_identity padding_9 in + let (_ : string) = Sys.opaque_identity padding_10 in + let (_ : string) = Sys.opaque_identity padding_11 in + let (_ : string) = Sys.opaque_identity padding_12 in + let (_ : string) = Sys.opaque_identity padding_13 in + let (_ : string) = Sys.opaque_identity padding_14 in + let (_ : string) = Sys.opaque_identity padding_15 in + let (_ : string) = Sys.opaque_identity padding_16 in + let (_ : string) = Sys.opaque_identity padding_17 in + let (_ : string) = Sys.opaque_identity padding_18 in + let (_ : string) = Sys.opaque_identity padding_19 in + let (_ : string) = Sys.opaque_identity padding_20 in + let (_ : string) = Sys.opaque_identity padding_21 in + let (_ : string) = Sys.opaque_identity padding_22 in + let (_ : string) = Sys.opaque_identity padding_23 in + let (_ : string) = Sys.opaque_identity padding_24 in + let (_ : string) = Sys.opaque_identity padding_25 in + let (_ : string) = Sys.opaque_identity padding_26 in + let (_ : string) = Sys.opaque_identity padding_27 in + let (_ : string) = Sys.opaque_identity padding_28 in + let (_ : string) = Sys.opaque_identity padding_29 in + let (_ : string) = Sys.opaque_identity padding_30 in + let (_ : string) = Sys.opaque_identity padding_31 in + let (_ : string) = Sys.opaque_identity padding_32 in + let (_ : string) = Sys.opaque_identity padding_33 in + let (_ : string) = Sys.opaque_identity padding_34 in + let (_ : string) = Sys.opaque_identity padding_35 in + let (_ : string) = Sys.opaque_identity padding_36 in + let (_ : string) = Sys.opaque_identity padding_37 in + let (_ : string) = Sys.opaque_identity padding_38 in + let (_ : string) = Sys.opaque_identity padding_39 in + let (_ : string) = Sys.opaque_identity padding_40 in + let (_ : string) = Sys.opaque_identity padding_41 in + let (_ : string) = Sys.opaque_identity padding_42 in + let (_ : string) = Sys.opaque_identity padding_43 in + let (_ : string) = Sys.opaque_identity padding_44 in + let (_ : string) = Sys.opaque_identity padding_45 in + let (_ : string) = Sys.opaque_identity padding_46 in + let (_ : string) = Sys.opaque_identity padding_47 in + let (_ : string) = Sys.opaque_identity padding_48 in + let (_ : string) = Sys.opaque_identity padding_49 in + let (_ : string) = Sys.opaque_identity padding_50 in + let (_ : string) = Sys.opaque_identity padding_51 in + let (_ : string) = Sys.opaque_identity padding_52 in + let (_ : string) = Sys.opaque_identity padding_53 in + let (_ : string) = Sys.opaque_identity padding_54 in + let (_ : string) = Sys.opaque_identity padding_55 in + let (_ : string) = Sys.opaque_identity padding_56 in + let (_ : string) = Sys.opaque_identity padding_57 in + let (_ : string) = Sys.opaque_identity padding_58 in + let (_ : string) = Sys.opaque_identity padding_59 in + let (_ : string) = Sys.opaque_identity padding_60 in + let (_ : string) = Sys.opaque_identity padding_61 in + let (_ : string) = Sys.opaque_identity padding_62 in + let (_ : string) = Sys.opaque_identity padding_63 in + let (_ : string) = Sys.opaque_identity padding_64 in + let (_ : string) = Sys.opaque_identity padding_65 in + let (_ : string) = Sys.opaque_identity padding_66 in + let (_ : string) = Sys.opaque_identity padding_67 in + let (_ : string) = Sys.opaque_identity padding_68 in + let (_ : string) = Sys.opaque_identity padding_69 in + let (_ : string) = Sys.opaque_identity padding_70 in + let (_ : string) = Sys.opaque_identity padding_71 in + let (_ : string) = Sys.opaque_identity padding_72 in + let (_ : string) = Sys.opaque_identity padding_73 in + let (_ : string) = Sys.opaque_identity padding_74 in + let (_ : string) = Sys.opaque_identity padding_75 in + let (_ : string) = Sys.opaque_identity padding_76 in + let (_ : string) = Sys.opaque_identity padding_77 in + let (_ : string) = Sys.opaque_identity padding_78 in + let (_ : string) = Sys.opaque_identity padding_79 in + let (_ : string) = Sys.opaque_identity padding_80 in + let (_ : string) = Sys.opaque_identity padding_81 in + let (_ : string) = Sys.opaque_identity padding_82 in + let (_ : string) = Sys.opaque_identity padding_83 in + let (_ : string) = Sys.opaque_identity padding_84 in + let (_ : string) = Sys.opaque_identity padding_85 in + let (_ : string) = Sys.opaque_identity padding_86 in + let (_ : string) = Sys.opaque_identity padding_87 in + let (_ : string) = Sys.opaque_identity padding_88 in + let (_ : string) = Sys.opaque_identity padding_89 in + let (_ : string) = Sys.opaque_identity padding_90 in + let (_ : string) = Sys.opaque_identity padding_91 in + let (_ : string) = Sys.opaque_identity padding_92 in + let (_ : string) = Sys.opaque_identity padding_93 in + let (_ : string) = Sys.opaque_identity padding_94 in + let (_ : string) = Sys.opaque_identity padding_95 in + let (_ : string) = Sys.opaque_identity padding_96 in + let (_ : string) = Sys.opaque_identity padding_97 in + let (_ : string) = Sys.opaque_identity padding_98 in + let (_ : string) = Sys.opaque_identity padding_99 in + let (_ : string) = Sys.opaque_identity padding_100 in + let (_ : string) = Sys.opaque_identity padding_101 in + let (_ : string) = Sys.opaque_identity padding_102 in + let (_ : string) = Sys.opaque_identity padding_103 in + let (_ : string) = Sys.opaque_identity padding_104 in + let (_ : string) = Sys.opaque_identity padding_105 in + let (_ : string) = Sys.opaque_identity padding_106 in + let (_ : string) = Sys.opaque_identity padding_107 in + let (_ : string) = Sys.opaque_identity padding_108 in + let (_ : string) = Sys.opaque_identity padding_109 in + let (_ : string) = Sys.opaque_identity padding_110 in + let (_ : string) = Sys.opaque_identity padding_111 in + let (_ : string) = Sys.opaque_identity padding_112 in + let (_ : string) = Sys.opaque_identity padding_113 in + let (_ : string) = Sys.opaque_identity padding_114 in + let (_ : string) = Sys.opaque_identity padding_115 in + let (_ : string) = Sys.opaque_identity padding_116 in + let (_ : string) = Sys.opaque_identity padding_117 in + let (_ : string) = Sys.opaque_identity padding_118 in + let (_ : string) = Sys.opaque_identity padding_119 in + let (_ : string) = Sys.opaque_identity padding_120 in + let (_ : string) = Sys.opaque_identity padding_121 in + let (_ : string) = Sys.opaque_identity padding_122 in + let (_ : string) = Sys.opaque_identity padding_123 in + let (_ : string) = Sys.opaque_identity padding_124 in + let (_ : string) = Sys.opaque_identity padding_125 in + let (_ : string) = Sys.opaque_identity padding_126 in + let (_ : string) = Sys.opaque_identity padding_127 in + let (_ : string) = Sys.opaque_identity padding_128 in + let (_ : string) = Sys.opaque_identity padding_129 in + let (_ : string) = Sys.opaque_identity padding_130 in + let (_ : string) = Sys.opaque_identity padding_131 in + let (_ : string) = Sys.opaque_identity padding_132 in + let (_ : string) = Sys.opaque_identity padding_133 in + let (_ : string) = Sys.opaque_identity padding_134 in + let (_ : string) = Sys.opaque_identity padding_135 in + let (_ : string) = Sys.opaque_identity padding_136 in + let (_ : string) = Sys.opaque_identity padding_137 in + let (_ : string) = Sys.opaque_identity padding_138 in + let (_ : string) = Sys.opaque_identity padding_139 in + let (_ : string) = Sys.opaque_identity padding_140 in + let (_ : string) = Sys.opaque_identity padding_141 in + let (_ : string) = Sys.opaque_identity padding_142 in + let (_ : string) = Sys.opaque_identity padding_143 in + let (_ : string) = Sys.opaque_identity padding_144 in + let (_ : string) = Sys.opaque_identity padding_145 in + let (_ : string) = Sys.opaque_identity padding_146 in + let (_ : string) = Sys.opaque_identity padding_147 in + let (_ : string) = Sys.opaque_identity padding_148 in + let (_ : string) = Sys.opaque_identity padding_149 in + let (_ : string) = Sys.opaque_identity padding_150 in + let (_ : string) = Sys.opaque_identity padding_151 in + let (_ : string) = Sys.opaque_identity padding_152 in + let (_ : string) = Sys.opaque_identity padding_153 in + let (_ : string) = Sys.opaque_identity padding_154 in + let (_ : string) = Sys.opaque_identity padding_155 in + let (_ : string) = Sys.opaque_identity padding_156 in + let (_ : string) = Sys.opaque_identity padding_157 in + let (_ : string) = Sys.opaque_identity padding_158 in + let (_ : string) = Sys.opaque_identity padding_159 in + let (_ : string) = Sys.opaque_identity padding_160 in + let (_ : string) = Sys.opaque_identity padding_161 in + let (_ : string) = Sys.opaque_identity padding_162 in + let (_ : string) = Sys.opaque_identity padding_163 in + let (_ : string) = Sys.opaque_identity padding_164 in + let (_ : string) = Sys.opaque_identity padding_165 in + let (_ : string) = Sys.opaque_identity padding_166 in + let (_ : string) = Sys.opaque_identity padding_167 in + let (_ : string) = Sys.opaque_identity padding_168 in + let (_ : string) = Sys.opaque_identity padding_169 in + let (_ : string) = Sys.opaque_identity padding_170 in + let (_ : string) = Sys.opaque_identity padding_171 in + let (_ : string) = Sys.opaque_identity padding_172 in + let (_ : string) = Sys.opaque_identity padding_173 in + let (_ : string) = Sys.opaque_identity padding_174 in + let (_ : string) = Sys.opaque_identity padding_175 in + let (_ : string) = Sys.opaque_identity padding_176 in + let (_ : string) = Sys.opaque_identity padding_177 in + let (_ : string) = Sys.opaque_identity padding_178 in + let (_ : string) = Sys.opaque_identity padding_179 in + let (_ : string) = Sys.opaque_identity padding_180 in + let (_ : string) = Sys.opaque_identity padding_181 in + let (_ : string) = Sys.opaque_identity padding_182 in + let (_ : string) = Sys.opaque_identity padding_183 in + let (_ : string) = Sys.opaque_identity padding_184 in + let (_ : string) = Sys.opaque_identity padding_185 in + let (_ : string) = Sys.opaque_identity padding_186 in + let (_ : string) = Sys.opaque_identity padding_187 in + let (_ : string) = Sys.opaque_identity padding_188 in + let (_ : string) = Sys.opaque_identity padding_189 in + let (_ : string) = Sys.opaque_identity padding_190 in + let (_ : string) = Sys.opaque_identity padding_191 in + let (_ : string) = Sys.opaque_identity padding_192 in + let (_ : string) = Sys.opaque_identity padding_193 in + let (_ : string) = Sys.opaque_identity padding_194 in + let (_ : string) = Sys.opaque_identity padding_195 in + let (_ : string) = Sys.opaque_identity padding_196 in + let (_ : string) = Sys.opaque_identity padding_197 in + let (_ : string) = Sys.opaque_identity padding_198 in + let (_ : string) = Sys.opaque_identity padding_199 in + let (_ : string) = Sys.opaque_identity padding_200 in + let (_ : string) = Sys.opaque_identity padding_201 in + let (_ : string) = Sys.opaque_identity padding_202 in + let (_ : string) = Sys.opaque_identity padding_203 in + let (_ : string) = Sys.opaque_identity padding_204 in + let (_ : string) = Sys.opaque_identity padding_205 in + let (_ : string) = Sys.opaque_identity padding_206 in + let (_ : string) = Sys.opaque_identity padding_207 in + let (_ : string) = Sys.opaque_identity padding_208 in + let (_ : string) = Sys.opaque_identity padding_209 in + let (_ : string) = Sys.opaque_identity padding_210 in + let (_ : string) = Sys.opaque_identity padding_211 in + let (_ : string) = Sys.opaque_identity padding_212 in + let (_ : string) = Sys.opaque_identity padding_213 in + let (_ : string) = Sys.opaque_identity padding_214 in + let (_ : string) = Sys.opaque_identity padding_215 in + let (_ : string) = Sys.opaque_identity padding_216 in + let (_ : string) = Sys.opaque_identity padding_217 in + let (_ : string) = Sys.opaque_identity padding_218 in + let (_ : string) = Sys.opaque_identity padding_219 in + let (_ : string) = Sys.opaque_identity padding_220 in + let (_ : string) = Sys.opaque_identity padding_221 in + let (_ : string) = Sys.opaque_identity padding_222 in + let (_ : string) = Sys.opaque_identity padding_223 in + let (_ : string) = Sys.opaque_identity padding_224 in + let (_ : string) = Sys.opaque_identity padding_225 in + let (_ : string) = Sys.opaque_identity padding_226 in + let (_ : string) = Sys.opaque_identity padding_227 in + let (_ : string) = Sys.opaque_identity padding_228 in + let (_ : string) = Sys.opaque_identity padding_229 in + let (_ : string) = Sys.opaque_identity padding_230 in + let (_ : string) = Sys.opaque_identity padding_231 in + let (_ : string) = Sys.opaque_identity padding_232 in + let (_ : string) = Sys.opaque_identity padding_233 in + let (_ : string) = Sys.opaque_identity padding_234 in + let (_ : string) = Sys.opaque_identity padding_235 in + let (_ : string) = Sys.opaque_identity padding_236 in + let (_ : string) = Sys.opaque_identity padding_237 in + let (_ : string) = Sys.opaque_identity padding_238 in + let (_ : string) = Sys.opaque_identity padding_239 in + let (_ : string) = Sys.opaque_identity padding_240 in + let (_ : string) = Sys.opaque_identity padding_241 in + let (_ : string) = Sys.opaque_identity padding_242 in + let (_ : string) = Sys.opaque_identity padding_243 in + let (_ : string) = Sys.opaque_identity padding_244 in + let (_ : string) = Sys.opaque_identity padding_245 in + let (_ : string) = Sys.opaque_identity padding_246 in + let (_ : string) = Sys.opaque_identity padding_247 in + let (_ : string) = Sys.opaque_identity padding_248 in + let (_ : string) = Sys.opaque_identity padding_249 in + let (_ : string) = Sys.opaque_identity padding_250 in + let (_ : string) = Sys.opaque_identity padding_251 in + let (_ : string) = Sys.opaque_identity padding_252 in + let (_ : string) = Sys.opaque_identity padding_253 in + let (_ : string) = Sys.opaque_identity padding_254 in + let (_ : string) = Sys.opaque_identity padding_255 in + let (_ : string) = Sys.opaque_identity padding_256 in + let (_ : string) = Sys.opaque_identity padding_257 in + let (_ : string) = Sys.opaque_identity padding_258 in + let (_ : string) = Sys.opaque_identity padding_259 in + let (_ : string) = Sys.opaque_identity padding_260 in + let (_ : string) = Sys.opaque_identity padding_261 in + let (_ : string) = Sys.opaque_identity padding_262 in + let (_ : string) = Sys.opaque_identity padding_263 in + let (_ : string) = Sys.opaque_identity padding_264 in + let (_ : string) = Sys.opaque_identity padding_265 in + let (_ : string) = Sys.opaque_identity padding_266 in + let (_ : string) = Sys.opaque_identity padding_267 in + let (_ : string) = Sys.opaque_identity padding_268 in + let (_ : string) = Sys.opaque_identity padding_269 in + let (_ : string) = Sys.opaque_identity padding_270 in + let (_i : int) = Sys.opaque_identity (String.length x) in + rec_c3_1arg () + in + ( c1_1arg, + c2_1arg, + c3_1arg, + c1_2arg, + c2_2arg, + c3_2arg, + rec_c1_1arg, + rec_c2_1arg, + rec_c3_1arg, + rec_c1_2arg, + rec_c2_2arg, + rec_c3_2arg ) + +let check_one_large_closures () = + let i64_1 = rand_near_minor_heap () in + let i64_2 = rand_near_minor_heap () in + let i64_3 = rand_near_minor_heap () in + let i64_4 = rand_near_minor_heap () in + let padding_i64_0 = rand_near_minor_heap () in + let padding_i64_1 = rand_near_minor_heap () in + let padding_i64_2 = rand_near_minor_heap () in + let padding_i64_3 = rand_near_minor_heap () in + let padding_i64_4 = rand_near_minor_heap () in + let padding_i64_5 = rand_near_minor_heap () in + let padding_i64_6 = rand_near_minor_heap () in + let padding_i64_7 = rand_near_minor_heap () in + let padding_i64_8 = rand_near_minor_heap () in + let padding_i64_9 = rand_near_minor_heap () in + let padding_i64_10 = rand_near_minor_heap () in + let padding_i64_11 = rand_near_minor_heap () in + let padding_i64_12 = rand_near_minor_heap () in + let padding_i64_13 = rand_near_minor_heap () in + let padding_i64_14 = rand_near_minor_heap () in + let padding_i64_15 = rand_near_minor_heap () in + let padding_i64_16 = rand_near_minor_heap () in + let padding_i64_17 = rand_near_minor_heap () in + let padding_i64_18 = rand_near_minor_heap () in + let padding_i64_19 = rand_near_minor_heap () in + let padding_i64_20 = rand_near_minor_heap () in + let padding_i64_21 = rand_near_minor_heap () in + let padding_i64_22 = rand_near_minor_heap () in + let padding_i64_23 = rand_near_minor_heap () in + let padding_i64_24 = rand_near_minor_heap () in + let padding_i64_25 = rand_near_minor_heap () in + let padding_i64_26 = rand_near_minor_heap () in + let padding_i64_27 = rand_near_minor_heap () in + let padding_i64_28 = rand_near_minor_heap () in + let padding_i64_29 = rand_near_minor_heap () in + let padding_i64_30 = rand_near_minor_heap () in + let padding_i64_31 = rand_near_minor_heap () in + let padding_i64_32 = rand_near_minor_heap () in + let padding_i64_33 = rand_near_minor_heap () in + let padding_i64_34 = rand_near_minor_heap () in + let padding_i64_35 = rand_near_minor_heap () in + let padding_i64_36 = rand_near_minor_heap () in + let padding_i64_37 = rand_near_minor_heap () in + let padding_i64_38 = rand_near_minor_heap () in + let padding_i64_39 = rand_near_minor_heap () in + let padding_i64_40 = rand_near_minor_heap () in + let padding_i64_41 = rand_near_minor_heap () in + let padding_i64_42 = rand_near_minor_heap () in + let padding_i64_43 = rand_near_minor_heap () in + let padding_i64_44 = rand_near_minor_heap () in + let padding_i64_45 = rand_near_minor_heap () in + let padding_i64_46 = rand_near_minor_heap () in + let padding_i64_47 = rand_near_minor_heap () in + let padding_i64_48 = rand_near_minor_heap () in + let padding_i64_49 = rand_near_minor_heap () in + let padding_i64_50 = rand_near_minor_heap () in + let padding_i64_51 = rand_near_minor_heap () in + let padding_i64_52 = rand_near_minor_heap () in + let padding_i64_53 = rand_near_minor_heap () in + let padding_i64_54 = rand_near_minor_heap () in + let padding_i64_55 = rand_near_minor_heap () in + let padding_i64_56 = rand_near_minor_heap () in + let padding_i64_57 = rand_near_minor_heap () in + let padding_i64_58 = rand_near_minor_heap () in + let padding_i64_59 = rand_near_minor_heap () in + let padding_i64_60 = rand_near_minor_heap () in + let padding_i64_61 = rand_near_minor_heap () in + let padding_i64_62 = rand_near_minor_heap () in + let padding_i64_63 = rand_near_minor_heap () in + let padding_i64_64 = rand_near_minor_heap () in + let padding_i64_65 = rand_near_minor_heap () in + let padding_i64_66 = rand_near_minor_heap () in + let padding_i64_67 = rand_near_minor_heap () in + let padding_i64_68 = rand_near_minor_heap () in + let padding_i64_69 = rand_near_minor_heap () in + let padding_i64_70 = rand_near_minor_heap () in + let padding_i64_71 = rand_near_minor_heap () in + let padding_i64_72 = rand_near_minor_heap () in + let padding_i64_73 = rand_near_minor_heap () in + let padding_i64_74 = rand_near_minor_heap () in + let padding_i64_75 = rand_near_minor_heap () in + let padding_i64_76 = rand_near_minor_heap () in + let padding_i64_77 = rand_near_minor_heap () in + let padding_i64_78 = rand_near_minor_heap () in + let padding_i64_79 = rand_near_minor_heap () in + let padding_i64_80 = rand_near_minor_heap () in + let padding_i64_81 = rand_near_minor_heap () in + let padding_i64_82 = rand_near_minor_heap () in + let padding_i64_83 = rand_near_minor_heap () in + let padding_i64_84 = rand_near_minor_heap () in + let padding_i64_85 = rand_near_minor_heap () in + let padding_i64_86 = rand_near_minor_heap () in + let padding_i64_87 = rand_near_minor_heap () in + let padding_i64_88 = rand_near_minor_heap () in + let padding_i64_89 = rand_near_minor_heap () in + let padding_i64_90 = rand_near_minor_heap () in + let padding_i64_91 = rand_near_minor_heap () in + let padding_i64_92 = rand_near_minor_heap () in + let padding_i64_93 = rand_near_minor_heap () in + let padding_i64_94 = rand_near_minor_heap () in + let padding_i64_95 = rand_near_minor_heap () in + let padding_i64_96 = rand_near_minor_heap () in + let padding_i64_97 = rand_near_minor_heap () in + let padding_i64_98 = rand_near_minor_heap () in + let padding_i64_99 = rand_near_minor_heap () in + let padding_i64_100 = rand_near_minor_heap () in + let padding_i64_101 = rand_near_minor_heap () in + let padding_i64_102 = rand_near_minor_heap () in + let padding_i64_103 = rand_near_minor_heap () in + let padding_i64_104 = rand_near_minor_heap () in + let padding_i64_105 = rand_near_minor_heap () in + let padding_i64_106 = rand_near_minor_heap () in + let padding_i64_107 = rand_near_minor_heap () in + let padding_i64_108 = rand_near_minor_heap () in + let padding_i64_109 = rand_near_minor_heap () in + let padding_i64_110 = rand_near_minor_heap () in + let padding_i64_111 = rand_near_minor_heap () in + let padding_i64_112 = rand_near_minor_heap () in + let padding_i64_113 = rand_near_minor_heap () in + let padding_i64_114 = rand_near_minor_heap () in + let padding_i64_115 = rand_near_minor_heap () in + let padding_i64_116 = rand_near_minor_heap () in + let padding_i64_117 = rand_near_minor_heap () in + let padding_i64_118 = rand_near_minor_heap () in + let padding_i64_119 = rand_near_minor_heap () in + let padding_i64_120 = rand_near_minor_heap () in + let padding_i64_121 = rand_near_minor_heap () in + let padding_i64_122 = rand_near_minor_heap () in + let padding_i64_123 = rand_near_minor_heap () in + let padding_i64_124 = rand_near_minor_heap () in + let padding_i64_125 = rand_near_minor_heap () in + let padding_i64_126 = rand_near_minor_heap () in + let padding_i64_127 = rand_near_minor_heap () in + let padding_i64_128 = rand_near_minor_heap () in + let padding_i64_129 = rand_near_minor_heap () in + let padding_i64_130 = rand_near_minor_heap () in + let padding_i64_131 = rand_near_minor_heap () in + let padding_i64_132 = rand_near_minor_heap () in + let padding_i64_133 = rand_near_minor_heap () in + let padding_i64_134 = rand_near_minor_heap () in + let padding_i64_135 = rand_near_minor_heap () in + let padding_i64_136 = rand_near_minor_heap () in + let padding_i64_137 = rand_near_minor_heap () in + let padding_i64_138 = rand_near_minor_heap () in + let padding_i64_139 = rand_near_minor_heap () in + let padding_i64_140 = rand_near_minor_heap () in + let padding_i64_141 = rand_near_minor_heap () in + let padding_i64_142 = rand_near_minor_heap () in + let padding_i64_143 = rand_near_minor_heap () in + let padding_i64_144 = rand_near_minor_heap () in + let padding_i64_145 = rand_near_minor_heap () in + let padding_i64_146 = rand_near_minor_heap () in + let padding_i64_147 = rand_near_minor_heap () in + let padding_i64_148 = rand_near_minor_heap () in + let padding_i64_149 = rand_near_minor_heap () in + let padding_i64_150 = rand_near_minor_heap () in + let padding_i64_151 = rand_near_minor_heap () in + let padding_i64_152 = rand_near_minor_heap () in + let padding_i64_153 = rand_near_minor_heap () in + let padding_i64_154 = rand_near_minor_heap () in + let padding_i64_155 = rand_near_minor_heap () in + let padding_i64_156 = rand_near_minor_heap () in + let padding_i64_157 = rand_near_minor_heap () in + let padding_i64_158 = rand_near_minor_heap () in + let padding_i64_159 = rand_near_minor_heap () in + let padding_i64_160 = rand_near_minor_heap () in + let padding_i64_161 = rand_near_minor_heap () in + let padding_i64_162 = rand_near_minor_heap () in + let padding_i64_163 = rand_near_minor_heap () in + let padding_i64_164 = rand_near_minor_heap () in + let padding_i64_165 = rand_near_minor_heap () in + let padding_i64_166 = rand_near_minor_heap () in + let padding_i64_167 = rand_near_minor_heap () in + let padding_i64_168 = rand_near_minor_heap () in + let padding_i64_169 = rand_near_minor_heap () in + let padding_i64_170 = rand_near_minor_heap () in + let padding_i64_171 = rand_near_minor_heap () in + let padding_i64_172 = rand_near_minor_heap () in + let padding_i64_173 = rand_near_minor_heap () in + let padding_i64_174 = rand_near_minor_heap () in + let padding_i64_175 = rand_near_minor_heap () in + let padding_i64_176 = rand_near_minor_heap () in + let padding_i64_177 = rand_near_minor_heap () in + let padding_i64_178 = rand_near_minor_heap () in + let padding_i64_179 = rand_near_minor_heap () in + let padding_i64_180 = rand_near_minor_heap () in + let padding_i64_181 = rand_near_minor_heap () in + let padding_i64_182 = rand_near_minor_heap () in + let padding_i64_183 = rand_near_minor_heap () in + let padding_i64_184 = rand_near_minor_heap () in + let padding_i64_185 = rand_near_minor_heap () in + let padding_i64_186 = rand_near_minor_heap () in + let padding_i64_187 = rand_near_minor_heap () in + let padding_i64_188 = rand_near_minor_heap () in + let padding_i64_189 = rand_near_minor_heap () in + let padding_i64_190 = rand_near_minor_heap () in + let padding_i64_191 = rand_near_minor_heap () in + let padding_i64_192 = rand_near_minor_heap () in + let padding_i64_193 = rand_near_minor_heap () in + let padding_i64_194 = rand_near_minor_heap () in + let padding_i64_195 = rand_near_minor_heap () in + let padding_i64_196 = rand_near_minor_heap () in + let padding_i64_197 = rand_near_minor_heap () in + let padding_i64_198 = rand_near_minor_heap () in + let padding_i64_199 = rand_near_minor_heap () in + let padding_i64_200 = rand_near_minor_heap () in + let padding_i64_201 = rand_near_minor_heap () in + let padding_i64_202 = rand_near_minor_heap () in + let padding_i64_203 = rand_near_minor_heap () in + let padding_i64_204 = rand_near_minor_heap () in + let padding_i64_205 = rand_near_minor_heap () in + let padding_i64_206 = rand_near_minor_heap () in + let padding_i64_207 = rand_near_minor_heap () in + let padding_i64_208 = rand_near_minor_heap () in + let padding_i64_209 = rand_near_minor_heap () in + let padding_i64_210 = rand_near_minor_heap () in + let padding_i64_211 = rand_near_minor_heap () in + let padding_i64_212 = rand_near_minor_heap () in + let padding_i64_213 = rand_near_minor_heap () in + let padding_i64_214 = rand_near_minor_heap () in + let padding_i64_215 = rand_near_minor_heap () in + let padding_i64_216 = rand_near_minor_heap () in + let padding_i64_217 = rand_near_minor_heap () in + let padding_i64_218 = rand_near_minor_heap () in + let padding_i64_219 = rand_near_minor_heap () in + let padding_i64_220 = rand_near_minor_heap () in + let padding_i64_221 = rand_near_minor_heap () in + let padding_i64_222 = rand_near_minor_heap () in + let padding_i64_223 = rand_near_minor_heap () in + let padding_i64_224 = rand_near_minor_heap () in + let padding_i64_225 = rand_near_minor_heap () in + let padding_i64_226 = rand_near_minor_heap () in + let padding_i64_227 = rand_near_minor_heap () in + let padding_i64_228 = rand_near_minor_heap () in + let padding_i64_229 = rand_near_minor_heap () in + let padding_i64_230 = rand_near_minor_heap () in + let padding_i64_231 = rand_near_minor_heap () in + let padding_i64_232 = rand_near_minor_heap () in + let padding_i64_233 = rand_near_minor_heap () in + let padding_i64_234 = rand_near_minor_heap () in + let padding_i64_235 = rand_near_minor_heap () in + let padding_i64_236 = rand_near_minor_heap () in + let padding_i64_237 = rand_near_minor_heap () in + let padding_i64_238 = rand_near_minor_heap () in + let padding_i64_239 = rand_near_minor_heap () in + let padding_i64_240 = rand_near_minor_heap () in + let padding_i64_241 = rand_near_minor_heap () in + let padding_i64_242 = rand_near_minor_heap () in + let padding_i64_243 = rand_near_minor_heap () in + let padding_i64_244 = rand_near_minor_heap () in + let padding_i64_245 = rand_near_minor_heap () in + let padding_i64_246 = rand_near_minor_heap () in + let padding_i64_247 = rand_near_minor_heap () in + let padding_i64_248 = rand_near_minor_heap () in + let padding_i64_249 = rand_near_minor_heap () in + let padding_i64_250 = rand_near_minor_heap () in + let padding_i64_251 = rand_near_minor_heap () in + let padding_i64_252 = rand_near_minor_heap () in + let padding_i64_253 = rand_near_minor_heap () in + let padding_i64_254 = rand_near_minor_heap () in + let padding_i64_255 = rand_near_minor_heap () in + let padding_i64_256 = rand_near_minor_heap () in + let padding_i64_257 = rand_near_minor_heap () in + let padding_i64_258 = rand_near_minor_heap () in + let padding_i64_259 = rand_near_minor_heap () in + let padding_i64_260 = rand_near_minor_heap () in + let padding_i64_261 = rand_near_minor_heap () in + let padding_i64_262 = rand_near_minor_heap () in + let padding_i64_263 = rand_near_minor_heap () in + let padding_i64_264 = rand_near_minor_heap () in + let padding_i64_265 = rand_near_minor_heap () in + let padding_i64_266 = rand_near_minor_heap () in + let padding_i64_267 = rand_near_minor_heap () in + let padding_i64_268 = rand_near_minor_heap () in + let padding_i64_269 = rand_near_minor_heap () in + let padding_i64_270 = rand_near_minor_heap () in + let padding_0 = rand_string () in + let padding_1 = rand_string () in + let padding_2 = rand_string () in + let padding_3 = rand_string () in + let padding_4 = rand_string () in + let padding_5 = rand_string () in + let padding_6 = rand_string () in + let padding_7 = rand_string () in + let padding_8 = rand_string () in + let padding_9 = rand_string () in + let padding_10 = rand_string () in + let padding_11 = rand_string () in + let padding_12 = rand_string () in + let padding_13 = rand_string () in + let padding_14 = rand_string () in + let padding_15 = rand_string () in + let padding_16 = rand_string () in + let padding_17 = rand_string () in + let padding_18 = rand_string () in + let padding_19 = rand_string () in + let padding_20 = rand_string () in + let padding_21 = rand_string () in + let padding_22 = rand_string () in + let padding_23 = rand_string () in + let padding_24 = rand_string () in + let padding_25 = rand_string () in + let padding_26 = rand_string () in + let padding_27 = rand_string () in + let padding_28 = rand_string () in + let padding_29 = rand_string () in + let padding_30 = rand_string () in + let padding_31 = rand_string () in + let padding_32 = rand_string () in + let padding_33 = rand_string () in + let padding_34 = rand_string () in + let padding_35 = rand_string () in + let padding_36 = rand_string () in + let padding_37 = rand_string () in + let padding_38 = rand_string () in + let padding_39 = rand_string () in + let padding_40 = rand_string () in + let padding_41 = rand_string () in + let padding_42 = rand_string () in + let padding_43 = rand_string () in + let padding_44 = rand_string () in + let padding_45 = rand_string () in + let padding_46 = rand_string () in + let padding_47 = rand_string () in + let padding_48 = rand_string () in + let padding_49 = rand_string () in + let padding_50 = rand_string () in + let padding_51 = rand_string () in + let padding_52 = rand_string () in + let padding_53 = rand_string () in + let padding_54 = rand_string () in + let padding_55 = rand_string () in + let padding_56 = rand_string () in + let padding_57 = rand_string () in + let padding_58 = rand_string () in + let padding_59 = rand_string () in + let padding_60 = rand_string () in + let padding_61 = rand_string () in + let padding_62 = rand_string () in + let padding_63 = rand_string () in + let padding_64 = rand_string () in + let padding_65 = rand_string () in + let padding_66 = rand_string () in + let padding_67 = rand_string () in + let padding_68 = rand_string () in + let padding_69 = rand_string () in + let padding_70 = rand_string () in + let padding_71 = rand_string () in + let padding_72 = rand_string () in + let padding_73 = rand_string () in + let padding_74 = rand_string () in + let padding_75 = rand_string () in + let padding_76 = rand_string () in + let padding_77 = rand_string () in + let padding_78 = rand_string () in + let padding_79 = rand_string () in + let padding_80 = rand_string () in + let padding_81 = rand_string () in + let padding_82 = rand_string () in + let padding_83 = rand_string () in + let padding_84 = rand_string () in + let padding_85 = rand_string () in + let padding_86 = rand_string () in + let padding_87 = rand_string () in + let padding_88 = rand_string () in + let padding_89 = rand_string () in + let padding_90 = rand_string () in + let padding_91 = rand_string () in + let padding_92 = rand_string () in + let padding_93 = rand_string () in + let padding_94 = rand_string () in + let padding_95 = rand_string () in + let padding_96 = rand_string () in + let padding_97 = rand_string () in + let padding_98 = rand_string () in + let padding_99 = rand_string () in + let padding_100 = rand_string () in + let padding_101 = rand_string () in + let padding_102 = rand_string () in + let padding_103 = rand_string () in + let padding_104 = rand_string () in + let padding_105 = rand_string () in + let padding_106 = rand_string () in + let padding_107 = rand_string () in + let padding_108 = rand_string () in + let padding_109 = rand_string () in + let padding_110 = rand_string () in + let padding_111 = rand_string () in + let padding_112 = rand_string () in + let padding_113 = rand_string () in + let padding_114 = rand_string () in + let padding_115 = rand_string () in + let padding_116 = rand_string () in + let padding_117 = rand_string () in + let padding_118 = rand_string () in + let padding_119 = rand_string () in + let padding_120 = rand_string () in + let padding_121 = rand_string () in + let padding_122 = rand_string () in + let padding_123 = rand_string () in + let padding_124 = rand_string () in + let padding_125 = rand_string () in + let padding_126 = rand_string () in + let padding_127 = rand_string () in + let padding_128 = rand_string () in + let padding_129 = rand_string () in + let padding_130 = rand_string () in + let padding_131 = rand_string () in + let padding_132 = rand_string () in + let padding_133 = rand_string () in + let padding_134 = rand_string () in + let padding_135 = rand_string () in + let padding_136 = rand_string () in + let padding_137 = rand_string () in + let padding_138 = rand_string () in + let padding_139 = rand_string () in + let padding_140 = rand_string () in + let padding_141 = rand_string () in + let padding_142 = rand_string () in + let padding_143 = rand_string () in + let padding_144 = rand_string () in + let padding_145 = rand_string () in + let padding_146 = rand_string () in + let padding_147 = rand_string () in + let padding_148 = rand_string () in + let padding_149 = rand_string () in + let padding_150 = rand_string () in + let padding_151 = rand_string () in + let padding_152 = rand_string () in + let padding_153 = rand_string () in + let padding_154 = rand_string () in + let padding_155 = rand_string () in + let padding_156 = rand_string () in + let padding_157 = rand_string () in + let padding_158 = rand_string () in + let padding_159 = rand_string () in + let padding_160 = rand_string () in + let padding_161 = rand_string () in + let padding_162 = rand_string () in + let padding_163 = rand_string () in + let padding_164 = rand_string () in + let padding_165 = rand_string () in + let padding_166 = rand_string () in + let padding_167 = rand_string () in + let padding_168 = rand_string () in + let padding_169 = rand_string () in + let padding_170 = rand_string () in + let padding_171 = rand_string () in + let padding_172 = rand_string () in + let padding_173 = rand_string () in + let padding_174 = rand_string () in + let padding_175 = rand_string () in + let padding_176 = rand_string () in + let padding_177 = rand_string () in + let padding_178 = rand_string () in + let padding_179 = rand_string () in + let padding_180 = rand_string () in + let padding_181 = rand_string () in + let padding_182 = rand_string () in + let padding_183 = rand_string () in + let padding_184 = rand_string () in + let padding_185 = rand_string () in + let padding_186 = rand_string () in + let padding_187 = rand_string () in + let padding_188 = rand_string () in + let padding_189 = rand_string () in + let padding_190 = rand_string () in + let padding_191 = rand_string () in + let padding_192 = rand_string () in + let padding_193 = rand_string () in + let padding_194 = rand_string () in + let padding_195 = rand_string () in + let padding_196 = rand_string () in + let padding_197 = rand_string () in + let padding_198 = rand_string () in + let padding_199 = rand_string () in + let padding_200 = rand_string () in + let padding_201 = rand_string () in + let padding_202 = rand_string () in + let padding_203 = rand_string () in + let padding_204 = rand_string () in + let padding_205 = rand_string () in + let padding_206 = rand_string () in + let padding_207 = rand_string () in + let padding_208 = rand_string () in + let padding_209 = rand_string () in + let padding_210 = rand_string () in + let padding_211 = rand_string () in + let padding_212 = rand_string () in + let padding_213 = rand_string () in + let padding_214 = rand_string () in + let padding_215 = rand_string () in + let padding_216 = rand_string () in + let padding_217 = rand_string () in + let padding_218 = rand_string () in + let padding_219 = rand_string () in + let padding_220 = rand_string () in + let padding_221 = rand_string () in + let padding_222 = rand_string () in + let padding_223 = rand_string () in + let padding_224 = rand_string () in + let padding_225 = rand_string () in + let padding_226 = rand_string () in + let padding_227 = rand_string () in + let padding_228 = rand_string () in + let padding_229 = rand_string () in + let padding_230 = rand_string () in + let padding_231 = rand_string () in + let padding_232 = rand_string () in + let padding_233 = rand_string () in + let padding_234 = rand_string () in + let padding_235 = rand_string () in + let padding_236 = rand_string () in + let padding_237 = rand_string () in + let padding_238 = rand_string () in + let padding_239 = rand_string () in + let padding_240 = rand_string () in + let padding_241 = rand_string () in + let padding_242 = rand_string () in + let padding_243 = rand_string () in + let padding_244 = rand_string () in + let padding_245 = rand_string () in + let padding_246 = rand_string () in + let padding_247 = rand_string () in + let padding_248 = rand_string () in + let padding_249 = rand_string () in + let padding_250 = rand_string () in + let padding_251 = rand_string () in + let padding_252 = rand_string () in + let padding_253 = rand_string () in + let padding_254 = rand_string () in + let padding_255 = rand_string () in + let padding_256 = rand_string () in + let padding_257 = rand_string () in + let padding_258 = rand_string () in + let padding_259 = rand_string () in + let padding_260 = rand_string () in + let padding_261 = rand_string () in + let padding_262 = rand_string () in + let padding_263 = rand_string () in + let padding_264 = rand_string () in + let padding_265 = rand_string () in + let padding_266 = rand_string () in + let padding_267 = rand_string () in + let padding_268 = rand_string () in + let padding_269 = rand_string () in + let padding_270 = rand_string () in + let x = rand_string () in + let ( c1_1arg_original, + c2_1arg_original, + c3_1arg_original, + c1_2arg_original, + c2_2arg_original, + c3_2arg_original, + rec_c1_1arg_original, + rec_c2_1arg_original, + rec_c3_1arg_original, + rec_c1_2arg_original, + rec_c2_2arg_original, + rec_c3_2arg_original ) = + make_large_closures i64_1 i64_2 i64_3 i64_4 + padding_i64_0 + padding_i64_1 + padding_i64_2 + padding_i64_3 + padding_i64_4 + padding_i64_5 + padding_i64_6 + padding_i64_7 + padding_i64_8 + padding_i64_9 + padding_i64_10 + padding_i64_11 + padding_i64_12 + padding_i64_13 + padding_i64_14 + padding_i64_15 + padding_i64_16 + padding_i64_17 + padding_i64_18 + padding_i64_19 + padding_i64_20 + padding_i64_21 + padding_i64_22 + padding_i64_23 + padding_i64_24 + padding_i64_25 + padding_i64_26 + padding_i64_27 + padding_i64_28 + padding_i64_29 + padding_i64_30 + padding_i64_31 + padding_i64_32 + padding_i64_33 + padding_i64_34 + padding_i64_35 + padding_i64_36 + padding_i64_37 + padding_i64_38 + padding_i64_39 + padding_i64_40 + padding_i64_41 + padding_i64_42 + padding_i64_43 + padding_i64_44 + padding_i64_45 + padding_i64_46 + padding_i64_47 + padding_i64_48 + padding_i64_49 + padding_i64_50 + padding_i64_51 + padding_i64_52 + padding_i64_53 + padding_i64_54 + padding_i64_55 + padding_i64_56 + padding_i64_57 + padding_i64_58 + padding_i64_59 + padding_i64_60 + padding_i64_61 + padding_i64_62 + padding_i64_63 + padding_i64_64 + padding_i64_65 + padding_i64_66 + padding_i64_67 + padding_i64_68 + padding_i64_69 + padding_i64_70 + padding_i64_71 + padding_i64_72 + padding_i64_73 + padding_i64_74 + padding_i64_75 + padding_i64_76 + padding_i64_77 + padding_i64_78 + padding_i64_79 + padding_i64_80 + padding_i64_81 + padding_i64_82 + padding_i64_83 + padding_i64_84 + padding_i64_85 + padding_i64_86 + padding_i64_87 + padding_i64_88 + padding_i64_89 + padding_i64_90 + padding_i64_91 + padding_i64_92 + padding_i64_93 + padding_i64_94 + padding_i64_95 + padding_i64_96 + padding_i64_97 + padding_i64_98 + padding_i64_99 + padding_i64_100 + padding_i64_101 + padding_i64_102 + padding_i64_103 + padding_i64_104 + padding_i64_105 + padding_i64_106 + padding_i64_107 + padding_i64_108 + padding_i64_109 + padding_i64_110 + padding_i64_111 + padding_i64_112 + padding_i64_113 + padding_i64_114 + padding_i64_115 + padding_i64_116 + padding_i64_117 + padding_i64_118 + padding_i64_119 + padding_i64_120 + padding_i64_121 + padding_i64_122 + padding_i64_123 + padding_i64_124 + padding_i64_125 + padding_i64_126 + padding_i64_127 + padding_i64_128 + padding_i64_129 + padding_i64_130 + padding_i64_131 + padding_i64_132 + padding_i64_133 + padding_i64_134 + padding_i64_135 + padding_i64_136 + padding_i64_137 + padding_i64_138 + padding_i64_139 + padding_i64_140 + padding_i64_141 + padding_i64_142 + padding_i64_143 + padding_i64_144 + padding_i64_145 + padding_i64_146 + padding_i64_147 + padding_i64_148 + padding_i64_149 + padding_i64_150 + padding_i64_151 + padding_i64_152 + padding_i64_153 + padding_i64_154 + padding_i64_155 + padding_i64_156 + padding_i64_157 + padding_i64_158 + padding_i64_159 + padding_i64_160 + padding_i64_161 + padding_i64_162 + padding_i64_163 + padding_i64_164 + padding_i64_165 + padding_i64_166 + padding_i64_167 + padding_i64_168 + padding_i64_169 + padding_i64_170 + padding_i64_171 + padding_i64_172 + padding_i64_173 + padding_i64_174 + padding_i64_175 + padding_i64_176 + padding_i64_177 + padding_i64_178 + padding_i64_179 + padding_i64_180 + padding_i64_181 + padding_i64_182 + padding_i64_183 + padding_i64_184 + padding_i64_185 + padding_i64_186 + padding_i64_187 + padding_i64_188 + padding_i64_189 + padding_i64_190 + padding_i64_191 + padding_i64_192 + padding_i64_193 + padding_i64_194 + padding_i64_195 + padding_i64_196 + padding_i64_197 + padding_i64_198 + padding_i64_199 + padding_i64_200 + padding_i64_201 + padding_i64_202 + padding_i64_203 + padding_i64_204 + padding_i64_205 + padding_i64_206 + padding_i64_207 + padding_i64_208 + padding_i64_209 + padding_i64_210 + padding_i64_211 + padding_i64_212 + padding_i64_213 + padding_i64_214 + padding_i64_215 + padding_i64_216 + padding_i64_217 + padding_i64_218 + padding_i64_219 + padding_i64_220 + padding_i64_221 + padding_i64_222 + padding_i64_223 + padding_i64_224 + padding_i64_225 + padding_i64_226 + padding_i64_227 + padding_i64_228 + padding_i64_229 + padding_i64_230 + padding_i64_231 + padding_i64_232 + padding_i64_233 + padding_i64_234 + padding_i64_235 + padding_i64_236 + padding_i64_237 + padding_i64_238 + padding_i64_239 + padding_i64_240 + padding_i64_241 + padding_i64_242 + padding_i64_243 + padding_i64_244 + padding_i64_245 + padding_i64_246 + padding_i64_247 + padding_i64_248 + padding_i64_249 + padding_i64_250 + padding_i64_251 + padding_i64_252 + padding_i64_253 + padding_i64_254 + padding_i64_255 + padding_i64_256 + padding_i64_257 + padding_i64_258 + padding_i64_259 + padding_i64_260 + padding_i64_261 + padding_i64_262 + padding_i64_263 + padding_i64_264 + padding_i64_265 + padding_i64_266 + padding_i64_267 + padding_i64_268 + padding_i64_269 + padding_i64_270 + padding_0 + padding_1 + padding_2 + padding_3 + padding_4 + padding_5 + padding_6 + padding_7 + padding_8 + padding_9 + padding_10 + padding_11 + padding_12 + padding_13 + padding_14 + padding_15 + padding_16 + padding_17 + padding_18 + padding_19 + padding_20 + padding_21 + padding_22 + padding_23 + padding_24 + padding_25 + padding_26 + padding_27 + padding_28 + padding_29 + padding_30 + padding_31 + padding_32 + padding_33 + padding_34 + padding_35 + padding_36 + padding_37 + padding_38 + padding_39 + padding_40 + padding_41 + padding_42 + padding_43 + padding_44 + padding_45 + padding_46 + padding_47 + padding_48 + padding_49 + padding_50 + padding_51 + padding_52 + padding_53 + padding_54 + padding_55 + padding_56 + padding_57 + padding_58 + padding_59 + padding_60 + padding_61 + padding_62 + padding_63 + padding_64 + padding_65 + padding_66 + padding_67 + padding_68 + padding_69 + padding_70 + padding_71 + padding_72 + padding_73 + padding_74 + padding_75 + padding_76 + padding_77 + padding_78 + padding_79 + padding_80 + padding_81 + padding_82 + padding_83 + padding_84 + padding_85 + padding_86 + padding_87 + padding_88 + padding_89 + padding_90 + padding_91 + padding_92 + padding_93 + padding_94 + padding_95 + padding_96 + padding_97 + padding_98 + padding_99 + padding_100 + padding_101 + padding_102 + padding_103 + padding_104 + padding_105 + padding_106 + padding_107 + padding_108 + padding_109 + padding_110 + padding_111 + padding_112 + padding_113 + padding_114 + padding_115 + padding_116 + padding_117 + padding_118 + padding_119 + padding_120 + padding_121 + padding_122 + padding_123 + padding_124 + padding_125 + padding_126 + padding_127 + padding_128 + padding_129 + padding_130 + padding_131 + padding_132 + padding_133 + padding_134 + padding_135 + padding_136 + padding_137 + padding_138 + padding_139 + padding_140 + padding_141 + padding_142 + padding_143 + padding_144 + padding_145 + padding_146 + padding_147 + padding_148 + padding_149 + padding_150 + padding_151 + padding_152 + padding_153 + padding_154 + padding_155 + padding_156 + padding_157 + padding_158 + padding_159 + padding_160 + padding_161 + padding_162 + padding_163 + padding_164 + padding_165 + padding_166 + padding_167 + padding_168 + padding_169 + padding_170 + padding_171 + padding_172 + padding_173 + padding_174 + padding_175 + padding_176 + padding_177 + padding_178 + padding_179 + padding_180 + padding_181 + padding_182 + padding_183 + padding_184 + padding_185 + padding_186 + padding_187 + padding_188 + padding_189 + padding_190 + padding_191 + padding_192 + padding_193 + padding_194 + padding_195 + padding_196 + padding_197 + padding_198 + padding_199 + padding_200 + padding_201 + padding_202 + padding_203 + padding_204 + padding_205 + padding_206 + padding_207 + padding_208 + padding_209 + padding_210 + padding_211 + padding_212 + padding_213 + padding_214 + padding_215 + padding_216 + padding_217 + padding_218 + padding_219 + padding_220 + padding_221 + padding_222 + padding_223 + padding_224 + padding_225 + padding_226 + padding_227 + padding_228 + padding_229 + padding_230 + padding_231 + padding_232 + padding_233 + padding_234 + padding_235 + padding_236 + padding_237 + padding_238 + padding_239 + padding_240 + padding_241 + padding_242 + padding_243 + padding_244 + padding_245 + padding_246 + padding_247 + padding_248 + padding_249 + padding_250 + padding_251 + padding_252 + padding_253 + padding_254 + padding_255 + padding_256 + padding_257 + padding_258 + padding_259 + padding_260 + padding_261 + padding_262 + padding_263 + padding_264 + padding_265 + padding_266 + padding_267 + padding_268 + padding_269 + padding_270 + x + in + let dup (type a) (x : a) : a = Obj.(obj (dup (repr x))) in + let c1_1arg = dup c1_1arg_original in + let c2_1arg = dup c2_1arg_original in + let c3_1arg = dup c3_1arg_original in + let c1_2arg = dup c1_2arg_original in + let c2_2arg = dup c2_2arg_original in + let c3_2arg = dup c3_2arg_original in + let rec_c1_1arg = dup rec_c1_1arg_original in + let rec_c2_1arg = dup rec_c2_1arg_original in + let rec_c3_1arg = dup rec_c3_1arg_original in + let rec_c1_2arg = dup rec_c1_2arg_original in + let rec_c2_2arg = dup rec_c2_2arg_original in + let rec_c3_2arg = dup rec_c3_2arg_original in + Gc.compact (); + let check_tag_and_size v1 v2 = + let v1 = Obj.repr v1 in + let v2 = Obj.repr v2 in + assert (Obj.tag v1 = Obj.tag v2); + assert (Obj.size v1 = Obj.size v2) + in + check_tag_and_size c1_1arg c1_1arg_original; + check_tag_and_size c2_1arg c2_1arg_original; + check_tag_and_size c3_1arg c3_1arg_original; + check_tag_and_size c1_2arg c1_2arg_original; + check_tag_and_size c2_2arg c2_2arg_original; + check_tag_and_size c3_2arg c3_2arg_original; + check_tag_and_size rec_c1_1arg rec_c1_1arg_original; + check_tag_and_size rec_c2_1arg rec_c2_1arg_original; + check_tag_and_size rec_c3_1arg rec_c3_1arg_original; + check_tag_and_size rec_c1_2arg rec_c1_2arg_original; + check_tag_and_size rec_c2_2arg rec_c2_2arg_original; + check_tag_and_size rec_c3_2arg rec_c3_2arg_original; + check_results "large" i64_1 i64_2 i64_3 i64_4 x + ( c1_1arg, + c2_1arg, + c3_1arg, + c1_2arg, + c2_2arg, + c3_2arg, + rec_c1_1arg, + rec_c2_1arg, + rec_c3_1arg, + rec_c1_2arg, + rec_c2_2arg, + rec_c3_2arg ) + +let () = + Random.init 123; + for x = 1 to 10_000 do + check_one_small_closures (); + check_one_large_closures () + done diff --git a/testsuite/tests/parallel/max_domains1.ml b/testsuite/tests/parallel/max_domains1.ml new file mode 100644 index 00000000000..e00493f9e3c --- /dev/null +++ b/testsuite/tests/parallel/max_domains1.ml @@ -0,0 +1,11 @@ +(* TEST + flags += "-alert -unsafe_parallelism"; + ocamlrunparam += ",d=1"; + runtime5; + { native; } +*) + +let _ = + try + Domain.spawn (fun _ -> print_endline "Expect failure") |> ignore + with Failure _ -> print_string "ok\n" diff --git a/testsuite/tests/parallel/max_domains1.reference b/testsuite/tests/parallel/max_domains1.reference new file mode 100644 index 00000000000..9766475a418 --- /dev/null +++ b/testsuite/tests/parallel/max_domains1.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/parallel/max_domains2.ml b/testsuite/tests/parallel/max_domains2.ml new file mode 100644 index 00000000000..b9080372773 --- /dev/null +++ b/testsuite/tests/parallel/max_domains2.ml @@ -0,0 +1,17 @@ +(* TEST + flags += "-alert -unsafe_parallelism"; + ocamlrunparam += ",d=129"; + runtime5; + { native; } +*) + +let m = Mutex.create () + +let _ = + Mutex.lock m; + (* The default max domains limit is 128. In this test, we make this limit 129 + and spawn 128 domains in addition to the main domain. *) + for i = 1 to 128 do + Domain.spawn (fun _ -> Mutex.lock m) |> ignore + done; + print_endline "ok" diff --git a/testsuite/tests/parallel/max_domains2.reference b/testsuite/tests/parallel/max_domains2.reference new file mode 100644 index 00000000000..9766475a418 --- /dev/null +++ b/testsuite/tests/parallel/max_domains2.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/parallel/recommended_domain_count_cstubs.c b/testsuite/tests/parallel/recommended_domain_count_cstubs.c index 0f11c877840..8afa643ead2 100644 --- a/testsuite/tests/parallel/recommended_domain_count_cstubs.c +++ b/testsuite/tests/parallel/recommended_domain_count_cstubs.c @@ -1,13 +1,14 @@ #define CAML_INTERNALS -#include "caml/misc.h" -#include "caml/memory.h" #include "caml/domain.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/startup_aux.h" CAMLprim value caml_get_max_domains(value nada) { CAMLparam0(); - CAMLreturn(Val_long(Max_domains)); + CAMLreturn(Val_long(caml_params->max_domains)); } diff --git a/testsuite/tests/parsetree/source_jane_street.ml b/testsuite/tests/parsetree/source_jane_street.ml index 55d134d925f..f0205f2e9f0 100644 --- a/testsuite/tests/parsetree/source_jane_street.ml +++ b/testsuite/tests/parsetree/source_jane_street.ml @@ -166,7 +166,8 @@ end let x () = #( M.Null, M.This "hi" ) [%%expect{| -module M : sig type 'a t = 'a or_null = Null | This of 'a end +module M : + sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end val x : unit -> #('a M.t * string M.t) = |}] diff --git a/testsuite/tests/peek_and_poke/peek_and_poke.ml b/testsuite/tests/peek_and_poke/peek_and_poke.ml new file mode 100644 index 00000000000..610029f0986 --- /dev/null +++ b/testsuite/tests/peek_and_poke/peek_and_poke.ml @@ -0,0 +1,85 @@ +(* TEST + native; +*) + +(* Preliminaries to minimize deps *) + +external int32_u_to_int32 : int32# -> int32 + = "%box_int32" [@@warning "-187"] + +external int64_u_to_int64 : int64# -> int64 + = "%box_int64" [@@warning "-187"] + +external nativeint_u_to_nativeint : nativeint# -> nativeint + = "%box_nativeint" [@@warning "-187"] + +external nativeint_to_nativeint_u : nativeint -> nativeint# + = "%unbox_nativeint" [@@warning "-187"] + +external float_u_to_float : float# -> float + = "%box_float" [@@warning "-187"] + +(* CR mshinwell for gyorsh: enable these float32 cases *) + (* +external float32_u_to_float : float32# -> float32 + = "%box_float32" [@@warning "-187"] + *) + +let nativeint_u_add u1 n2 = + let n1 = nativeint_u_to_nativeint u1 in + let n = Nativeint.add n1 n2 in + nativeint_to_nativeint_u n + +(* The test itself starts here *) + +(* For the real API we don't plan to expose the type equality, but it + makes it easier to write the test below. *) +type ('a : any) t = nativeint# + +external read : ('a : any mod external_). 'a t -> 'a = "%peek" + [@@layout_poly] + +external write : ('a : any mod external_). 'a t -> 'a -> unit = "%poke" + [@@layout_poly] + +external calloc : + count:(int[@untagged]) -> size:(int[@untagged]) -> nativeint# = + "caml_no_bytecode_impl" "calloc" + [@@noalloc] + +let test_read p1 p2 p3 p4 p5 p6 + : #(int * int32# * int64# * nativeint# * float# * float#) = + #(read p1, read p2, read p3, read p4, read p5, read p6) + +(* CR mshinwell for gyorsh: the last number here should be #0.1234s *) +let values () = #(min_int, #400l, #9999999999L, #123456n, #0.87654, #0.1234) + +let test_write p1 p2 p3 p4 p5 p6 = + let #(n1, n2, n3, n4, n5, n6) = values () in + write p1 n1; + write p2 n2; + write p3 n3; + write p4 n4; + write p5 n5; + write p6 n6 + +let () = + let buf = calloc ~count:6 ~size:8 in + let int_buf = buf in + let int32_buf = nativeint_u_add buf 8n in + let int64_buf = nativeint_u_add buf 16n in + let nativeint_buf = nativeint_u_add buf 24n in + let float_buf = nativeint_u_add buf 32n in + let float32_buf = nativeint_u_add buf 40n in + test_write int_buf int32_buf int64_buf nativeint_buf float_buf float32_buf; + let #(n1, n2, n3, n4, n5, n6) = + test_read int_buf int32_buf int64_buf nativeint_buf float_buf float32_buf + in + let #(n1', n2', n3', n4', n5', n6') = values () in + assert (Int.equal n1 n1'); + assert (Int32.equal (int32_u_to_int32 n2) (int32_u_to_int32 n2')); + assert (Int64.equal (int64_u_to_int64 n3) (int64_u_to_int64 n3')); + assert (Nativeint.equal (nativeint_u_to_nativeint n4) + (nativeint_u_to_nativeint n4')); + assert (Float.equal (float_u_to_float n5) (float_u_to_float n5')); + assert (Float.equal (float_u_to_float n6) (float_u_to_float n6')) diff --git a/testsuite/tests/peek_and_poke/peek_and_poke_forbidden_for_value.ml b/testsuite/tests/peek_and_poke/peek_and_poke_forbidden_for_value.ml new file mode 100644 index 00000000000..dfdb00e73b8 --- /dev/null +++ b/testsuite/tests/peek_and_poke/peek_and_poke_forbidden_for_value.ml @@ -0,0 +1,35 @@ +(* TEST + expect; +*) + +type ('a : any) t + +external read : ('a : any mod external_). 'a t -> 'a = "%peek" + [@@layout_poly] + +external write : ('a : any mod external_). 'a t -> 'a -> unit = "%poke" + [@@layout_poly] + +[%%expect {| +type ('a : any) t +external read : ('a : any mod external_). 'a t -> 'a = "%peek" + [@@layout_poly] +external write : ('a : any mod external_). 'a t -> 'a -> unit = "%poke" + [@@layout_poly] +|}] + +let bad_read p : string = read p +[%%expect {| +Line 1, characters 26-32: +1 | let bad_read p : string = read p + ^^^^^^ +Error: Unsupported layout for the peek primitive +|}] + +let bad_write p (s : string) = write p s +[%%expect {| +Line 1, characters 31-40: +1 | let bad_write p (s : string) = write p s + ^^^^^^^^^ +Error: Unsupported layout for the poke primitive +|}] diff --git a/ocaml/testsuite/tests/polling/polling.compilers.reference b/testsuite/tests/polling/polling.compilers.reference similarity index 100% rename from ocaml/testsuite/tests/polling/polling.compilers.reference rename to testsuite/tests/polling/polling.compilers.reference diff --git a/ocaml/testsuite/tests/polling/polling.ml b/testsuite/tests/polling/polling.ml similarity index 100% rename from ocaml/testsuite/tests/polling/polling.ml rename to testsuite/tests/polling/polling.ml diff --git a/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml b/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml index 6776ff31a5d..996bec9d4ff 100644 --- a/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml +++ b/testsuite/tests/templates/basic/bad_instance_wrong_mode.ml @@ -2,4 +2,6 @@ let (f @ portable) () = let module Monoid_utils_of_list_monoid = Monoid_utils(Monoid)(List_monoid) [@jane.non_erasable.instances] in + (* module alias doesn't walk locks; using it does. *) + let _ = Monoid_utils_of_list_monoid.concat in () diff --git a/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference b/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference index cd840ed625b..67214136bf0 100644 --- a/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference +++ b/testsuite/tests/templates/basic/bad_instance_wrong_mode.reference @@ -1,4 +1,4 @@ -File "bad_instance_wrong_mode.ml", line 3, characters 4-68: -3 | Monoid_utils(Monoid)(List_monoid) [@jane.non_erasable.instances] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Modules are nonportable, so cannot be used inside a function that is portable. +File "bad_instance_wrong_mode.ml", line 6, characters 10-44: +6 | let _ = Monoid_utils_of_list_monoid.concat in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The value "Monoid_utils_of_list_monoid.concat" is nonportable, so cannot be used inside a function that is portable. diff --git a/testsuite/tests/templates/basic/main-ocamlobjinfo.reference b/testsuite/tests/templates/basic/main-ocamlobjinfo.reference index b3036161601..43064026976 100644 --- a/testsuite/tests/templates/basic/main-ocamlobjinfo.reference +++ b/testsuite/tests/templates/basic/main-ocamlobjinfo.reference @@ -26,8 +26,8 @@ Runtime parameters: Monoid_utils[Monoid:Monoid_of_semigroup] Monoid_of_semigroup Chain[Category:Category_of_monoid[Monoid:List_monoid]] - Import Category_of_monoid[Monoid:List_monoid] + Import List_element List_monoid Category_utils[Category:Category_of_monoid[Monoid:List_monoid]] diff --git a/testsuite/tests/templates/basic/main.mli b/testsuite/tests/templates/basic/main.mli index 8bb16c706a4..d77cd16f3b4 100644 --- a/testsuite/tests/templates/basic/main.mli +++ b/testsuite/tests/templates/basic/main.mli @@ -1,5 +1,3 @@ -open Import - val append3_semi : Semigroup.t option -> Semigroup.t option diff --git a/testsuite/tests/templates/basic/test.ml b/testsuite/tests/templates/basic/test.ml index 6fda0975a00..48ded7465fb 100644 --- a/testsuite/tests/templates/basic/test.ml +++ b/testsuite/tests/templates/basic/test.ml @@ -434,11 +434,11 @@ ocamlc.byte; { - flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + flags = "-open Import -parameter Semigroup -parameter List_element -w -misplaced-attribute"; module = "main.mli"; ocamlc.byte; { - flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; + flags = "-open Import -parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; module = "main.ml"; compiler_output = "main.output"; ocamlc.byte; @@ -919,11 +919,11 @@ ocamlopt.byte; { - flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute"; + flags = "-open Import -parameter Semigroup -parameter List_element -w -misplaced-attribute"; module = "main.mli"; ocamlopt.byte; { - flags = "-parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; + flags = "-open Import -parameter Semigroup -parameter List_element -w -misplaced-attribute -i"; module = "main.ml"; compiler_output = "main.output"; ocamlopt.byte; diff --git a/testsuite/tests/typing-layouts-arrays/README.md b/testsuite/tests/typing-layouts-arrays/README.md new file mode 100644 index 00000000000..14c5a717d58 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/README.md @@ -0,0 +1,34 @@ +This directory has tests for arrays of unboxed types. The tests assume the array +contains something that is like a number. + +Using the test framework here still involves a fair amount of copy and paste to +build your new test. This is mainly because we don't have layout polymorphism, +so it's not really possible to build it as one nice big functor. Hopefully we +can improve it in the future. + +## Basic use + +The files `gen_u_array.ml` and `test_gen_u_array.ml` contain the basic +framework. Rather than reading them, you are probably better off looking at an +example. E.g., see `test_int64_u_array.ml`. + +## Errors + +The testing framework is not very helpful in the event of errors - you'll get an +assertion failure with an uninformative backtrace. One way to debug is to +copy the framework and your test file elsewhere, compile and run it as a normal +ocaml program, then comment out parts of the big test functor from +`test_gen_u_array.ml` until you locate the line causing the error. This should +be improved. + +## Unboxed products + +The file `gen_product_array_helpers.ml` has additional infrastructure for +testing arrays of unboxed products. To add a new test, copy one of the existing +ones (e.g., `test_ignorable_product_array_1.ml`) and follow the instructions +in its comments about which parts you need to edit. + +Note that tests whose filename contains `with_uninit` use +`%makearray_dynamic_uninit` to create arrays, while other tests using this +infrastructure use `%makearray_dynamic`. + diff --git a/testsuite/tests/typing-layouts-arrays/array_element_size_in_bytes.ml b/testsuite/tests/typing-layouts-arrays/array_element_size_in_bytes.ml new file mode 100644 index 00000000000..f4e9cad40b5 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/array_element_size_in_bytes.ml @@ -0,0 +1,233 @@ +(* TEST + flags = "-extension layouts_beta"; + flambda2; + stack-allocation; + arch_amd64; + { + bytecode; + } { + native; + } +*) + +(* CR layouts v4: The below definition is just to give this test slightly + different behavior on native code and bytecode, because some arrays of + unboxed things are represented as custom blocks on only native code, and + therefore the size calculations differ slightly. Delete this when we change + the representation to not use custom blocks. *) +let custom_block_padding = + match Sys.backend_type with + | Native -> 1 + | Bytecode -> 0 + | Other _ -> failwith "Don't know what to do" + +(* We only compile for 64 bits. *) +let bytes_per_word = 8 + +external[@layout_poly] size_in_bytes : ('a : any_non_null). 'a array -> int + = "%array_element_size_in_bytes" + +external[@layout_poly] makearray_dynamic : + ('a : any_non_null). int -> 'a -> 'a array = "%makearray_dynamic" + +let array_sizes_to_check = [0; 1; 2; 25] + +(* values *) +let check_value ~init ~element_size = + (* It is unfortunately necessary to duplicate this function many times because + we don't have layout polymorphism. *) + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let int_array_element_size = size_in_bytes ([||] : int array) +let _ = check_value ~init:42 ~element_size:int_array_element_size + +let string_array_element_size = size_in_bytes ([||] : string array) +let _ = check_value ~init:"abc" ~element_size:int_array_element_size + +let float_array_element_size = size_in_bytes ([||] : float array) +let _ = check_value ~init:42.0 ~element_size:int_array_element_size + +let float32_array_element_size = size_in_bytes ([||] : float32 array) +let _ = check_value ~init:42.0s ~element_size:int_array_element_size + +let int32_array_element_size = size_in_bytes ([||] : int32 array) +let _ = check_value ~init:42l ~element_size:int_array_element_size + +(* unboxed floats *) +let check_floatu ~init ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let floatu_array_element_size = size_in_bytes ([||] : float# array) + +let _ = check_floatu ~init:#42.0 ~element_size:floatu_array_element_size + +(* unboxed int64s *) +let check_int64u ~(init : int64#) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((custom_block_padding + (element_size * n / bytes_per_word)) + = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let int64u_array_element_size = size_in_bytes ([||] : int64# array) + +let _ = check_int64u ~init:#42L ~element_size:int64u_array_element_size + +(* unboxed float32s *) +let check_float32u ~(init : float32#) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* These arrays are packed in native code *) + let n = + match Sys.backend_type with + | Native -> if n mod 2 = 0 then n else n + 1 + | Bytecode -> n + | Other _ -> failwith "Don't know what to do" + in + assert ((custom_block_padding + (element_size * n / bytes_per_word)) + = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let float32u_array_element_size = size_in_bytes ([||] : float32# array) + +let _ = check_float32u ~init:#42.0s ~element_size:float32u_array_element_size + +(* unboxed int32s *) +let check_int32u ~(init : int32#) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* These arrays are packed in native code *) + let n = + match Sys.backend_type with + | Native -> if n mod 2 = 0 then n else n + 1 + | Bytecode -> n + | Other _ -> failwith "Don't know what to do" + in + assert ((custom_block_padding + (element_size * n / bytes_per_word)) + = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let int32u_array_element_size = size_in_bytes ([||] : int32# array) + +let _ = check_int32u ~init:#42l ~element_size:int32u_array_element_size + +(* simple scannable products *) +let check_scannable_product1 ~(init : #(int * string * int * float array)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let scannable_product1_array_element_size = + size_in_bytes ([||] : #(int * string * int * float array) array) + +let _ = check_scannable_product1 ~init:#(42, "hi", 0, [| 1.0; 2.0; 3.0 |]) + ~element_size:scannable_product1_array_element_size + +(* complex scannable products *) +type t_scan = #{ x : int; y : #(float * string); z: int option } + +let check_scannable_product2 ~(init : #(int * t_scan * string * t_scan)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let mk_el () = + #(42, + #{ x = 42; y = #(42.0, "hi"); z = Some 42 }, + "hi", + #{ x = 42; y = #(42.0, "hi"); z = Some 42 }) + +let scannable_product2_array_element_size = + size_in_bytes ([||] : #(int * t_scan * string * t_scan) array) + +let _ = check_scannable_product2 ~init:(mk_el ()) + ~element_size:scannable_product2_array_element_size + +(* simple ignorable products *) +let check_ignorable_product1 ~(init : #(int * float32# * int * int64#)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let ignorable_product1_array_element_size = + size_in_bytes ([||] : #(int * float32# * int * int64#) array) + +let _ = check_ignorable_product1 ~init:#(42, #42.0s, 0, #42L) + ~element_size:ignorable_product1_array_element_size + +(* complex ignorable products *) +type t_ignore = #{ x : int; y : #(float# * int32#); z: int32# } + +let check_ignorable_product2 ~(init : #(int * t_ignore * bool * t_ignore)) + ~element_size = + let check_one n = + let x = makearray_dynamic n init in + assert ((element_size * n / bytes_per_word) = (Obj.size (Obj.repr x))) + in + List.iter check_one array_sizes_to_check + +let mk_el () = + #(42, + #{ x = 42; y = #(#41.0, #40l); z = #43l }, + true, + #{ x = 42; y = #(#41.0, #40l); z = #43l }) + +let ignorable_product2_array_element_size = + size_in_bytes ([||] : #(int * t_ignore * bool * t_ignore) array) + +let _ = check_ignorable_product2 ~init:(mk_el ()) + ~element_size:ignorable_product2_array_element_size + +(* check lack of float32# packing in unboxed product arrays *) +let check_float32u_pair ~(init : #(float32# * float32#)) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* 2 because there are two components in the unboxed product *) + match Sys.backend_type with + | Native -> assert (n * 2 = (Obj.size (Obj.repr x))) + | Bytecode | Other _ -> assert (n = Obj.size (Obj.repr x)) + in + List.iter check_one array_sizes_to_check + +let float32u_pair_array_element_size = + size_in_bytes ([||] : #(int * t_ignore * bool * t_ignore) array) + +let _ = check_float32u_pair ~init:#(#1.0s, #42.1s) + ~element_size:float32u_pair_array_element_size + +(* check lack of int32# packing in unboxed product arrays *) +let check_int32u_pair ~(init : #(int32# * int32#)) ~element_size = + let check_one n = + let x = makearray_dynamic n init in + (* 2 because there are two components in the unboxed product *) + match Sys.backend_type with + | Native -> assert (n * 2 = (Obj.size (Obj.repr x))) + | Bytecode | Other _ -> assert (n = Obj.size (Obj.repr x)) + in + List.iter check_one array_sizes_to_check + +let int32u_pair_array_element_size = + size_in_bytes ([||] : #(int * t_ignore * bool * t_ignore) array) + +let _ = check_int32u_pair ~init:#(#1l, #42l) + ~element_size:int32u_pair_array_element_size diff --git a/testsuite/tests/typing-layouts-arrays/basics_alpha.ml b/testsuite/tests/typing-layouts-arrays/basics_alpha.ml index 4b6074016e1..b52edd91f95 100644 --- a/testsuite/tests/typing-layouts-arrays/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-arrays/basics_alpha.ml @@ -362,3 +362,302 @@ Error: This expression has type "float32#" because it's the type of an array element, chosen to have layout value. |}] + +(* Test 8: makearraydynamic_uninit *) + +external[@layout_poly] makearray_dynamic_uninit_local + : ('a : any_non_null) . int -> 'a array @ local = "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_uninit + : ('a : any_non_null) . int -> 'a array = "%makearray_dynamic_uninit" +[%%expect{| +external makearray_dynamic_uninit_local : + ('a : any_non_null). int -> local_ 'a array = "%makearray_dynamic_uninit" + [@@layout_poly] +external makearray_dynamic_uninit : ('a : any_non_null). int -> 'a array + = "%makearray_dynamic_uninit" [@@layout_poly] +|}] + +type ('a : any) with_i64s = #( int64# * 'a * int64# ) + +type ok_1 = #(int64# * int32#) +type ok_2 = float# with_i64s + +type bad_1 = #(int * int32#) +type bad_2 = int +type bad_3 = A | B | C +type bad_4 = #{ a: int64# ; enum : bad_3 } +type bad_5 = bad_3 with_i64s +type bad_6 = #(float * #(float * float) * #(float * #(float * float * float))) +type bad_7 = #{ i : int64# ; bad_4 : bad_4 ; j : int64# } +[%%expect{| +type ('a : any) with_i64s = #(int64# * 'a * int64#) +type ok_1 = #(int64# * int32#) +type ok_2 = float# with_i64s +type bad_1 = #(int * int32#) +type bad_2 = int +type bad_3 = A | B | C +type bad_4 = #{ a : int64#; enum : bad_3; } +type bad_5 = bad_3 with_i64s +type bad_6 = + #(float * #(float * float) * #(float * #(float * float * float))) +type bad_7 = #{ i : int64#; bad_4 : bad_4; j : int64#; } +|}] + +(* Allowed usages *) + +let _ = + (makearray_dynamic_uninit 0 : float# array) +[%%expect{| +- : float# array = [||] +|}] + +let _ = + (makearray_dynamic_uninit 0 : ok_1 array) +[%%expect{| +- : ok_1 array = [||] +|}] + +let _ = + (makearray_dynamic_uninit 0 : ok_2 array) +[%%expect{| +- : ok_2 array = [||] +|}] + +(* Disallowed usages *) + +let _ = + (makearray_dynamic_uninit 0 : int array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : int array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : float array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : float array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : #(int64# * int) array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : #(int64# * int) array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_1 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_1 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_2 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_2 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_3 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_3 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_4 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_4 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_5 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_5 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_6 array) +[%%expect{| +Line 2, characters 2-28: +2 | (makearray_dynamic_uninit 0 : bad_6 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + (makearray_dynamic_uninit 0 : bad_7 array) +[%%expect{| +Line 2, characters 3-29: +2 | (makearray_dynamic_uninit 0 : bad_7 array) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +(* Allowed usages (local) *) + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : ok_1 array) in + () +[%%expect{| +- : unit = () +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : ok_2 array) in + () +[%%expect{| +- : unit = () +|}] + +(* Disallowed usages (local) *) + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : int array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : int array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : #(int64# * int) array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : #(int64# * int) array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_1 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_1 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_2 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_2 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_3 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_3 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_4 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_4 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_5 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_5 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_6 array) in + () +[%%expect{| +Line 2, characters 10-42: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_6 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] + +let _ = + let _ = (makearray_dynamic_uninit_local 0 : bad_7 array) in + () +[%%expect{| +Line 2, characters 11-43: +2 | let _ = (makearray_dynamic_uninit_local 0 : bad_7 array) in + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: %makearray_dynamic_uninit can only be used for GC-ignorable arrays + not involving tagged immediates; and arrays of unboxed numbers. + Use %makearray instead, providing an initializer. +|}] diff --git a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml new file mode 100644 index 00000000000..296563970a0 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.ml @@ -0,0 +1,353 @@ +module type Element_intf = Test_gen_u_array.Element_intf + +type 'a elem = + | Number : { ops : (module Element_intf with type t = 'a) } -> 'a elem + | Option : 'a elem -> ('a option) elem + | Tup2 : 'a1 elem * 'a2 elem -> ('a1 * 'a2) elem + | Tup3 : 'a1 elem * 'a2 elem * 'a3 elem -> ('a1 * 'a2 * 'a3) elem + | Tup4 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem + -> ('a1 * 'a2 * 'a3 * 'a4) elem + | Tup5 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) elem + | Tup6 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem * 'a6 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) elem + +module Int_elem : Element_intf with type t = int = +struct + include Int + let of_int x = x + let max_val = max_int + let min_val = min_int + let rand = Random.full_int + let print i = Printf.printf "%d" i +end + +let int_elem = Number { ops = (module Int_elem) } + +module Int32_elem : Element_intf with type t = int32 = +struct + include Int32 + let max_val = max_int + let min_val = min_int + let rand = Random.int32 + let print i = Printf.printf "%ld" i +end + +let int32_elem = Number { ops = (module Int32_elem) } + +module Int64_elem : Element_intf with type t = int64 = +struct + include Int64 + let max_val = max_int + let min_val = min_int + let rand = Random.int64 + let print i = Printf.printf "%Ld" i +end + +let int64_elem = Number { ops = (module Int64_elem) } + +module Nativeint_elem : Element_intf with type t = nativeint = +struct + include Nativeint + let max_val = max_int + let min_val = min_int + let rand = Random.nativeint + let print i = Printf.printf "%nd" i +end + +let nativeint_elem = Number { ops = (module Nativeint_elem) } + +module Float_elem : Element_intf with type t = float = +struct + include Float + let max_val = max_float + let min_val = min_float + let rand = Random.float + let print i = Printf.printf "%f" i +end + +let float_elem = Number { ops = (module Float_elem) } + +module Float32_elem : Element_intf with type t = float32 = +struct + include Stdlib_stable.Float32 + let max_val = max_float + let min_val = min_float + let rand x = of_float (Random.float (to_float x)) + let print i = Printf.printf "%f" (to_float i) +end + +let float32_elem = Number { ops = (module Float32_elem) } + +let traverse0 (f : 'a. (module Element_intf with type t = 'a) -> 'a) = + let rec go : type a . a elem -> a = + fun (elem : a elem) -> + match elem with + | Number {ops} -> f ops + | Option elem -> Some (go elem) + | Tup2 (e1, e2) -> (go e1, go e2) + | Tup3 (e1, e2, e3) -> (go e1, go e2, go e3) + | Tup4 (e1, e2, e3, e4) -> (go e1, go e2, go e3, go e4) + | Tup5 (e1, e2, e3, e4, e5) -> (go e1, go e2, go e3, go e4, go e5) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + (go e1, go e2, go e3, go e4, go e5, go e6) + in + go + +let traverse1 (f : 'a. (module Element_intf with type t = 'a) -> 'a -> 'a) = + let rec go : type a . a elem -> a -> a = + fun (elem : a elem) (a : a) -> + match elem with + | Number {ops} -> f ops a + | Option elem -> Option.map (go elem) a + | Tup2 (e1, e2) -> + let a1, a2 = a in + (go e1 a1, go e2 a2) + | Tup3 (e1, e2, e3) -> + let a1, a2, a3 = a in + (go e1 a1, go e2 a2, go e3 a3) + | Tup4 (e1, e2, e3, e4) -> + let a1, a2, a3, a4 = a in + (go e1 a1, go e2 a2, go e3 a3, go e4 a4) + | Tup5 (e1, e2, e3, e4, e5) -> + let a1, a2, a3, a4, a5 = a in + (go e1 a1, go e2 a2, go e3 a3, go e4 a4, go e5 a5) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a1, a2, a3, a4, a5, a6 = a in + (go e1 a1, go e2 a2, go e3 a3, go e4 a4, go e5 a5, go e6 a6) + in + go + +let traverse2 + (f : 'a. (module Element_intf with type t = 'a) -> 'a -> 'a -> 'a) = + let rec go : type a . a elem -> a -> a -> a = + fun (elem : a elem) (a1 : a) (a2 : a) -> + match elem with + | Number {ops} -> f ops a1 a2 + | Option elem -> + begin match a1, a2 with + | None, _ | _, None -> None + | Some a1, Some a2 -> Some (go elem a1 a2) + end + | Tup2 (e1, e2) -> + let a11, a12 = a1 in + let a21, a22 = a2 in + (go e1 a11 a21, go e2 a12 a22) + | Tup3 (e1, e2, e3) -> + let a11, a12, a13 = a1 in + let a21, a22, a23 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23) + | Tup4 (e1, e2, e3, e4) -> + let a11, a12, a13, a14 = a1 in + let a21, a22, a23, a24 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24) + | Tup5 (e1, e2, e3, e4, e5) -> + let a11, a12, a13, a14, a15 = a1 in + let a21, a22, a23, a24, a25 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24, + go e5 a15 a25) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a11, a12, a13, a14, a15, a16 = a1 in + let a21, a22, a23, a24, a25, a26 = a2 in + (go e1 a11 a21, go e2 a12 a22, go e3 a13 a23, go e4 a14 a24, + go e5 a15 a25, go e6 a16 a26) + in + go + +let rec of_int : type a . a elem -> int -> a = + fun elem i -> + match elem with + | Number {ops} -> + let module O = (val ops) in + O.of_int i + | Option elem -> Some (of_int elem i) + | Tup2 (e1, e2) -> (of_int e1 i, of_int e2 i) + | Tup3 (e1, e2, e3) -> (of_int e1 i, of_int e2 i, of_int e3 i) + | Tup4 (e1, e2, e3, e4) -> + (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i) + | Tup5 (e1, e2, e3, e4, e5) -> + (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i, of_int e5 i) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + (of_int e1 i, of_int e2 i, of_int e3 i, of_int e4 i, of_int e5 i, + of_int e6 i) + +let add elem a1 a2 = + let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = + E.add a1 a2 + in + traverse2 f elem a1 a2 + +let sub elem a1 a2 = + let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = + E.sub a1 a2 + in + traverse2 f elem a1 a2 + +let mul elem a1 a2 = + let f (type a) (module E : Element_intf with type t = a) (a1 : a) (a2 : a) = + E.mul a1 a2 + in + traverse2 f elem a1 a2 + +let neg elem a = + let f (type a) (module E : Element_intf with type t = a) (a : a) = + E.neg a + in + traverse1 f elem a + +let max_val elem = + let f (type a) (module E : Element_intf with type t = a) = + E.max_val + in + traverse0 f elem + +let min_val elem = + let rec go : type a . a elem -> a = + fun (elem : a elem) -> + match elem with + | Number {ops} -> + let module E = (val ops) in + E.min_val + | Option elem -> None + | Tup2 (e1, e2) -> (go e1, go e2) + | Tup3 (e1, e2, e3) -> (go e1, go e2, go e3) + | Tup4 (e1, e2, e3, e4) -> (go e1, go e2, go e3, go e4) + | Tup5 (e1, e2, e3, e4, e5) -> (go e1, go e2, go e3, go e4, go e5) + | Tup6 (e1, e2, e3, e4, e5, e6) -> + (go e1, go e2, go e3, go e4, go e5, go e6) + in + go elem + +let rand elem a = + let f (type a) (module E : Element_intf with type t = a) (a : a) = + E.rand a + in + traverse1 f elem a + +let rec compare : type a . a elem -> a -> a -> int = + fun elem a1 a2 -> + match elem with + | Number {ops} -> + let module E = (val ops) in + E.compare a1 a2 + | Option elem -> Option.compare (compare elem) a1 a2 + | Tup2 (e1, e2) -> + let a11, a12 = a1 in + let a21, a22 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else compare e2 a12 a22 + | Tup3 (e1, e2, e3) -> + let a11, a12, a13 = a1 in + let a21, a22, a23 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else compare e3 a13 a23 + | Tup4 (e1, e2, e3, e4) -> + let a11, a12, a13, a14 = a1 in + let a21, a22, a23, a24 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else + let x = compare e3 a13 a23 in + if x <> 0 then x else compare e4 a14 a24 + | Tup5 (e1, e2, e3, e4, e5) -> + let a11, a12, a13, a14, a15 = a1 in + let a21, a22, a23, a24, a25 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else + let x = compare e3 a13 a23 in + if x <> 0 then x else + let x = compare e4 a14 a24 in + if x <> 0 then x else compare e5 a15 a25 + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a11, a12, a13, a14, a15, a16 = a1 in + let a21, a22, a23, a24, a25, a26 = a2 in + let x = compare e1 a11 a21 in + if x <> 0 then x + else + let x = compare e2 a12 a22 in + if x <> 0 then x else + let x = compare e3 a13 a23 in + if x <> 0 then x else + let x = compare e4 a14 a24 in + if x <> 0 then x else + let x = compare e5 a15 a25 in + if x <> 0 then x else + compare e6 a16 a26 + +let rec print : type a . a elem -> a -> unit = + let open struct + type packed = P : 'a elem * 'a -> packed + + let print_comma_sep l = + Printf.printf "("; + let rec go l = + match l with + | [] -> assert false + | [P (e,a)] -> + print e a; + Printf.printf ")" + | (P (e,a)) :: l -> + print e a; + Printf.printf ", "; + go l + in + go l + end + in + fun elem a -> + match elem with + | Number {ops} -> + let module E = (val ops) in + E.print a + | Option elem -> + begin match a with + | None -> Printf.printf "None" + | Some a -> begin + Printf.printf "Some "; + print elem a + end + end + | Tup2 (e1, e2) -> + let a1, a2 = a in + print_comma_sep [P (e1, a1); P (e2, a2)] + | Tup3 (e1, e2, e3) -> + let a1, a2, a3 = a in + print_comma_sep [P (e1, a1); P (e2, a2); P (e3, a3)] + | Tup4 (e1, e2, e3, e4) -> + let a1, a2, a3, a4 = a in + print_comma_sep [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4)] + | Tup5 (e1, e2, e3, e4, e5) -> + let a1, a2, a3, a4, a5 = a in + print_comma_sep + [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4); P (e5, a5)] + | Tup6 (e1, e2, e3, e4, e5, e6) -> + let a1, a2, a3, a4, a5, a6 = a in + print_comma_sep + [P (e1, a1); P (e2, a2); P (e3, a3); P (e4, a4); P (e5, a5); + P (e6, a6)] + +let make_element_ops (type a) (elem : a elem) + : (module Element_intf with type t = a) = + (module struct + type t = a + + let of_int i = of_int elem i + let add t1 t2 = add elem t1 t2 + let sub t1 t2 = sub elem t1 t2 + let mul t1 t2 = mul elem t1 t2 + let neg t = neg elem t + let max_val = max_val elem + let min_val = min_val elem + let rand t = rand elem t + let compare t1 t2 = compare elem t1 t2 + let print t = print elem t + end) diff --git a/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli new file mode 100644 index 00000000000..2ba44fb0ad1 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/gen_product_array_helpers.mli @@ -0,0 +1,26 @@ +(* This module defines some helpers for writing tests on arays of unboxed + products. See [README.md] in this directory. *) + +module type Element_intf = Test_gen_u_array.Element_intf + +type 'a elem = + | Number : { ops : (module Element_intf with type t = 'a) } -> 'a elem + | Option : 'a elem -> ('a option) elem + | Tup2 : 'a1 elem * 'a2 elem -> ('a1 * 'a2) elem + | Tup3 : 'a1 elem * 'a2 elem * 'a3 elem -> ('a1 * 'a2 * 'a3) elem + | Tup4 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem + -> ('a1 * 'a2 * 'a3 * 'a4) elem + | Tup5 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) elem + | Tup6 : 'a1 elem * 'a2 elem * 'a3 elem * 'a4 elem * 'a5 elem * 'a6 elem + -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) elem + +val int_elem : int elem +val int32_elem : int32 elem +val int64_elem : int64 elem +val nativeint_elem : nativeint elem + +val float_elem : float elem +val float32_elem : float32 elem + +val make_element_ops : 'a elem -> (module Element_intf with type t = 'a) diff --git a/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml b/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml new file mode 100644 index 00000000000..2fb1aaa1827 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/generate_makearray_dynamic_tests.ml @@ -0,0 +1,682 @@ +(* This file is used in [run_makearray_dynamic_tests.ml]. *) +open Stdlib_upstream_compatible +open Stdlib_stable +module List = ListLabels +module String = StringLabels + +let failwithf fmt = Printf.ksprintf failwith fmt +let sprintf = Printf.sprintf + +(* See [test_makearray_dynamic] for the main testing steps! *) + +module Ty : sig + (* A type in the generated code *) + type t = { + ty_code : string; + (* Code for this type expression (e.g. "int option * float") *) + value_code : int -> string; + (* Given some integer seed, generate code for a value of this type. + E.g. passing 3 gives "(Some 3, 3.)" for [int option * float]. *) + mk_value_code : string; + (* Code that dynamically implements [value_code], creating a value from an + integer seed bound to "i". + We should be able to generate this code: + "let mk_value (i : int) : $ty_code = $mk_value_code" *) + eq : string; + (* A function that implements equality in the generated code. + We should be able generate this code: + "let eq : $ty_code @ local -> $ty_code @ local -> bool = $eq" *) + is_gc_ignorable : bool; + (* Whether type only contains non-values/immediates (this used to gate + blit tests, but now that blits work for all types, this field is + unused). *) + } + + (* Generate typedecls for user-defined nominal types that have been created *) + val decls_code : unit -> string list + + (* Takes the record name and (label_name, label_type) pairs *) + val unboxed_record : string -> (string * t) list -> t + + (* [enum 3] represents [type enum3 = A3_0 | A3_1 | A3_2]. *) + val enum : int -> t + + (* Structural and built-in types *) + + val option : t -> t + val tuple : t list -> t + val unboxed_tuple : t list -> t + + val int : t + val float : t + val float_u : t + val float32 : t + val float32_u : t + val int32 : t + val int32_u : t + val int64 : t + val int64_u : t + val nativeint : t + val nativeint_u : t +end = struct + type t = { + ty_code : string; + value_code : int -> string; + mk_value_code : string; + eq : string; + is_gc_ignorable : bool; + } + + let ty_code t = t.ty_code + let value_code t = t.value_code + let mk_value_code t = t.mk_value_code + let is_gc_ignorable t = t.is_gc_ignorable + + let map_value_code ts i = List.map ts ~f:(fun t -> t.value_code i) + + (* If (name, decl) is in this list, we'll generate "type $name = $decl" *) + let decls : (string * string) list ref = ref [] + + let decls_code () = + (* [!decls] is only reversed for aesthetic reasons. *) + List.mapi (List.rev !decls) ~f:(fun i (name, def) -> + (if i == 0 then "type " else "and ") ^ name ^ " = " ^ def + ) + + let add_decl ~name ~def = + match List.assoc_opt name !decls with + | Some def' -> + if not (String.equal def def') then + failwithf + "%s has conflicting definitions:\n %s\nand\n %s" name def' def + | None -> decls := (name, def) :: !decls + + let unboxed_record name labeled_ts = + let lbls, ts = List.split labeled_ts in + let assemble colon_or_eq fields = + let labeled_fields = + List.map2 lbls fields ~f:(fun s x -> s ^ " " ^ colon_or_eq ^ " " ^ x) + in + "#{ " ^ String.concat ~sep:"; " labeled_fields ^ " }" + in + let assemble_expr fields = "(" ^ assemble "=" fields ^ " : " ^ name ^ ")" in + let value_code i = assemble_expr (map_value_code ts i) in + let mk_value_code = assemble_expr (List.map ts ~f:mk_value_code) in + let pat i = + assemble_expr (List.map lbls ~f:(fun s -> s ^ Int.to_string i)) + in + let eq = + let body = + List.map labeled_ts ~f:(fun (s, t) -> sprintf "%s %s1 %s2" t.eq s s) + |> String.concat ~sep:" && " + in + sprintf "(fun %s %s -> %s)" (pat 1) (pat 2) body + in + add_decl ~name ~def:(assemble ":" (List.map ts ~f:ty_code)); + { + ty_code = name; + value_code; + mk_value_code; + eq; + is_gc_ignorable = List.for_all ~f:is_gc_ignorable ts; + } + + let enum size = + let ith_ctor i = sprintf "A%d_%d" size i in + let def = List.init ~len:size ~f:ith_ctor |> String.concat ~sep:" | " in + let eq = + let eq_pat = + List.init ~len:size ~f:(fun i -> ith_ctor i ^ ", " ^ ith_ctor i) + |> String.concat ~sep:" | " + in + sprintf "(fun a b -> match a, b with %s -> true | _ -> false)" eq_pat + in + let mk_value_code = + let brs = + List.init ~len:size ~f:(fun i -> sprintf "%d -> %s" i (ith_ctor i)) + @ ["_ -> assert false"] + in + sprintf "(match Int.rem i %d with %s)" size (String.concat ~sep:" | " brs) + in + let name = sprintf "enum%d" size in + add_decl ~name ~def; + { + ty_code = name; + value_code = (fun i -> ith_ctor (Int.rem i size)); + mk_value_code; + eq; + is_gc_ignorable = true; + } + + let option t = { + ty_code = t.ty_code ^ " option"; + value_code = + (fun i -> if i == 0 then "None" else "Some " ^ t.value_code i); + mk_value_code = + "(if i == 0 then None else Some (" ^ t.mk_value_code ^ "))"; + eq = "(fun a b -> match a, b with None,None -> true | Some a,Some b -> " + ^ t.eq ^ " a b|_->false)"; + is_gc_ignorable = false; + } + + let gen_tuple ~unboxed ts = + let hash = if unboxed then "#" else "" in + let assemble ~sep xs = sprintf "%s(%s)" hash (String.concat ~sep xs) in + let value_code i = assemble ~sep:", " (map_value_code ts i) in + let mk_value_code = assemble ~sep:", " (List.map ts ~f:mk_value_code) in + let eq = + let pat s = + assemble ~sep:", " (List.mapi ts ~f:(fun i _ -> s ^ Int.to_string i)) + in + let body = + List.mapi ts ~f:(fun i t -> sprintf "%s a%d b%d" t.eq i i) + |> String.concat ~sep:" && " + in + sprintf "(fun %s %s -> %s)" (pat "a") (pat "b") body + in + { + ty_code = assemble ~sep:" * " (List.map ts ~f:ty_code); + value_code; + mk_value_code; + eq; + is_gc_ignorable = unboxed && List.for_all ~f:is_gc_ignorable ts; + } + + let tuple = gen_tuple ~unboxed:false + + let unboxed_tuple = gen_tuple ~unboxed:true + + let int = { + ty_code = "int"; + value_code = Int.to_string; + mk_value_code = "i"; + eq = "(fun a b -> Int.equal a b)"; + is_gc_ignorable = true; + } + + let float = { + ty_code = "float"; + value_code = (fun i -> Int.to_string i ^ "."); + mk_value_code = "Float.of_int i"; + eq = "(fun a b -> Float.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let float_u = { + ty_code = "float#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "."); + mk_value_code = "Float_u.of_int i"; + eq = "(fun a b -> Float_u.(equal (add #0. a) (add #0. b)))"; + is_gc_ignorable = true; + } + + let float32 = { + ty_code = "float32"; + value_code = (fun i -> Int.to_string i ^ ".s"); + mk_value_code = "Float32.of_int i"; + eq = "(fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b))"; + is_gc_ignorable = false; + } + + let float32_u = { + ty_code = "float32#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ ".s"); + mk_value_code = "Float32_u.of_int i"; + eq = "(fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b)))"; + is_gc_ignorable = true; + } + + let int32 = { + ty_code = "int32"; + value_code = (fun i -> Int.to_string i ^ "l"); + mk_value_code = "Int32.of_int i"; + eq = "(fun a b -> Int32.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let int32_u = { + ty_code = "int32#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "l"); + mk_value_code = "Int32_u.of_int i"; + eq = "(fun a b -> Int32_u.(equal (add #0l a) (add #0l b)))"; + is_gc_ignorable = true; + } + + let int64 = { + ty_code = "int64"; + value_code = (fun i -> Int.to_string i ^ "L"); + mk_value_code = "Int64.of_int i"; + eq = "(fun a b -> Int64.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let int64_u = { + ty_code = "int64#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "L"); + mk_value_code = "Int64_u.of_int i"; + eq = "(fun a b -> Int64_u.(equal (add #0L a) (add #0L b)))"; + is_gc_ignorable = true; + } + + let nativeint = { + ty_code = "nativeint"; + value_code = (fun i -> (Int.to_string i) ^ "n"); + mk_value_code = "Nativeint.of_int i"; + eq = "(fun a b -> Nativeint.equal (globalize a) (globalize b))"; + is_gc_ignorable = false; + } + + let nativeint_u = { + ty_code = "nativeint#"; + value_code = (fun i -> "#" ^ Int.to_string i ^ "n"); + mk_value_code = "Nativeint_u.of_int i"; + eq = "(fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b)))"; + is_gc_ignorable = true; + } +end + +let ty_ur1 = Ty.(unboxed_record "ur1" ["a", int64_u; "b", float_u]) +let ty_ur2 = Ty.(unboxed_record "ur2" ["a", int64_u; "b", int]) +let ty_ur3 = Ty.(unboxed_record "ur3" ["a", int64_u]) +let ty_ur4 = Ty.(unboxed_record "ur4" ["a", ty_ur1; "b", ty_ur3]) + +(* Types the GC always ignores, which can be used with %makearray_dynamic_uninit *) +let always_ignored_types = Ty.([ + float32_u; float_u; int32_u; int64_u; nativeint_u; ty_ur1; ty_ur3; ty_ur4; + unboxed_tuple [float_u; int32_u; int64_u]; + unboxed_tuple [ + float_u; + unboxed_tuple [int64_u; int64_u]; + float32_u; + unboxed_tuple [int32_u; unboxed_tuple [float32_u; float_u]]; + int64_u; + ]; + unboxed_tuple [int64_u; ty_ur1]; +]) + +let types = always_ignored_types @ Ty.([ + float32; float; int32; int64; nativeint; int; enum 3; ty_ur2; + unboxed_tuple [int; int64]; + unboxed_tuple [ + option int64; + unboxed_tuple [int; int32; float]; + float; + unboxed_tuple [float32; option (tuple [nativeint; nativeint])]; + int32 + ]; + unboxed_tuple [float; float; float]; + unboxed_tuple [ + float; + unboxed_tuple [float; float]; + unboxed_tuple [float; unboxed_tuple [float; float; float]] + ]; + unboxed_tuple [float_u; int; int64_u]; + unboxed_tuple [ + float_u; + unboxed_tuple [int; int64_u]; + float32_u; + unboxed_tuple [int32_u; unboxed_tuple [float32_u; float_u]]; + int; + ]; + unboxed_tuple [ty_ur2; ty_ur1]; +]) + +let preamble = {| +open Stdlib_upstream_compatible +open Stdlib_stable +module List = ListLabels +module String = StringLabels + +external[@layout_poly] makearray_dynamic_uninit_local : + ('a : any_non_null) . int -> 'a array @ local = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_uninit : + ('a : any_non_null) . int -> 'a array = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_local : + ('a : any_non_null) . int -> 'a -> 'a array @ local = + "%makearray_dynamic" + +external[@layout_poly] makearray_dynamic : + ('a : any_non_null) . int -> 'a -> 'a array = + "%makearray_dynamic" + +external[@layout_poly] get : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = + "%array_safe_get" + +external[@layout_poly] set : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = + "%array_safe_set" + +external[@layout_poly] unsafe_blit : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> ('a array[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = + "%arrayblit" + +let failwithf fmt = Printf.ksprintf failwith fmt + +external globalize : local_ 'a -> 'a = "%obj_dup";; + +(* Redefine iter to infer locality *) +let rec iter ~f = function + [] -> () + | a::l -> f a; iter ~f l + +let tests_run = ref [] + +let mark_test_run test_id = + if not (List.mem ~set:!tests_run test_id) then + tests_run := test_id :: !tests_run + +(* Various interesting values *) + +let sizes = [ 0; 1; 2; 30; 31; 32 ] + +let bad_indices size = + [ -100; -2; -1; size; size + 1; size + 100; Int.min_int; Int.max_int ] + +let blit_offsets size = + let candidates = [ 0; 1; size / 3; size / 2; size - 1; size ] in + List.filter candidates ~f:(fun ofs -> ofs > 0 && ofs < size) + |> List.sort_uniq ~cmp:Int.compare + +let blit_lens ~ofs1 ~ofs2 ~size1 ~size2 = + let len_until_end = Int.min (size1 - ofs1) (size2 - ofs2) in + let candidates = [ 0; 1; size1 / 2; len_until_end - 1; len_until_end ] in + List.filter candidates ~f:(fun len -> ofs1 + len <= size1 && ofs2 + len <= size2) + |> List.sort_uniq ~cmp:Int.compare +|} + +let indent = ref 0 + +let with_indent f = incr indent; f (); decr indent + +let line fmt = + Printf.ksprintf + (fun s -> + let indent = Seq.init (!indent * 2) (fun _ -> ' ') |> String.of_seq in + print_endline (indent ^ s); + flush stdout) + fmt + +let print_in_test s = + line {|let () = Printf.printf "%s%%!\n";;|} (String.escaped s) + +let seq_print_in_test s = + line {|print_endline "%s%!";|} (String.escaped s) + +let makearray_dynamic_fn ~uninit ~local = + let uninit_s = if uninit then "_uninit" else "" in + let local_s = if local then "_local" else "" in + "makearray_dynamic" ^ uninit_s ^ local_s + +type debug_expr = { expr : string ; format_s : string } + +let concat_with_leading_spaces l = + List.map l ~f:(fun s -> " " ^ s) + |> String.concat ~sep:"" + +let combine_debug_exprs (l : debug_expr list) : debug_expr = + let debug_expr_to_tuple { expr ; format_s } = expr, format_s in + let exprs, format_ss = List.split (List.rev_map ~f:debug_expr_to_tuple l) in + let expr = concat_with_leading_spaces exprs in + let format_s = concat_with_leading_spaces format_ss in + { expr; format_s } + +let seq_print_debug_exprs ~debug_exprs = + let { expr ; format_s } = combine_debug_exprs debug_exprs in + line {|Printf.printf "%s: %s\n%%!"%s;|} expr format_s expr + +let test_id = ref 0 + +let seq_assert ~debug_exprs s = + incr test_id; + let { expr ; format_s } = combine_debug_exprs debug_exprs in + line "mark_test_run %d;" !test_id; + line "let test = %s in" s; + line {|if not test then failwithf "test %d failed%s"%s;|} + !test_id format_s expr + +let for_ var ~from ~to_ ~debug_exprs f = + line "for %s = %s to %s do" var from to_; + with_indent (fun () -> + let debug_exprs = { expr = var; format_s = "%d" } :: debug_exprs in + f ~debug_exprs + ); + line "done;" + +let for_i_below_size = for_ "i" ~from:"0" ~to_:"size - 1" + +(* Iterate through a list of ints *) +let iter l var ~debug_exprs f = + line "iter (%s) ~f:(fun %s ->" l var; + with_indent (fun () -> + let debug_exprs = { expr = var; format_s = "%d" } :: debug_exprs in + f ~debug_exprs + ); + line ") [@nontail];" + +let section s = + let s_as_stars = String.init (String.length s) ~f:(fun _ -> '*') in + line "(**%s**)" s_as_stars; + line "(* %s *)" s; + line "(**%s**)" s_as_stars + +(* Test steps: + 1. Create an array, possibly local, possibly uninitialized + 2. For initialized arrays, check all elements have the correct value + 3. Fill array with distinct values and read back those values + 4. Check that getting bad indices errors + 5. Check that setting bad indices errors + 6. Check that array contents were unaffected by setting bad indices + 7. Overlapping blits + 8. Blits to heap arrays + 9. Blits to local arrays +*) +let test_makearray_dynamic ~uninit ~local ty = + let makearray_dynamic = makearray_dynamic_fn ~uninit ~local in + let debug_exprs = [{ expr = "size"; format_s = "%d"}] in + let ty_array_s = ty.Ty.ty_code ^ " array" in + (* seq_print_in_test ty.Ty.ty_code; *) + section (" " ^ ty.Ty.ty_code ^ " "); + line "let eq = %s in" ty.Ty.eq; + line "let mk_value i = %s in" ty.Ty.mk_value_code; + line "(* 1. Create an array of size [size] *)"; + (if uninit then ( + line "let a : %s = %s size in" ty_array_s makearray_dynamic; + line "(* 2. For uninitialized arrays, element values are unspecified *)" + ) else + line "let a : %s = %s size %s in" ty_array_s makearray_dynamic (ty.Ty.value_code 0); + line "(* 2. For initialized arrays, check all elements have the correct value *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "let el = get a i in"; + if uninit then + line "let _ = el in ()" + else ( + let test = sprintf "eq el %s" (ty.Ty.value_code 0) in + seq_assert ~debug_exprs test; + ) + )); + line "(* 3. Fill [a] with distinct values and read back those values *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "set a i (mk_value i);" + ); + line "Gc.compact ();"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + seq_assert ~debug_exprs "eq (get a i) (mk_value i)" + ); + iter "bad_indices size" "i" ~debug_exprs (fun ~debug_exprs -> + line "(* 4. Getting bad indices errors *)"; + line "let raises ="; + with_indent (fun () -> + line "match get a i with"; + line "| exception Invalid_argument _ -> true"; + line "| _ -> false" + ); + line "in"; + seq_assert ~debug_exprs "raises"; + line "(* 5. Setting bad indices errors *)"; + line "let raises ="; + with_indent (fun () -> + line "match set a i %s with" (ty.Ty.value_code 0); + line "| exception Invalid_argument _ -> true"; + line "| _ -> false" + ); + line "in"; + seq_assert ~debug_exprs "raises" + ); + line "Gc.compact ();"; + line "(* 6. Array contents were unaffacted by setting bad indices *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + seq_assert ~debug_exprs "eq (get a i) (mk_value i)" + ); + (* Blits currently only work for GC ignorable values *) + line "(* 7. Overlapping blits *)"; + iter "blit_offsets size" "ofs1" ~debug_exprs (fun ~debug_exprs -> + iter "blit_offsets size" "ofs2" ~debug_exprs (fun ~debug_exprs -> + let lens = "blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size" in + iter lens "len" ~debug_exprs (fun ~debug_exprs -> + line "unsafe_blit a ofs1 a ofs2 len;"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "let expected_src_i ="; + with_indent (fun () -> + line "if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i" + ); + line "in"; + seq_assert ~debug_exprs "eq (get a i) (mk_value expected_src_i)" + ); + line "(* Reset array *)"; + for_i_below_size ~debug_exprs (fun ~debug_exprs -> + line "set a i (mk_value i);" + ) + ); + ); + ); + line "Gc.compact ();"; + let test_blit_to ~to_local = + iter "sizes" "size2" ~debug_exprs (fun ~debug_exprs -> + iter "blit_offsets size" "ofs1" ~debug_exprs (fun ~debug_exprs -> + iter "blit_offsets size2" "ofs2" ~debug_exprs (fun ~debug_exprs -> + let lens = "blit_lens ~ofs1 ~ofs2 ~size1:size ~size2" in + iter lens "len" ~debug_exprs (fun ~debug_exprs -> + (if to_local then + line "let local_ a2 = makearray_dynamic_local size2 %s in" (ty.Ty.value_code 0) + else + line "let a2 = makearray_dynamic size2 %s in" (ty.Ty.value_code 0)); + line "unsafe_blit a ofs1 a2 ofs2 len;"; + for_ "i" ~from:"0" ~to_:"size2 - 1" ~debug_exprs (fun ~debug_exprs -> + line "let expected_src_i ="; + with_indent (fun () -> + line "if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0" + ); + line "in"; + seq_assert ~debug_exprs "eq (get a2 i) (mk_value expected_src_i)" + ) + ) + ) + ) + ); + line "Gc.compact ();" + in + line "(* 8. Blits to heap arrays *)"; + test_blit_to ~to_local:false; + line "(* 9. Blits to local arrays *)"; + test_blit_to ~to_local:true; + print_endline "" + +let toplevel_unit_block f = + assert (Int.equal !indent 0); + line "let () ="; + with_indent (fun () -> + f (); line "()" + ); + line ";;"; + line "" + +let main ~bytecode = + let debug_exprs = [] in + line {|(* TEST + include stdlib_stable; + include stdlib_upstream_compatible;|}; + if bytecode then ( + line {| flags = "-extension layouts_beta";|}; + (* CR layouts: enable for arm64 once float32 is available *) + line {| arch_amd64;|}; + line {| bytecode;|}; + ) else ( + line {| modules = "stubs.c";|}; + line {| flags = "-extension layouts_beta -extension simd_beta";|}; + line {| flambda2;|}; + line {| stack-allocation;|}; + line {| arch_amd64;|}; + line {| native;|}; + ); + line {|*)|}; + line "(** This is code generated by [generate_makearray_dynamic_tests.ml]. *)"; + line ""; + line "%s" preamble; + List.iter (Ty.decls_code ()) ~f:(fun s -> line "%s" s); + line ""; + line "(* Catch metaprogramming errors early *)"; + toplevel_unit_block (fun () -> + let open Ty in + line "(* Check types and constants *)"; + List.iter types ~f:(fun ty -> + line "let _ : %s = %s in" ty.ty_code (ty.value_code 0) + ); + line "(* Check equality and mk_value functions *)"; + List.iter types ~f:(fun ty -> + line "let eq : %s @ local -> %s @ local -> bool = %s in" + ty.ty_code ty.ty_code ty.eq; + line "let mk_value i = %s in" ty.mk_value_code; + seq_assert ~debug_exprs + (sprintf "eq (mk_value 1) %s" (ty.value_code 1)); + seq_assert ~debug_exprs + (sprintf "eq %s %s" (ty.value_code 1) (ty.value_code 1)); + seq_assert ~debug_exprs + (sprintf "not (eq %s %s)" (ty.value_code 1) (ty.value_code 2)) + ); + line "(* Check always-GC-ignored types *)"; + List.iter always_ignored_types ~f:(fun ty -> + line "let _ = (makearray_dynamic_uninit 1 : %s array) in" (ty.ty_code) + ); + ); + List.iter [false; true] ~f:(fun uninit -> + List.iter [false; true] ~f:(fun local -> + line "let test_%s size =" (makearray_dynamic_fn ~uninit ~local); + with_indent (fun () -> + let tys = if uninit then always_ignored_types else types in + List.iter tys ~f:(test_makearray_dynamic ~uninit ~local); + line "()"; + ); + line ""; + ) + ); + line "(* Main tests *)"; + toplevel_unit_block (fun () -> + List.iter [false; true] ~f:(fun uninit -> + List.iter [false; true] ~f:(fun local -> + let test_fn = "test_" ^ makearray_dynamic_fn ~uninit ~local in + seq_print_in_test test_fn; + line "iter sizes ~f:%s;" test_fn + ) + ) + ); + line "for i = 1 to %d do" !test_id; + with_indent (fun () -> + line + {|if not (List.mem ~set:!tests_run i) then failwithf "test %%d not run" i|} + ); + line "done;;"; + print_in_test "All tests passed." + +let () = + let bytecode = + match Sys.argv with + | [| _; "native" |] -> false + | [| _; "byte" |] -> true + | _ -> failwith (sprintf "Usage %s " Sys.argv.(0)) + in + main ~bytecode diff --git a/testsuite/tests/typing-layouts-arrays/generated_test.ml b/testsuite/tests/typing-layouts-arrays/generated_test.ml new file mode 100644 index 00000000000..873b18854ae --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/generated_test.ml @@ -0,0 +1,8785 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + modules = "stubs.c"; + flags = "-extension layouts_beta -extension simd_beta"; + flambda2; + stack-allocation; + arch_amd64; + native; +*) +(** This is code generated by [generate_makearray_dynamic_tests.ml]. *) + + +open Stdlib_upstream_compatible +open Stdlib_stable +module List = ListLabels +module String = StringLabels + +external[@layout_poly] makearray_dynamic_uninit_local : + ('a : any_non_null) . int -> 'a array @ local = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_uninit : + ('a : any_non_null) . int -> 'a array = + "%makearray_dynamic_uninit" + +external[@layout_poly] makearray_dynamic_local : + ('a : any_non_null) . int -> 'a -> 'a array @ local = + "%makearray_dynamic" + +external[@layout_poly] makearray_dynamic : + ('a : any_non_null) . int -> 'a -> 'a array = + "%makearray_dynamic" + +external[@layout_poly] get : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a = + "%array_safe_get" + +external[@layout_poly] set : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> 'a -> unit = + "%array_safe_set" + +external[@layout_poly] unsafe_blit : + ('a : any_non_null) . ('a array[@local_opt]) -> (int[@local_opt]) -> ('a array[@local_opt]) -> (int[@local_opt]) -> (int[@local_opt]) -> unit = + "%arrayblit" + +let failwithf fmt = Printf.ksprintf failwith fmt + +external globalize : local_ 'a -> 'a = "%obj_dup";; + +(* Redefine iter to infer locality *) +let rec iter ~f = function + [] -> () + | a::l -> f a; iter ~f l + +let tests_run = ref [] + +let mark_test_run test_id = + if not (List.mem ~set:!tests_run test_id) then + tests_run := test_id :: !tests_run + +(* Various interesting values *) + +let sizes = [ 0; 1; 2; 30; 31; 32 ] + +let bad_indices size = + [ -100; -2; -1; size; size + 1; size + 100; Int.min_int; Int.max_int ] + +let blit_offsets size = + let candidates = [ 0; 1; size / 3; size / 2; size - 1; size ] in + List.filter candidates ~f:(fun ofs -> ofs > 0 && ofs < size) + |> List.sort_uniq ~cmp:Int.compare + +let blit_lens ~ofs1 ~ofs2 ~size1 ~size2 = + let len_until_end = Int.min (size1 - ofs1) (size2 - ofs2) in + let candidates = [ 0; 1; size1 / 2; len_until_end - 1; len_until_end ] in + List.filter candidates ~f:(fun len -> ofs1 + len <= size1 && ofs2 + len <= size2) + |> List.sort_uniq ~cmp:Int.compare + +type ur1 = #{ a : int64#; b : float# } +and ur2 = #{ a : int64#; b : int } +and ur3 = #{ a : int64# } +and ur4 = #{ a : ur1; b : ur3 } +and enum3 = A3_0 | A3_1 | A3_2 + +(* Catch metaprogramming errors early *) +let () = + (* Check types and constants *) + let _ : float32# = #0.s in + let _ : float# = #0. in + let _ : int32# = #0l in + let _ : int64# = #0L in + let _ : nativeint# = #0n in + let _ : ur1 = (#{ a = #0L; b = #0. } : ur1) in + let _ : ur3 = (#{ a = #0L } : ur3) in + let _ : ur4 = (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + let _ : #(float# * int32# * int64#) = #(#0., #0l, #0L) in + let _ : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) = #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + let _ : #(int64# * ur1) = #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + let _ : float32 = 0.s in + let _ : float = 0. in + let _ : int32 = 0l in + let _ : int64 = 0L in + let _ : nativeint = 0n in + let _ : int = 0 in + let _ : enum3 = A3_0 in + let _ : ur2 = (#{ a = #0L; b = 0 } : ur2) in + let _ : #(int * int64) = #(0, 0L) in + let _ : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) = #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + let _ : #(float * float * float) = #(0., 0., 0.) in + let _ : #(float * #(float * float) * #(float * #(float * float * float))) = #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + let _ : #(float# * int * int64#) = #(#0., 0, #0L) in + let _ : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) = #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + let _ : #(ur2 * ur1) = #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + (* Check equality and mk_value functions *) + let eq : float32# @ local -> float32# @ local -> bool = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + mark_test_run 1; + let test = eq (mk_value 1) #1.s in + if not test then failwithf "test 1 failed"; + mark_test_run 2; + let test = eq #1.s #1.s in + if not test then failwithf "test 2 failed"; + mark_test_run 3; + let test = not (eq #1.s #2.s) in + if not test then failwithf "test 3 failed"; + let eq : float# @ local -> float# @ local -> bool = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + mark_test_run 4; + let test = eq (mk_value 1) #1. in + if not test then failwithf "test 4 failed"; + mark_test_run 5; + let test = eq #1. #1. in + if not test then failwithf "test 5 failed"; + mark_test_run 6; + let test = not (eq #1. #2.) in + if not test then failwithf "test 6 failed"; + let eq : int32# @ local -> int32# @ local -> bool = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + mark_test_run 7; + let test = eq (mk_value 1) #1l in + if not test then failwithf "test 7 failed"; + mark_test_run 8; + let test = eq #1l #1l in + if not test then failwithf "test 8 failed"; + mark_test_run 9; + let test = not (eq #1l #2l) in + if not test then failwithf "test 9 failed"; + let eq : int64# @ local -> int64# @ local -> bool = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + mark_test_run 10; + let test = eq (mk_value 1) #1L in + if not test then failwithf "test 10 failed"; + mark_test_run 11; + let test = eq #1L #1L in + if not test then failwithf "test 11 failed"; + mark_test_run 12; + let test = not (eq #1L #2L) in + if not test then failwithf "test 12 failed"; + let eq : nativeint# @ local -> nativeint# @ local -> bool = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + mark_test_run 13; + let test = eq (mk_value 1) #1n in + if not test then failwithf "test 13 failed"; + mark_test_run 14; + let test = eq #1n #1n in + if not test then failwithf "test 14 failed"; + mark_test_run 15; + let test = not (eq #1n #2n) in + if not test then failwithf "test 15 failed"; + let eq : ur1 @ local -> ur1 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + mark_test_run 16; + let test = eq (mk_value 1) (#{ a = #1L; b = #1. } : ur1) in + if not test then failwithf "test 16 failed"; + mark_test_run 17; + let test = eq (#{ a = #1L; b = #1. } : ur1) (#{ a = #1L; b = #1. } : ur1) in + if not test then failwithf "test 17 failed"; + mark_test_run 18; + let test = not (eq (#{ a = #1L; b = #1. } : ur1) (#{ a = #2L; b = #2. } : ur1)) in + if not test then failwithf "test 18 failed"; + let eq : ur3 @ local -> ur3 @ local -> bool = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + mark_test_run 19; + let test = eq (mk_value 1) (#{ a = #1L } : ur3) in + if not test then failwithf "test 19 failed"; + mark_test_run 20; + let test = eq (#{ a = #1L } : ur3) (#{ a = #1L } : ur3) in + if not test then failwithf "test 20 failed"; + mark_test_run 21; + let test = not (eq (#{ a = #1L } : ur3) (#{ a = #2L } : ur3)) in + if not test then failwithf "test 21 failed"; + let eq : ur4 @ local -> ur4 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + mark_test_run 22; + let test = eq (mk_value 1) (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) in + if not test then failwithf "test 22 failed"; + mark_test_run 23; + let test = eq (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) in + if not test then failwithf "test 23 failed"; + mark_test_run 24; + let test = not (eq (#{ a = (#{ a = #1L; b = #1. } : ur1); b = (#{ a = #1L } : ur3) } : ur4) (#{ a = (#{ a = #2L; b = #2. } : ur1); b = (#{ a = #2L } : ur3) } : ur4)) in + if not test then failwithf "test 24 failed"; + let eq : #(float# * int32# * int64#) @ local -> #(float# * int32# * int64#) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + mark_test_run 25; + let test = eq (mk_value 1) #(#1., #1l, #1L) in + if not test then failwithf "test 25 failed"; + mark_test_run 26; + let test = eq #(#1., #1l, #1L) #(#1., #1l, #1L) in + if not test then failwithf "test 26 failed"; + mark_test_run 27; + let test = not (eq #(#1., #1l, #1L) #(#2., #2l, #2L)) in + if not test then failwithf "test 27 failed"; + let eq : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) @ local -> #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + mark_test_run 28; + let test = eq (mk_value 1) #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) in + if not test then failwithf "test 28 failed"; + mark_test_run 29; + let test = eq #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) in + if not test then failwithf "test 29 failed"; + mark_test_run 30; + let test = not (eq #(#1., #(#1L, #1L), #1.s, #(#1l, #(#1.s, #1.)), #1L) #(#2., #(#2L, #2L), #2.s, #(#2l, #(#2.s, #2.)), #2L)) in + if not test then failwithf "test 30 failed"; + let eq : #(int64# * ur1) @ local -> #(int64# * ur1) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + mark_test_run 31; + let test = eq (mk_value 1) #(#1L, (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 31 failed"; + mark_test_run 32; + let test = eq #(#1L, (#{ a = #1L; b = #1. } : ur1)) #(#1L, (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 32 failed"; + mark_test_run 33; + let test = not (eq #(#1L, (#{ a = #1L; b = #1. } : ur1)) #(#2L, (#{ a = #2L; b = #2. } : ur1))) in + if not test then failwithf "test 33 failed"; + let eq : float32 @ local -> float32 @ local -> bool = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in + let mk_value i = Float32.of_int i in + mark_test_run 34; + let test = eq (mk_value 1) 1.s in + if not test then failwithf "test 34 failed"; + mark_test_run 35; + let test = eq 1.s 1.s in + if not test then failwithf "test 35 failed"; + mark_test_run 36; + let test = not (eq 1.s 2.s) in + if not test then failwithf "test 36 failed"; + let eq : float @ local -> float @ local -> bool = (fun a b -> Float.equal (globalize a) (globalize b)) in + let mk_value i = Float.of_int i in + mark_test_run 37; + let test = eq (mk_value 1) 1. in + if not test then failwithf "test 37 failed"; + mark_test_run 38; + let test = eq 1. 1. in + if not test then failwithf "test 38 failed"; + mark_test_run 39; + let test = not (eq 1. 2.) in + if not test then failwithf "test 39 failed"; + let eq : int32 @ local -> int32 @ local -> bool = (fun a b -> Int32.equal (globalize a) (globalize b)) in + let mk_value i = Int32.of_int i in + mark_test_run 40; + let test = eq (mk_value 1) 1l in + if not test then failwithf "test 40 failed"; + mark_test_run 41; + let test = eq 1l 1l in + if not test then failwithf "test 41 failed"; + mark_test_run 42; + let test = not (eq 1l 2l) in + if not test then failwithf "test 42 failed"; + let eq : int64 @ local -> int64 @ local -> bool = (fun a b -> Int64.equal (globalize a) (globalize b)) in + let mk_value i = Int64.of_int i in + mark_test_run 43; + let test = eq (mk_value 1) 1L in + if not test then failwithf "test 43 failed"; + mark_test_run 44; + let test = eq 1L 1L in + if not test then failwithf "test 44 failed"; + mark_test_run 45; + let test = not (eq 1L 2L) in + if not test then failwithf "test 45 failed"; + let eq : nativeint @ local -> nativeint @ local -> bool = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in + let mk_value i = Nativeint.of_int i in + mark_test_run 46; + let test = eq (mk_value 1) 1n in + if not test then failwithf "test 46 failed"; + mark_test_run 47; + let test = eq 1n 1n in + if not test then failwithf "test 47 failed"; + mark_test_run 48; + let test = not (eq 1n 2n) in + if not test then failwithf "test 48 failed"; + let eq : int @ local -> int @ local -> bool = (fun a b -> Int.equal a b) in + let mk_value i = i in + mark_test_run 49; + let test = eq (mk_value 1) 1 in + if not test then failwithf "test 49 failed"; + mark_test_run 50; + let test = eq 1 1 in + if not test then failwithf "test 50 failed"; + mark_test_run 51; + let test = not (eq 1 2) in + if not test then failwithf "test 51 failed"; + let eq : enum3 @ local -> enum3 @ local -> bool = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in + let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in + mark_test_run 52; + let test = eq (mk_value 1) A3_1 in + if not test then failwithf "test 52 failed"; + mark_test_run 53; + let test = eq A3_1 A3_1 in + if not test then failwithf "test 53 failed"; + mark_test_run 54; + let test = not (eq A3_1 A3_2) in + if not test then failwithf "test 54 failed"; + let eq : ur2 @ local -> ur2 @ local -> bool = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in + mark_test_run 55; + let test = eq (mk_value 1) (#{ a = #1L; b = 1 } : ur2) in + if not test then failwithf "test 55 failed"; + mark_test_run 56; + let test = eq (#{ a = #1L; b = 1 } : ur2) (#{ a = #1L; b = 1 } : ur2) in + if not test then failwithf "test 56 failed"; + mark_test_run 57; + let test = not (eq (#{ a = #1L; b = 1 } : ur2) (#{ a = #2L; b = 2 } : ur2)) in + if not test then failwithf "test 57 failed"; + let eq : #(int * int64) @ local -> #(int * int64) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in + let mk_value i = #(i, Int64.of_int i) in + mark_test_run 58; + let test = eq (mk_value 1) #(1, 1L) in + if not test then failwithf "test 58 failed"; + mark_test_run 59; + let test = eq #(1, 1L) #(1, 1L) in + if not test then failwithf "test 59 failed"; + mark_test_run 60; + let test = not (eq #(1, 1L) #(2, 2L)) in + if not test then failwithf "test 60 failed"; + let eq : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) @ local -> #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in + let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in + mark_test_run 61; + let test = eq (mk_value 1) #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) in + if not test then failwithf "test 61 failed"; + mark_test_run 62; + let test = eq #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) in + if not test then failwithf "test 62 failed"; + mark_test_run 63; + let test = not (eq #(Some 1L, #(1, 1l, 1.), 1., #(1.s, Some (1n, 1n)), 1l) #(Some 2L, #(2, 2l, 2.), 2., #(2.s, Some (2n, 2n)), 2l)) in + if not test then failwithf "test 63 failed"; + let eq : #(float * float * float) @ local -> #(float * float * float) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in + let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in + mark_test_run 64; + let test = eq (mk_value 1) #(1., 1., 1.) in + if not test then failwithf "test 64 failed"; + mark_test_run 65; + let test = eq #(1., 1., 1.) #(1., 1., 1.) in + if not test then failwithf "test 65 failed"; + mark_test_run 66; + let test = not (eq #(1., 1., 1.) #(2., 2., 2.)) in + if not test then failwithf "test 66 failed"; + let eq : #(float * #(float * float) * #(float * #(float * float * float))) @ local -> #(float * #(float * float) * #(float * #(float * float * float))) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in + let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in + mark_test_run 67; + let test = eq (mk_value 1) #(1., #(1., 1.), #(1., #(1., 1., 1.))) in + if not test then failwithf "test 67 failed"; + mark_test_run 68; + let test = eq #(1., #(1., 1.), #(1., #(1., 1., 1.))) #(1., #(1., 1.), #(1., #(1., 1., 1.))) in + if not test then failwithf "test 68 failed"; + mark_test_run 69; + let test = not (eq #(1., #(1., 1.), #(1., #(1., 1., 1.))) #(2., #(2., 2.), #(2., #(2., 2., 2.)))) in + if not test then failwithf "test 69 failed"; + let eq : #(float# * int * int64#) @ local -> #(float# * int * int64#) @ local -> bool = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in + mark_test_run 70; + let test = eq (mk_value 1) #(#1., 1, #1L) in + if not test then failwithf "test 70 failed"; + mark_test_run 71; + let test = eq #(#1., 1, #1L) #(#1., 1, #1L) in + if not test then failwithf "test 71 failed"; + mark_test_run 72; + let test = not (eq #(#1., 1, #1L) #(#2., 2, #2L)) in + if not test then failwithf "test 72 failed"; + let eq : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) @ local -> #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) @ local -> bool = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in + mark_test_run 73; + let test = eq (mk_value 1) #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) in + if not test then failwithf "test 73 failed"; + mark_test_run 74; + let test = eq #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) in + if not test then failwithf "test 74 failed"; + mark_test_run 75; + let test = not (eq #(#1., #(1, #1L), #1.s, #(#1l, #(#1.s, #1.)), 1) #(#2., #(2, #2L), #2.s, #(#2l, #(#2.s, #2.)), 2)) in + if not test then failwithf "test 75 failed"; + let eq : #(ur2 * ur1) @ local -> #(ur2 * ur1) @ local -> bool = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + mark_test_run 76; + let test = eq (mk_value 1) #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 76 failed"; + mark_test_run 77; + let test = eq #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) in + if not test then failwithf "test 77 failed"; + mark_test_run 78; + let test = not (eq #((#{ a = #1L; b = 1 } : ur2), (#{ a = #1L; b = #1. } : ur1)) #((#{ a = #2L; b = 2 } : ur2), (#{ a = #2L; b = #2. } : ur1))) in + if not test then failwithf "test 78 failed"; + (* Check always-GC-ignored types *) + let _ = (makearray_dynamic_uninit 1 : float32# array) in + let _ = (makearray_dynamic_uninit 1 : float# array) in + let _ = (makearray_dynamic_uninit 1 : int32# array) in + let _ = (makearray_dynamic_uninit 1 : int64# array) in + let _ = (makearray_dynamic_uninit 1 : nativeint# array) in + let _ = (makearray_dynamic_uninit 1 : ur1 array) in + let _ = (makearray_dynamic_uninit 1 : ur3 array) in + let _ = (makearray_dynamic_uninit 1 : ur4 array) in + let _ = (makearray_dynamic_uninit 1 : #(float# * int32# * int64#) array) in + let _ = (makearray_dynamic_uninit 1 : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array) in + let _ = (makearray_dynamic_uninit 1 : #(int64# * ur1) array) in + () +;; + +let test_makearray_dynamic size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic size #0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 79; + let test = eq el #0.s in + if not test then failwithf "test 79 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 80; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 80 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 81; + let test = raises in + if not test then failwithf "test 81 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 82; + let test = raises in + if not test then failwithf "test 82 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 83; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 83 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 84; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 84 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 85; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 85 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 86; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 86 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic size #0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 87; + let test = eq el #0. in + if not test then failwithf "test 87 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 88; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 88 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 89; + let test = raises in + if not test then failwithf "test 89 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 90; + let test = raises in + if not test then failwithf "test 90 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 91; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 91 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 92; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 92 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 93; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 93 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 94; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 94 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic size #0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 95; + let test = eq el #0l in + if not test then failwithf "test 95 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 96; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 96 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 97; + let test = raises in + if not test then failwithf "test 97 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 98; + let test = raises in + if not test then failwithf "test 98 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 99; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 99 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 100; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 100 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 101; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 101 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 102; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 102 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic size #0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 103; + let test = eq el #0L in + if not test then failwithf "test 103 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 104; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 104 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 105; + let test = raises in + if not test then failwithf "test 105 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 106; + let test = raises in + if not test then failwithf "test 106 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 107; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 107 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 108; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 108 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 109; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 109 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 110; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 110 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic size #0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 111; + let test = eq el #0n in + if not test then failwithf "test 111 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 112; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 112 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 113; + let test = raises in + if not test then failwithf "test 113 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 114; + let test = raises in + if not test then failwithf "test 114 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 115; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 115 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 116; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 116 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 117; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 117 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 118; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 118 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic size (#{ a = #0L; b = #0. } : ur1) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 119; + let test = eq el (#{ a = #0L; b = #0. } : ur1) in + if not test then failwithf "test 119 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 120; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 120 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 121; + let test = raises in + if not test then failwithf "test 121 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 122; + let test = raises in + if not test then failwithf "test 122 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 123; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 123 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 124; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 124 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 125; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 125 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 126; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 126 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic size (#{ a = #0L } : ur3) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 127; + let test = eq el (#{ a = #0L } : ur3) in + if not test then failwithf "test 127 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 128; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 128 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 129; + let test = raises in + if not test then failwithf "test 129 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 130; + let test = raises in + if not test then failwithf "test 130 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 131; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 131 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 132; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 132 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 133; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 133 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 134; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 134 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic size (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 135; + let test = eq el (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + if not test then failwithf "test 135 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 136; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 136 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 137; + let test = raises in + if not test then failwithf "test 137 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 138; + let test = raises in + if not test then failwithf "test 138 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 139; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 139 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 140; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 140 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 141; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 141 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 142; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 142 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic size #(#0., #0l, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 143; + let test = eq el #(#0., #0l, #0L) in + if not test then failwithf "test 143 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 144; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 144 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 145; + let test = raises in + if not test then failwithf "test 145 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 146; + let test = raises in + if not test then failwithf "test 146 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 147; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 147 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 148; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 148 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 149; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 149 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 150; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 150 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic size #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 151; + let test = eq el #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + if not test then failwithf "test 151 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 152; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 152 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 153; + let test = raises in + if not test then failwithf "test 153 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 154; + let test = raises in + if not test then failwithf "test 154 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 155; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 155 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 156; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 156 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 157; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 157 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 158; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 158 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic size #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 159; + let test = eq el #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 159 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 160; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 160 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 161; + let test = raises in + if not test then failwithf "test 161 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 162; + let test = raises in + if not test then failwithf "test 162 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 163; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 163 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 164; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 164 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 165; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 165 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 166; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 166 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************) + (* float32 *) + (***************) + let eq = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in + let mk_value i = Float32.of_int i in + (* 1. Create an array of size [size] *) + let a : float32 array = makearray_dynamic size 0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 167; + let test = eq el 0.s in + if not test then failwithf "test 167 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 168; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 168 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 169; + let test = raises in + if not test then failwithf "test 169 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 170; + let test = raises in + if not test then failwithf "test 170 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 171; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 171 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 172; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 172 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 173; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 173 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 174; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 174 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* float *) + (*************) + let eq = (fun a b -> Float.equal (globalize a) (globalize b)) in + let mk_value i = Float.of_int i in + (* 1. Create an array of size [size] *) + let a : float array = makearray_dynamic size 0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 175; + let test = eq el 0. in + if not test then failwithf "test 175 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 176; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 176 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 177; + let test = raises in + if not test then failwithf "test 177 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 178; + let test = raises in + if not test then failwithf "test 178 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 179; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 179 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 180; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 180 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 181; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 181 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 182; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 182 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int32 *) + (*************) + let eq = (fun a b -> Int32.equal (globalize a) (globalize b)) in + let mk_value i = Int32.of_int i in + (* 1. Create an array of size [size] *) + let a : int32 array = makearray_dynamic size 0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 183; + let test = eq el 0l in + if not test then failwithf "test 183 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 184; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 184 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 185; + let test = raises in + if not test then failwithf "test 185 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 186; + let test = raises in + if not test then failwithf "test 186 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 187; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 187 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 188; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 188 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 189; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 189 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 190; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 190 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int64 *) + (*************) + let eq = (fun a b -> Int64.equal (globalize a) (globalize b)) in + let mk_value i = Int64.of_int i in + (* 1. Create an array of size [size] *) + let a : int64 array = makearray_dynamic size 0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 191; + let test = eq el 0L in + if not test then failwithf "test 191 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 192; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 192 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 193; + let test = raises in + if not test then failwithf "test 193 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 194; + let test = raises in + if not test then failwithf "test 194 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 195; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 195 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 196; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 196 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 197; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 197 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 198; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 198 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*****************) + (* nativeint *) + (*****************) + let eq = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in + let mk_value i = Nativeint.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint array = makearray_dynamic size 0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 199; + let test = eq el 0n in + if not test then failwithf "test 199 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 200; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 200 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 201; + let test = raises in + if not test then failwithf "test 201 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 202; + let test = raises in + if not test then failwithf "test 202 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 203; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 203 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 204; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 204 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 205; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 205 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 206; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 206 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* int *) + (***********) + let eq = (fun a b -> Int.equal a b) in + let mk_value i = i in + (* 1. Create an array of size [size] *) + let a : int array = makearray_dynamic size 0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 207; + let test = eq el 0 in + if not test then failwithf "test 207 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 208; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 208 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 209; + let test = raises in + if not test then failwithf "test 209 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 210; + let test = raises in + if not test then failwithf "test 210 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 211; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 211 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 212; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 212 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 213; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 213 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 214; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 214 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* enum3 *) + (*************) + let eq = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in + let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in + (* 1. Create an array of size [size] *) + let a : enum3 array = makearray_dynamic size A3_0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 215; + let test = eq el A3_0 in + if not test then failwithf "test 215 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 216; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 216 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 217; + let test = raises in + if not test then failwithf "test 217 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i A3_0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 218; + let test = raises in + if not test then failwithf "test 218 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 219; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 219 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 220; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 220 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 221; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 221 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 222; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 222 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur2 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in + (* 1. Create an array of size [size] *) + let a : ur2 array = makearray_dynamic size (#{ a = #0L; b = 0 } : ur2) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 223; + let test = eq el (#{ a = #0L; b = 0 } : ur2) in + if not test then failwithf "test 223 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 224; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 224 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 225; + let test = raises in + if not test then failwithf "test 225 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = 0 } : ur2) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 226; + let test = raises in + if not test then failwithf "test 226 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 227; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 227 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 228; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 228 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 229; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 229 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 230; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 230 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**********************) + (* #(int * int64) *) + (**********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in + let mk_value i = #(i, Int64.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int * int64) array = makearray_dynamic size #(0, 0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 231; + let test = eq el #(0, 0L) in + if not test then failwithf "test 231 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 232; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 232 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 233; + let test = raises in + if not test then failwithf "test 233 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0, 0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 234; + let test = raises in + if not test then failwithf "test 234 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 235; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 235 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 236; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 236 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 237; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 237 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 238; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 238 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************************************************************************************************************) + (* #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) *) + (**************************************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in + let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) array = makearray_dynamic size #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 239; + let test = eq el #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + if not test then failwithf "test 239 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 240; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 240 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 241; + let test = raises in + if not test then failwithf "test 241 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 242; + let test = raises in + if not test then failwithf "test 242 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 243; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 243 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 244; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 244 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 245; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 245 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 246; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 246 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float * float * float) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in + let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float * float * float) array = makearray_dynamic size #(0., 0., 0.) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 247; + let test = eq el #(0., 0., 0.) in + if not test then failwithf "test 247 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 248; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 248 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 249; + let test = raises in + if not test then failwithf "test 249 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., 0., 0.) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 250; + let test = raises in + if not test then failwithf "test 250 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 251; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 251 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 252; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 252 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 253; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 253 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 254; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 254 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************************************************************************) + (* #(float * #(float * float) * #(float * #(float * float * float))) *) + (*************************************************************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in + let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in + (* 1. Create an array of size [size] *) + let a : #(float * #(float * float) * #(float * #(float * float * float))) array = makearray_dynamic size #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 255; + let test = eq el #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + if not test then failwithf "test 255 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 256; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 256 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 257; + let test = raises in + if not test then failwithf "test 257 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., #(0., 0.), #(0., #(0., 0., 0.))) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 258; + let test = raises in + if not test then failwithf "test 258 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 259; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 259 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 260; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 260 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 261; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 261 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 262; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 262 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float# * int * int64#) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int * int64#) array = makearray_dynamic size #(#0., 0, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 263; + let test = eq el #(#0., 0, #0L) in + if not test then failwithf "test 263 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 264; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 264 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 265; + let test = raises in + if not test then failwithf "test 265 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., 0, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 266; + let test = raises in + if not test then failwithf "test 266 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 267; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 267 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 268; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 268 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 269; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 269 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 270; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 270 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************************************************************************************) + (* #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) *) + (***************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) array = makearray_dynamic size #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 271; + let test = eq el #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + if not test then failwithf "test 271 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 272; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 272 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 273; + let test = raises in + if not test then failwithf "test 273 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 274; + let test = raises in + if not test then failwithf "test 274 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 275; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 275 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 276; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 276 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 277; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 277 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 278; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 278 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************) + (* #(ur2 * ur1) *) + (********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(ur2 * ur1) array = makearray_dynamic size #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 279; + let test = eq el #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 279 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 280; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 280 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 281; + let test = raises in + if not test then failwithf "test 281 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 282; + let test = raises in + if not test then failwithf "test 282 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 283; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 283 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 284; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 284 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 285; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 285 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 286; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 286 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +let test_makearray_dynamic_local size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic_local size #0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 287; + let test = eq el #0.s in + if not test then failwithf "test 287 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 288; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 288 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 289; + let test = raises in + if not test then failwithf "test 289 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 290; + let test = raises in + if not test then failwithf "test 290 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 291; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 291 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 292; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 292 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 293; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 293 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 294; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 294 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic_local size #0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 295; + let test = eq el #0. in + if not test then failwithf "test 295 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 296; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 296 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 297; + let test = raises in + if not test then failwithf "test 297 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 298; + let test = raises in + if not test then failwithf "test 298 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 299; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 299 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 300; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 300 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 301; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 301 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 302; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 302 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic_local size #0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 303; + let test = eq el #0l in + if not test then failwithf "test 303 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 304; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 304 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 305; + let test = raises in + if not test then failwithf "test 305 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 306; + let test = raises in + if not test then failwithf "test 306 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 307; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 307 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 308; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 308 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 309; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 309 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 310; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 310 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic_local size #0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 311; + let test = eq el #0L in + if not test then failwithf "test 311 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 312; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 312 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 313; + let test = raises in + if not test then failwithf "test 313 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 314; + let test = raises in + if not test then failwithf "test 314 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 315; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 315 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 316; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 316 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 317; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 317 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 318; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 318 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic_local size #0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 319; + let test = eq el #0n in + if not test then failwithf "test 319 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 320; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 320 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 321; + let test = raises in + if not test then failwithf "test 321 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 322; + let test = raises in + if not test then failwithf "test 322 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 323; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 323 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 324; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 324 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 325; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 325 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 326; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 326 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic_local size (#{ a = #0L; b = #0. } : ur1) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 327; + let test = eq el (#{ a = #0L; b = #0. } : ur1) in + if not test then failwithf "test 327 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 328; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 328 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 329; + let test = raises in + if not test then failwithf "test 329 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 330; + let test = raises in + if not test then failwithf "test 330 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 331; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 331 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 332; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 332 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 333; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 333 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 334; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 334 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic_local size (#{ a = #0L } : ur3) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 335; + let test = eq el (#{ a = #0L } : ur3) in + if not test then failwithf "test 335 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 336; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 336 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 337; + let test = raises in + if not test then failwithf "test 337 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 338; + let test = raises in + if not test then failwithf "test 338 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 339; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 339 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 340; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 340 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 341; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 341 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 342; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 342 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic_local size (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 343; + let test = eq el (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + if not test then failwithf "test 343 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 344; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 344 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 345; + let test = raises in + if not test then failwithf "test 345 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 346; + let test = raises in + if not test then failwithf "test 346 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 347; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 347 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 348; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 348 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 349; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 349 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 350; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 350 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic_local size #(#0., #0l, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 351; + let test = eq el #(#0., #0l, #0L) in + if not test then failwithf "test 351 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 352; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 352 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 353; + let test = raises in + if not test then failwithf "test 353 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 354; + let test = raises in + if not test then failwithf "test 354 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 355; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 355 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 356; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 356 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 357; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 357 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 358; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 358 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_local size #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 359; + let test = eq el #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + if not test then failwithf "test 359 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 360; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 360 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 361; + let test = raises in + if not test then failwithf "test 361 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 362; + let test = raises in + if not test then failwithf "test 362 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 363; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 363 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 364; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 364 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 365; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 365 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 366; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 366 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic_local size #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 367; + let test = eq el #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 367 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 368; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 368 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 369; + let test = raises in + if not test then failwithf "test 369 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 370; + let test = raises in + if not test then failwithf "test 370 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 371; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 371 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 372; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 372 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 373; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 373 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 374; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 374 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************) + (* float32 *) + (***************) + let eq = (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) in + let mk_value i = Float32.of_int i in + (* 1. Create an array of size [size] *) + let a : float32 array = makearray_dynamic_local size 0.s in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 375; + let test = eq el 0.s in + if not test then failwithf "test 375 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 376; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 376 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 377; + let test = raises in + if not test then failwithf "test 377 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 378; + let test = raises in + if not test then failwithf "test 378 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 379; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 379 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 380; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 380 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 381; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 381 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 382; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 382 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* float *) + (*************) + let eq = (fun a b -> Float.equal (globalize a) (globalize b)) in + let mk_value i = Float.of_int i in + (* 1. Create an array of size [size] *) + let a : float array = makearray_dynamic_local size 0. in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 383; + let test = eq el 0. in + if not test then failwithf "test 383 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 384; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 384 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 385; + let test = raises in + if not test then failwithf "test 385 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 386; + let test = raises in + if not test then failwithf "test 386 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 387; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 387 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 388; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 388 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 389; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 389 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 390; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 390 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int32 *) + (*************) + let eq = (fun a b -> Int32.equal (globalize a) (globalize b)) in + let mk_value i = Int32.of_int i in + (* 1. Create an array of size [size] *) + let a : int32 array = makearray_dynamic_local size 0l in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 391; + let test = eq el 0l in + if not test then failwithf "test 391 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 392; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 392 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 393; + let test = raises in + if not test then failwithf "test 393 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 394; + let test = raises in + if not test then failwithf "test 394 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 395; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 395 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 396; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 396 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 397; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 397 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 398; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 398 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* int64 *) + (*************) + let eq = (fun a b -> Int64.equal (globalize a) (globalize b)) in + let mk_value i = Int64.of_int i in + (* 1. Create an array of size [size] *) + let a : int64 array = makearray_dynamic_local size 0L in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 399; + let test = eq el 0L in + if not test then failwithf "test 399 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 400; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 400 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 401; + let test = raises in + if not test then failwithf "test 401 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 402; + let test = raises in + if not test then failwithf "test 402 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 403; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 403 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 404; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 404 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 405; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 405 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 406; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 406 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*****************) + (* nativeint *) + (*****************) + let eq = (fun a b -> Nativeint.equal (globalize a) (globalize b)) in + let mk_value i = Nativeint.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint array = makearray_dynamic_local size 0n in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 407; + let test = eq el 0n in + if not test then failwithf "test 407 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 408; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 408 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 409; + let test = raises in + if not test then failwithf "test 409 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 410; + let test = raises in + if not test then failwithf "test 410 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 411; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 411 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 412; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 412 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 413; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 413 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 414; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 414 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* int *) + (***********) + let eq = (fun a b -> Int.equal a b) in + let mk_value i = i in + (* 1. Create an array of size [size] *) + let a : int array = makearray_dynamic_local size 0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 415; + let test = eq el 0 in + if not test then failwithf "test 415 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 416; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 416 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 417; + let test = raises in + if not test then failwithf "test 417 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i 0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 418; + let test = raises in + if not test then failwithf "test 418 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 419; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 419 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 420; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 420 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 421; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 421 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 422; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 422 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************) + (* enum3 *) + (*************) + let eq = (fun a b -> match a, b with A3_0, A3_0 | A3_1, A3_1 | A3_2, A3_2 -> true | _ -> false) in + let mk_value i = (match Int.rem i 3 with 0 -> A3_0 | 1 -> A3_1 | 2 -> A3_2 | _ -> assert false) in + (* 1. Create an array of size [size] *) + let a : enum3 array = makearray_dynamic_local size A3_0 in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 423; + let test = eq el A3_0 in + if not test then failwithf "test 423 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 424; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 424 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 425; + let test = raises in + if not test then failwithf "test 425 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i A3_0 with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 426; + let test = raises in + if not test then failwithf "test 426 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 427; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 427 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 428; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 428 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 429; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 429 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 A3_0 in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 430; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 430 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur2 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = i } : ur2) in + (* 1. Create an array of size [size] *) + let a : ur2 array = makearray_dynamic_local size (#{ a = #0L; b = 0 } : ur2) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 431; + let test = eq el (#{ a = #0L; b = 0 } : ur2) in + if not test then failwithf "test 431 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 432; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 432 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 433; + let test = raises in + if not test then failwithf "test 433 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = 0 } : ur2) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 434; + let test = raises in + if not test then failwithf "test 434 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 435; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 435 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 436; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 436 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 437; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 437 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = 0 } : ur2) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 438; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 438 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**********************) + (* #(int * int64) *) + (**********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64.equal (globalize a) (globalize b)) a1 b1) in + let mk_value i = #(i, Int64.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int * int64) array = makearray_dynamic_local size #(0, 0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 439; + let test = eq el #(0, 0L) in + if not test then failwithf "test 439 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 440; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 440 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 441; + let test = raises in + if not test then failwithf "test 441 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0, 0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 442; + let test = raises in + if not test then failwithf "test 442 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 443; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 443 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 444; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 444 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 445; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 445 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0, 0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 446; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 446 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************************************************************************************************************) + (* #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) *) + (**************************************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun a b -> Int64.equal (globalize a) (globalize b)) a b|_->false) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int32.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (Float32.to_float a) (Float32.to_float b)) a0 b0 && (fun a b -> match a, b with None,None -> true | Some a,Some b -> (fun (a0, a1) (b0, b1) -> (fun a b -> Nativeint.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Nativeint.equal (globalize a) (globalize b)) a1 b1) a b|_->false) a1 b1) a3 b3 && (fun a b -> Int32.equal (globalize a) (globalize b)) a4 b4) in + let mk_value i = #((if i == 0 then None else Some (Int64.of_int i)), #(i, Int32.of_int i, Float.of_int i), Float.of_int i, #(Float32.of_int i, (if i == 0 then None else Some ((Nativeint.of_int i, Nativeint.of_int i)))), Int32.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(int64 option * #(int * int32 * float) * float * #(float32 * (nativeint * nativeint) option) * int32) array = makearray_dynamic_local size #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 447; + let test = eq el #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + if not test then failwithf "test 447 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 448; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 448 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 449; + let test = raises in + if not test then failwithf "test 449 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 450; + let test = raises in + if not test then failwithf "test 450 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 451; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 451 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 452; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 452 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 453; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 453 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(None, #(0, 0l, 0.), 0., #(0.s, None), 0l) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 454; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 454 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float * float * float) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) in + let mk_value i = #(Float.of_int i, Float.of_int i, Float.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float * float * float) array = makearray_dynamic_local size #(0., 0., 0.) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 455; + let test = eq el #(0., 0., 0.) in + if not test then failwithf "test 455 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 456; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 456 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 457; + let test = raises in + if not test then failwithf "test 457 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., 0., 0.) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 458; + let test = raises in + if not test then failwithf "test 458 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 459; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 459 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 460; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 460 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 461; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 461 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., 0., 0.) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 462; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 462 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*************************************************************************) + (* #(float * #(float * float) * #(float * #(float * float * float))) *) + (*************************************************************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1) a1 b1 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float.equal (globalize a) (globalize b)) a0 b0 && (fun a b -> Float.equal (globalize a) (globalize b)) a1 b1 && (fun a b -> Float.equal (globalize a) (globalize b)) a2 b2) a1 b1) a2 b2) in + let mk_value i = #(Float.of_int i, #(Float.of_int i, Float.of_int i), #(Float.of_int i, #(Float.of_int i, Float.of_int i, Float.of_int i))) in + (* 1. Create an array of size [size] *) + let a : #(float * #(float * float) * #(float * #(float * float * float))) array = makearray_dynamic_local size #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 463; + let test = eq el #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + if not test then failwithf "test 463 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 464; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 464 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 465; + let test = raises in + if not test then failwithf "test 465 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(0., #(0., 0.), #(0., #(0., 0., 0.))) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 466; + let test = raises in + if not test then failwithf "test 466 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 467; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 467 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 468; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 468 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 469; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 469 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(0., #(0., 0.), #(0., #(0., 0., 0.))) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 470; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 470 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************************) + (* #(float# * int * int64#) *) + (********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int.equal a b) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int * int64#) array = makearray_dynamic_local size #(#0., 0, #0L) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 471; + let test = eq el #(#0., 0, #0L) in + if not test then failwithf "test 471 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 472; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 472 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 473; + let test = raises in + if not test then failwithf "test 473 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., 0, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 474; + let test = raises in + if not test then failwithf "test 474 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 475; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 475 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 476; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 476 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 477; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 477 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., 0, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 478; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 478 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***************************************************************************************) + (* #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) *) + (***************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int.equal a b) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int.equal a b) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) * int) array = makearray_dynamic_local size #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 479; + let test = eq el #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + if not test then failwithf "test 479 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 480; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 480 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 481; + let test = raises in + if not test then failwithf "test 481 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 482; + let test = raises in + if not test then failwithf "test 482 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 483; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 483 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 484; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 484 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 485; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 485 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 486; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 486 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (********************) + (* #(ur2 * ur1) *) + (********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun (#{ a = a1; b = b1 } : ur2) (#{ a = a2; b = b2 } : ur2) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Int.equal a b) b1 b2) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #((#{ a = Int64_u.of_int i; b = i } : ur2), (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(ur2 * ur1) array = makearray_dynamic_local size #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + mark_test_run 487; + let test = eq el #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + if not test then failwithf "test 487 failed %d %d" size i; + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 488; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 488 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 489; + let test = raises in + if not test then failwithf "test 489 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 490; + let test = raises in + if not test then failwithf "test 490 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 491; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 491 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 492; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 492 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 493; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 493 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #((#{ a = #0L; b = 0 } : ur2), (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 494; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 494 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +let test_makearray_dynamic_uninit size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 495; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 495 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 496; + let test = raises in + if not test then failwithf "test 496 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 497; + let test = raises in + if not test then failwithf "test 497 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 498; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 498 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 499; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 499 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 500; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 500 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 501; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 501 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 502; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 502 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 503; + let test = raises in + if not test then failwithf "test 503 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 504; + let test = raises in + if not test then failwithf "test 504 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 505; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 505 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 506; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 506 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 507; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 507 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 508; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 508 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 509; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 509 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 510; + let test = raises in + if not test then failwithf "test 510 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 511; + let test = raises in + if not test then failwithf "test 511 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 512; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 512 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 513; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 513 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 514; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 514 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 515; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 515 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 516; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 516 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 517; + let test = raises in + if not test then failwithf "test 517 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 518; + let test = raises in + if not test then failwithf "test 518 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 519; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 519 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 520; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 520 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 521; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 521 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 522; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 522 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 523; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 523 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 524; + let test = raises in + if not test then failwithf "test 524 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 525; + let test = raises in + if not test then failwithf "test 525 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 526; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 526 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 527; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 527 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 528; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 528 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 529; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 529 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 530; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 530 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 531; + let test = raises in + if not test then failwithf "test 531 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 532; + let test = raises in + if not test then failwithf "test 532 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 533; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 533 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 534; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 534 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 535; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 535 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 536; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 536 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 537; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 537 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 538; + let test = raises in + if not test then failwithf "test 538 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 539; + let test = raises in + if not test then failwithf "test 539 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 540; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 540 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 541; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 541 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 542; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 542 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 543; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 543 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 544; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 544 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 545; + let test = raises in + if not test then failwithf "test 545 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 546; + let test = raises in + if not test then failwithf "test 546 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 547; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 547 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 548; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 548 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 549; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 549 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 550; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 550 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 551; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 551 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 552; + let test = raises in + if not test then failwithf "test 552 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 553; + let test = raises in + if not test then failwithf "test 553 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 554; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 554 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 555; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 555 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 556; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 556 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 557; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 557 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 558; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 558 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 559; + let test = raises in + if not test then failwithf "test 559 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 560; + let test = raises in + if not test then failwithf "test 560 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 561; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 561 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 562; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 562 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 563; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 563 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 564; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 564 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic_uninit size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 565; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 565 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 566; + let test = raises in + if not test then failwithf "test 566 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 567; + let test = raises in + if not test then failwithf "test 567 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 568; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 568 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 569; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 569 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 570; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 570 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 571; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 571 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +let test_makearray_dynamic_uninit_local size = + (****************) + (* float32# *) + (****************) + let eq = (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) in + let mk_value i = Float32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float32# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 572; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 572 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 573; + let test = raises in + if not test then failwithf "test 573 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0.s with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 574; + let test = raises in + if not test then failwithf "test 574 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 575; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 575 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 576; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 576 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 577; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 577 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0.s in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 578; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 578 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* float# *) + (**************) + let eq = (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) in + let mk_value i = Float_u.of_int i in + (* 1. Create an array of size [size] *) + let a : float# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 579; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 579 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 580; + let test = raises in + if not test then failwithf "test 580 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0. with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 581; + let test = raises in + if not test then failwithf "test 581 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 582; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 582 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 583; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 583 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 584; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 584 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0. in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 585; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 585 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int32# *) + (**************) + let eq = (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) in + let mk_value i = Int32_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int32# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 586; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 586 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 587; + let test = raises in + if not test then failwithf "test 587 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0l with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 588; + let test = raises in + if not test then failwithf "test 588 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 589; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 589 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 590; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 590 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 591; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 591 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0l in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 592; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 592 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (**************) + (* int64# *) + (**************) + let eq = (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) in + let mk_value i = Int64_u.of_int i in + (* 1. Create an array of size [size] *) + let a : int64# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 593; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 593 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 594; + let test = raises in + if not test then failwithf "test 594 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0L with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 595; + let test = raises in + if not test then failwithf "test 595 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 596; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 596 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 597; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 597 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 598; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 598 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0L in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 599; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 599 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (******************) + (* nativeint# *) + (******************) + let eq = (fun a b -> Nativeint_u.(equal (add #0n a) (add #0n b))) in + let mk_value i = Nativeint_u.of_int i in + (* 1. Create an array of size [size] *) + let a : nativeint# array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 600; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 600 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 601; + let test = raises in + if not test then failwithf "test 601 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #0n with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 602; + let test = raises in + if not test then failwithf "test 602 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 603; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 603 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 604; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 604 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 605; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 605 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #0n in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 606; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 606 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur1 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) in + let mk_value i = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1) in + (* 1. Create an array of size [size] *) + let a : ur1 array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 607; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 607 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 608; + let test = raises in + if not test then failwithf "test 608 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L; b = #0. } : ur1) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 609; + let test = raises in + if not test then failwithf "test 609 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 610; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 610 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 611; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 611 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 612; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 612 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L; b = #0. } : ur1) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 613; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 613 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur3 *) + (***********) + let eq = (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) in + let mk_value i = (#{ a = Int64_u.of_int i } : ur3) in + (* 1. Create an array of size [size] *) + let a : ur3 array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 614; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 614 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 615; + let test = raises in + if not test then failwithf "test 615 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = #0L } : ur3) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 616; + let test = raises in + if not test then failwithf "test 616 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 617; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 617 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 618; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 618 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 619; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 619 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = #0L } : ur3) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 620; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 620 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********) + (* ur4 *) + (***********) + let eq = (fun (#{ a = a1; b = b1 } : ur4) (#{ a = a2; b = b2 } : ur4) -> (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 a2 && (fun (#{ a = a1 } : ur3) (#{ a = a2 } : ur3) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2) b1 b2) in + let mk_value i = (#{ a = (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1); b = (#{ a = Int64_u.of_int i } : ur3) } : ur4) in + (* 1. Create an array of size [size] *) + let a : ur4 array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 621; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 621 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 622; + let test = raises in + if not test then failwithf "test 622 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 623; + let test = raises in + if not test then failwithf "test 623 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 624; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 624 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 625; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 625 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 626; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 626 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 (#{ a = (#{ a = #0L; b = #0. } : ur1); b = (#{ a = #0L } : ur3) } : ur4) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 627; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 627 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************************) + (* #(float# * int32# * int64#) *) + (***********************************) + let eq = (fun #(a0, a1, a2) #(b0, b1, b2) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a1 b1 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a2 b2) in + let mk_value i = #(Float_u.of_int i, Int32_u.of_int i, Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * int32# * int64#) array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 628; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 628 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 629; + let test = raises in + if not test then failwithf "test 629 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #0l, #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 630; + let test = raises in + if not test then failwithf "test 630 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 631; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 631 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 632; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 632 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 633; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 633 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #0l, #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 634; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 634 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (*********************************************************************************************) + (* #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) *) + (*********************************************************************************************) + let eq = (fun #(a0, a1, a2, a3, a4) #(b0, b1, b2, b3, b4) -> (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 b1) a1 b1 && (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a2 b2 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int32_u.(equal (add #0l a) (add #0l b))) a0 b0 && (fun #(a0, a1) #(b0, b1) -> (fun a b -> Float32_u.(equal (add #0.s a) (add #0.s b))) a0 b0 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) a1 b1) a1 b1) a3 b3 && (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a4 b4) in + let mk_value i = #(Float_u.of_int i, #(Int64_u.of_int i, Int64_u.of_int i), Float32_u.of_int i, #(Int32_u.of_int i, #(Float32_u.of_int i, Float_u.of_int i)), Int64_u.of_int i) in + (* 1. Create an array of size [size] *) + let a : #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) * int64#) array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 635; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 635 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 636; + let test = raises in + if not test then failwithf "test 636 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 637; + let test = raises in + if not test then failwithf "test 637 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 638; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 638 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 639; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 639 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 640; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 640 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 641; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 641 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + (***********************) + (* #(int64# * ur1) *) + (***********************) + let eq = (fun #(a0, a1) #(b0, b1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a0 b0 && (fun (#{ a = a1; b = b1 } : ur1) (#{ a = a2; b = b2 } : ur1) -> (fun a b -> Int64_u.(equal (add #0L a) (add #0L b))) a1 a2 && (fun a b -> Float_u.(equal (add #0. a) (add #0. b))) b1 b2) a1 b1) in + let mk_value i = #(Int64_u.of_int i, (#{ a = Int64_u.of_int i; b = Float_u.of_int i } : ur1)) in + (* 1. Create an array of size [size] *) + let a : #(int64# * ur1) array = makearray_dynamic_uninit_local size in + (* 2. For uninitialized arrays, element values are unspecified *) + (* 2. For initialized arrays, check all elements have the correct value *) + for i = 0 to size - 1 do + let el = get a i in + let _ = el in () + done; + (* 3. Fill [a] with distinct values and read back those values *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + Gc.compact (); + for i = 0 to size - 1 do + mark_test_run 642; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 642 failed %d %d" size i; + done; + iter (bad_indices size) ~f:(fun i -> + (* 4. Getting bad indices errors *) + let raises = + match get a i with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 643; + let test = raises in + if not test then failwithf "test 643 failed %d %d" size i; + (* 5. Setting bad indices errors *) + let raises = + match set a i #(#0L, (#{ a = #0L; b = #0. } : ur1)) with + | exception Invalid_argument _ -> true + | _ -> false + in + mark_test_run 644; + let test = raises in + if not test then failwithf "test 644 failed %d %d" size i; + ) [@nontail]; + Gc.compact (); + (* 6. Array contents were unaffacted by setting bad indices *) + for i = 0 to size - 1 do + mark_test_run 645; + let test = eq (get a i) (mk_value i) in + if not test then failwithf "test 645 failed %d %d" size i; + done; + (* 7. Overlapping blits *) + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2:size) ~f:(fun len -> + unsafe_blit a ofs1 a ofs2 len; + for i = 0 to size - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else i + in + mark_test_run 646; + let test = eq (get a i) (mk_value expected_src_i) in + if not test then failwithf "test 646 failed %d %d %d %d %d" size ofs1 ofs2 len i; + done; + (* Reset array *) + for i = 0 to size - 1 do + set a i (mk_value i); + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 8. Blits to heap arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let a2 = makearray_dynamic size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 647; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 647 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + (* 9. Blits to local arrays *) + iter (sizes) ~f:(fun size2 -> + iter (blit_offsets size) ~f:(fun ofs1 -> + iter (blit_offsets size2) ~f:(fun ofs2 -> + iter (blit_lens ~ofs1 ~ofs2 ~size1:size ~size2) ~f:(fun len -> + let local_ a2 = makearray_dynamic_local size2 #(#0L, (#{ a = #0L; b = #0. } : ur1)) in + unsafe_blit a ofs1 a2 ofs2 len; + for i = 0 to size2 - 1 do + let expected_src_i = + if i >= ofs2 && i < ofs2 + len then i - ofs2 + ofs1 else 0 + in + mark_test_run 648; + let test = eq (get a2 i) (mk_value expected_src_i) in + if not test then failwithf "test 648 failed %d %d %d %d %d %d" size size2 ofs1 ofs2 len i; + done; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + ) [@nontail]; + Gc.compact (); + + () + +(* Main tests *) +let () = + print_endline "test_makearray_dynamic"; + iter sizes ~f:test_makearray_dynamic; + print_endline "test_makearray_dynamic_local"; + iter sizes ~f:test_makearray_dynamic_local; + print_endline "test_makearray_dynamic_uninit"; + iter sizes ~f:test_makearray_dynamic_uninit; + print_endline "test_makearray_dynamic_uninit_local"; + iter sizes ~f:test_makearray_dynamic_uninit_local; + () +;; + +for i = 1 to 648 do + if not (List.mem ~set:!tests_run i) then failwithf "test %d not run" i +done;; +let () = Printf.printf "All tests passed.%!\n";; diff --git a/testsuite/tests/typing-layouts-arrays/generated_test.reference b/testsuite/tests/typing-layouts-arrays/generated_test.reference new file mode 100644 index 00000000000..c2075fa9659 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/generated_test.reference @@ -0,0 +1,5 @@ +test_makearray_dynamic +test_makearray_dynamic_local +test_makearray_dynamic_uninit +test_makearray_dynamic_uninit_local +All tests passed. diff --git a/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml b/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml new file mode 100644 index 00000000000..3dd358ae67c --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/run_makearray_dynamic_tests.ml @@ -0,0 +1,24 @@ +(* TEST + readonly_files = "generate_makearray_dynamic_tests.ml"; + (* Generate the bytecode/native code versions of + [generate_makearray_dynamic_tests.ml]. This doesn't actually run the test; + it just updates the generated test program (which is separately + run by the test harness). + *) + + { + setup-ocamlopt.opt-build-env; + stack-allocation; + program = "${test_source_directory}/generate.out"; + all_modules = "generate_makearray_dynamic_tests.ml"; + include stdlib_stable; + include stdlib_upstream_compatible; + ocamlopt.opt; + arguments = "native"; + output = "${test_source_directory}/generated_test.ml.corrected"; + run; + output = "${test_source_directory}/generated_test.ml.corrected"; + reference = "${test_source_directory}/generated_test.ml"; + check-program-output; + } +*) diff --git a/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml b/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml new file mode 100644 index 00000000000..81dd9df04e0 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_float_u_array.ml @@ -0,0 +1,93 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float +type unboxed_t = float# + +let elem : boxed_t elem = float_elem +let words_wide : int = 1 +let zero () : unboxed_t = #0. + +let to_boxed a = Float_u.to_float a +let of_boxed a = Float_u.of_float a + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module Float_u_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module Float_u_array = Gen_u_array.Make (Float_u_array0) + +module Float_u_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = Float_u_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (Float_u_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml new file mode 100644 index 00000000000..05b59f4ee0b --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_1.ml @@ -0,0 +1,93 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * int * int64 +type unboxed_t = #(float# * int * int64#) + +let elem : boxed_t elem = Tup3 (float_elem, int_elem, int64_elem) +let words_wide : int = 3 +let zero () : unboxed_t = #(#0., 0, #0L) + +let to_boxed #(a, b, c) = (Float_u.to_float a, b, Int64_u.to_int64 c) +let of_boxed (a, b, c) = #(Float_u.of_float a, b, Int64_u.of_int64 c) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml new file mode 100644 index 00000000000..4ce8c2a43d5 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_2.ml @@ -0,0 +1,114 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = + float * (int * int64) * float32 * (int32 * (float32 * float)) * int +type unboxed_t = + #(float# * #(int * int64#) * float32# * #(int32# * #(float32# * float#)) + * int) + +let elem : boxed_t elem = + Tup5 (float_elem, + Tup2 (int_elem, int64_elem), + float32_elem, + Tup2 (int32_elem, (Tup2 (float32_elem, float_elem))), + int_elem) + +let words_wide : int = 8 +let zero () : unboxed_t = + #(#0., #(0, #0L), #0.s, #(#0l, #(#0.s, #0.)), 0) + +let to_boxed #(a, #(b, c), d, #(e, #(f, g)), h) = + (Float_u.to_float a, + (b, Int64_u.to_int64 c), + Float32_u.to_float32 d, + (Int32_u.to_int32 e, (Float32_u.to_float32 f, Float_u.to_float g)), + h) + +let of_boxed (a, (b, c), d, (e, (f, g)), h) = + #(Float_u.of_float a, + #(b, Int64_u.of_int64 c), + Float32_u.of_float32 d, + #(Int32_u.of_int32 e, #(Float32_u.of_float32 f, Float_u.of_float g)), + h) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml new file mode 100644 index 00000000000..4dc10e586f7 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_1.ml @@ -0,0 +1,90 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * int32 * int64 +type unboxed_t = #(float# * int32# * int64#) + +let elem : boxed_t elem = Tup3 (float_elem, int32_elem, int64_elem) +let words_wide : int = 3 +let zero () : unboxed_t = #(#0., #0l, #0L) + +let to_boxed #(a, b, c) = (Float_u.to_float a, Int32_u.to_int32 b, Int64_u.to_int64 c) +let of_boxed (a, b, c) = #(Float_u.of_float a, Int32_u.of_int32 b, Int64_u.of_int64 c) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic_uninit : int -> element_t array = + "%makearray_dynamic_uninit" + + let unsafe_create : int -> element_t array = + fun i -> makearray_dynamic_uninit i + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml new file mode 100644 index 00000000000..1381e82f68e --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2.ml @@ -0,0 +1,111 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = + float * (int64 * int64) * float32 * (int32 * (float32 * float)) * int64 +type unboxed_t = + #(float# * #(int64# * int64#) * float32# * #(int32# * #(float32# * float#)) + * int64#) + +let elem : boxed_t elem = + Tup5 (float_elem, + Tup2 (int64_elem, int64_elem), + float32_elem, + Tup2 (int32_elem, (Tup2 (float32_elem, float_elem))), + int64_elem) + +let words_wide : int = 8 +let zero () : unboxed_t = + #(#0., #(#0L, #0L), #0.s, #(#0l, #(#0.s, #0.)), #0L) + +let to_boxed #(a, #(b, c), d, #(e, #(f, g)), h) = + (Float_u.to_float a, + (Int64_u.to_int64 b, Int64_u.to_int64 c), + Float32_u.to_float32 d, + (Int32_u.to_int32 e, (Float32_u.to_float32 f, Float_u.to_float g)), + Int64_u.to_int64 h) + +let of_boxed (a, (b, c), d, (e, (f, g)), h) = + #(Float_u.of_float a, + #(Int64_u.of_int64 b, Int64_u.of_int64 c), + Float32_u.of_float32 d, + #(Int32_u.of_int32 e, #(Float32_u.of_float32 f, Float_u.of_float g)), + Int64_u.of_int64 h) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic_uninit : int -> element_t array = + "%makearray_dynamic_uninit" + + let unsafe_create : int -> element_t array = + fun i -> makearray_dynamic_uninit i + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml new file mode 100644 index 00000000000..33daf2c9485 --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_1.ml @@ -0,0 +1,94 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = int * int64 +type unboxed_t = #(int * int64) + +let elem : boxed_t elem = Tup2 (int_elem, int64_elem) +let words_wide : int = 2 +let zero () : unboxed_t = #(0, 0L) + +let to_boxed #(i, i64) = (i, i64) +let of_boxed (i, i64) = #(i, i64) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml new file mode 100644 index 00000000000..1d64378a6ba --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_2.ml @@ -0,0 +1,116 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = + int64 option + * (int * int32 * float) + * float + * (float32 * (nativeint * nativeint) option) + * int32 + +type unboxed_t = + #(int64 option + * #(int * int32 * float) + * float + * #(float32 * (nativeint * nativeint) option) + * int32) + +let elem : boxed_t elem = + Tup5 (Option int64_elem, + Tup3 (int_elem, int32_elem, float_elem), + float_elem, + Tup2 (float32_elem, Option (Tup2 (nativeint_elem, nativeint_elem))), + int32_elem) + +let words_wide : int = 8 +let zero () : unboxed_t = + #(Some 0L, + #(0, 0l, 0.), + 0., + #(0.s, Some (0n, 0n)), + 0l) + +let to_boxed #(a, #(b, c, d), e, #(f, g), h) = (a, (b, c, d), e, (f, g), h) +let of_boxed (a, (b, c, d), e, (f, g), h) = #(a, #(b, c, d), e, #(f, g), h) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml new file mode 100644 index 00000000000..b18e167c7aa --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_3.ml @@ -0,0 +1,96 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * float * float + +type unboxed_t = #(float * float * float) + +let elem : boxed_t elem = Tup3 (float_elem, float_elem, float_elem) + +let words_wide : int = 3 +let zero () : unboxed_t = #(0., 0., 0.) + +let to_boxed #(a, b, c) = a, b, c +let of_boxed (a, b, c) = #(a, b, c) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml new file mode 100644 index 00000000000..19aa03f400a --- /dev/null +++ b/testsuite/tests/typing-layouts-arrays/test_scannable_product_array_4.ml @@ -0,0 +1,100 @@ +(* TEST + include stdlib_stable; + include stdlib_upstream_compatible; + readonly_files = + "gen_u_array.ml test_gen_u_array.ml gen_product_array_helpers.ml"; + modules = "${readonly_files}"; + flambda2; + stack-allocation; + arch_amd64; + { + flags = "-extension layouts_beta"; + bytecode; + } + { + flags = "-extension layouts_beta"; + native; + } +*) + +(* CR mshinwell: enable for arm64 once float32 is available *) + +open Gen_product_array_helpers +open Stdlib_stable +open Stdlib_upstream_compatible + +(* If copying this test for a new product shape, you should only have to + change the bit between here and the next comment. See README.md in this + test directory. *) +type boxed_t = float * (float * float) * (float * (float * float * float)) + +type unboxed_t = + #(float * #(float * float) * #(float * #(float * float * float))) + +let elem : boxed_t elem = + Tup3 (float_elem, + Tup2 (float_elem, float_elem), + Tup2 (float_elem, Tup3 (float_elem, float_elem, float_elem))) + +let words_wide : int = 7 +let zero () : unboxed_t = #(0., #(0., 0.), #(0., #(0., 0., 0.))) + +let to_boxed #(a, #(b, c), #(d, #(e, f, g))) = a, (b, c), (d, (e, f, g)) +let of_boxed (a, (b, c), (d, (e, f, g))) = #(a, #(b, c), #(d, #(e, g, f))) + +(* Below here is copy pasted due to the absence of layout polymorphism. Don't + change it. See README.md in this test directory. *) +module Element_ops = (val Gen_product_array_helpers.make_element_ops elem) + +module UTuple_array0 : + Gen_u_array.S0 with type element_t = unboxed_t + and type ('a : any) array_t = 'a array = struct + type element_t = unboxed_t + + type ('a : any) array_t = 'a array + + type element_arg = unit -> element_t + type t = element_t array + let max_length = Sys.max_array_length + external length : element_t array -> int = "%array_length" + external get: element_t array -> int -> element_t = "%array_safe_get" + let get t i = let a = get t i in fun () -> a + external set: element_t array -> int -> element_t -> unit = "%array_safe_set" + let set t i e = set t i (e ()) + external unsafe_get: element_t array -> int -> element_t = "%array_unsafe_get" + let unsafe_get t i = let a = unsafe_get t i in fun () -> a + external unsafe_set: element_t array -> int -> element_t -> unit = + "%array_unsafe_set" + let unsafe_set t i e = unsafe_set t i (e ()) + + external makearray_dynamic : int -> element_t -> element_t array = + "%makearray_dynamic" + + let unsafe_create : int -> element_t array = + (* We don't actually have an uninitialized creation function for these, yet, + so we just use [makearray_dynamic] (which is what we want to test anyway) + with the zero element. *) + fun i -> makearray_dynamic i (zero ()) + + external unsafe_blit : + element_t array -> int -> element_t array -> int -> int -> unit = + "%arrayblit" + + let empty () : unboxed_t array = [||] + let to_boxed = to_boxed + + let compare_element x y = + Element_ops.compare (to_boxed (x ())) (to_boxed (y ())) +end + +module UTuple_array = Gen_u_array.Make (UTuple_array0) + +module UTuple_array_boxed = Test_gen_u_array.Make_boxed (struct + module M = UTuple_array + module I = Element_ops + module E = struct + let to_boxed x = to_boxed (x ()) + let of_boxed x () = of_boxed x + end + end) +module _ = Test_gen_u_array.Test (UTuple_array_boxed) diff --git a/testsuite/tests/typing-layouts-or-null/reexport.ml b/testsuite/tests/typing-layouts-or-null/reexport.ml index 46ceeebc37f..906811bcf34 100644 --- a/testsuite/tests/typing-layouts-or-null/reexport.ml +++ b/testsuite/tests/typing-layouts-or-null/reexport.ml @@ -11,18 +11,15 @@ module Or_null = struct | This of 'a end -(* CR layouts v3: this error message is not great, but it will be a - different error message in the final PR. *) - [%%expect{| Lines 2-4, characters 2-16: 2 | ..type ('a : value) t : value_or_null = 'a or_null = 3 | | Null 4 | | This of 'a -Error: The kind of type "'a or_null" is value_or_null - because it is the primitive value_or_null type or_null. - But the kind of type "'a or_null" must be a subkind of value - because of the definition of t at lines 2-4, characters 2-16. +Error: This variant or record definition does not match that of type + "'a or_null" + Their internal representations differ: + the original definition has a null constructor. |}] module Or_null = struct @@ -62,7 +59,8 @@ let n = Or_null.Null let t v = Or_null.This v [%%expect{| -module Or_null : sig type 'a t = 'a or_null = Null | This of 'a end +module Or_null : + sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end val n : 'a Or_null.t = Or_null.Null val t : 'a -> 'a Or_null.t = |}] @@ -90,7 +88,8 @@ end let fail = Or_null.This (Or_null.This 5) [%%expect{| -module Or_null : sig type 'a t = 'a or_null = Null | This of 'a end +module Or_null : + sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end Line 4, characters 24-40: 4 | let fail = Or_null.This (Or_null.This 5) ^^^^^^^^^^^^^^^^ @@ -110,10 +109,10 @@ type 'a t : value = 'a or_null [@@or_null_reexport] Line 1, characters 0-51: 1 | type 'a t : value = 'a or_null [@@or_null_reexport] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type "'a or_null" is value_or_null +Error: The kind of type "t" is value_or_null because it is the primitive value_or_null type or_null. - But the kind of type "'a or_null" must be a subkind of value - because of the definition of t at line 1, characters 0-51. + But the kind of type "t" must be a subkind of value + because of the annotation on the declaration of the type t. |}] type 'a t : float64 = 'a or_null [@@or_null_reexport] @@ -122,10 +121,10 @@ type 'a t : float64 = 'a or_null [@@or_null_reexport] Line 1, characters 0-53: 1 | type 'a t : float64 = 'a or_null [@@or_null_reexport] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type "'a or_null" is value +Error: The layout of type "t" is value because it is the primitive value_or_null type or_null. - But the layout of type "'a or_null" must be a sublayout of float64 - because of the definition of t at line 1, characters 0-53. + But the layout of type "t" must be a sublayout of float64 + because of the annotation on the declaration of the type t. |}] type ('a : float64) t = 'a or_null [@@or_null_reexport] @@ -150,7 +149,8 @@ end let fail = Or_null.This (Or_null.This 5) [%%expect{| -module Or_null : sig type 'a t = 'a or_null = Null | This of 'a end +module Or_null : + sig type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] end Line 4, characters 24-40: 4 | let fail = Or_null.This (Or_null.This 5) ^^^^^^^^^^^^^^^^ @@ -233,7 +233,7 @@ type 'a t = 'a or_null [@@or_null_reexport] and t' = int or_null [%%expect{| -type 'a t = 'a or_null = Null | This of 'a +type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] and t' = int or_null |}] @@ -256,8 +256,8 @@ type 'a t1 = 'a or_null [@@or_null_reexport] type 'a t2 = 'a t1 [@@or_null_reexport] [%%expect{| -type 'a t1 = 'a or_null = Null | This of 'a -type 'a t2 = 'a t1 = Null | This of 'a +type 'a t1 = 'a or_null = Null | This of 'a [@@or_null_reexport] +type 'a t2 = 'a t1 = Null | This of 'a [@@or_null_reexport] |}] (* Correct injectivity and variance annotations are accepted. *) @@ -267,8 +267,8 @@ type !'a t = 'a or_null [@@or_null_reexport] type +'a t = 'a or_null [@@or_null_reexport] [%%expect{| -type 'a t = 'a or_null = Null | This of 'a -type 'a t = 'a or_null = Null | This of 'a +type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] +type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] |}] (* Incorrect variance annotation fails. *) diff --git a/testsuite/tests/typing-layouts-or-null/runtime.ml b/testsuite/tests/typing-layouts-or-null/runtime.ml new file mode 100644 index 00000000000..2b47eeec67a --- /dev/null +++ b/testsuite/tests/typing-layouts-or-null/runtime.ml @@ -0,0 +1,170 @@ +(* TEST + flags = "-extension layouts_alpha"; +*) + +let x = Null + +let () = + match x with + | Null -> () + | This _ -> assert false +;; + +let y = This 3 + +let () = + match y with + | This 3 -> () + | _ -> assert false +;; + + +external int_as_pointer : int -> int or_null = "%int_as_pointer" + +let n = int_as_pointer 0 + +let () = + match n with + | Null -> () + | _ -> assert false +;; + +external int_as_int : int -> int or_null = "%opaque" + +let m = int_as_int 5 + +let () = + match m with + | This 5 -> () + | This _ -> assert false + | Null -> assert false +;; + +let x = (Null, This "bar") + +let () = + match x with + | Null, This "foo" -> assert false + | Null, This "bar" -> () + | _, This "bar" -> assert false + | Null, _ -> assert false + | _, _ -> assert false +;; + +let y a = fun () -> This a + +let d = y 5 + +let () = + match d () with + | This 5 -> () + | _ -> assert false +;; + +external to_bytes : ('a : value_or_null) . 'a -> int list -> bytes = "caml_output_value_to_bytes" + +external from_bytes_unsafe : ('a : value_or_null) . bytes -> int -> 'a = "caml_input_value_from_bytes" + +let z = to_bytes (This "foo") [] + +let () = + match from_bytes_unsafe z 0 with + | This "foo" -> () + | This _ -> assert false + | Null -> assert false +;; + +let w = to_bytes Null [] + +let () = + match from_bytes_unsafe w 0 with + | Null -> () + | This _ -> assert false +;; + +external evil : 'a or_null -> 'a = "%opaque" + +let e = This (evil Null) + +let () = + match e with + | Null -> () + | This _ -> assert false +;; + +let e' = evil (This 4) + +let () = + match e' with + | 4 -> () + | _ -> assert false +;; + +let f a = fun () -> + match a with + | This x -> x ^ "bar" + | Null -> "foo" +;; + +let g = f (This "xxx") + +let () = + match g () with + | "xxxbar" -> () + | _ -> assert false +;; + +let h = f Null + +let () = + match h () with + | "foo" -> () + | _ -> assert false +;; + +type 'a nref = { mutable v : 'a or_null } + +let x : string nref = { v = Null } + +let () = + match x.v with + | Null -> () + | _ -> assert false +;; + +let () = x.v <- This "foo" + +let () = + match x.v with + | This "foo" -> () + | _ -> assert false +;; + +let () = x.v <- Null + +let () = + match x.v with + | Null -> () + | _ -> assert false +;; + +external equal : ('a : value_or_null) . 'a -> 'a -> bool = "%eq" +external compare : ('a : value_or_null) . 'a -> 'a -> int = "%compare" + +let () = + assert (equal Null Null); + assert (equal (This 4) (This 4)); + assert (not (equal Null (This 4))); + assert (not (equal (This 8) Null)); + assert (not (equal (This 4) (This 5))); +;; + +let () = + assert (compare Null Null = 0); + assert (compare (This 4) (This 4) = 0); + assert (compare Null (This 4) < 0); + assert (compare (This 8) Null > 0); + assert (compare (This 4) (This 5) < 0); + assert (compare (This "abc") (This "xyz") <> 0); + assert (compare (This "xyz") (This "xyz") = 0); +;; diff --git a/testsuite/tests/typing-layouts-or-null/test_or_null.ml b/testsuite/tests/typing-layouts-or-null/test_or_null.ml index 460fa882adc..abf30af8e99 100644 --- a/testsuite/tests/typing-layouts-or-null/test_or_null.ml +++ b/testsuite/tests/typing-layouts-or-null/test_or_null.ml @@ -6,7 +6,7 @@ type ('a : value) t : value_or_null = 'a or_null [@@or_null_reexport] [%%expect{| -type 'a t = 'a or_null = Null | This of 'a +type 'a t = 'a or_null = Null | This of 'a [@@or_null_reexport] |}] let to_option (x : 'a or_null) = diff --git a/testsuite/tests/typing-layouts-products/basics.ml b/testsuite/tests/typing-layouts-products/basics.ml index 8f70d0b47ed..4520f1bd9ba 100644 --- a/testsuite/tests/typing-layouts-products/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics.ml @@ -1,9 +1,6 @@ (* TEST flambda2; include stdlib_upstream_compatible; - { - expect; - } { flags = "-extension layouts_beta"; expect; @@ -12,14 +9,16 @@ open Stdlib_upstream_compatible -(**********************************************************) -(* Test 1: Basic unboxed product layouts and tuple types. *) +(****************************************************) +(* Test 1: Basic unboxed product layouts and types. *) type t1 : float64 & value type t2 = #(string * float# * int) +type t2 = #{ s : string; f : float#; i : int } [%%expect{| type t1 : float64 & value type t2 = #(string * float# * int) +type t2 = #{ s : string; f : float#; i : int; } |}] (* You can put unboxed and normal products inside unboxed products *) @@ -30,6 +29,15 @@ type t3 : value & (bits64 & (value & float32)) type t4 = #(string * #(int * (bool * int) * char option)) |}] +type t4_inner2 = #{ b : bool; i : int } +type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option } +type t4 = #{ s : string; t4_inner : t4_inner } +[%%expect{| +type t4_inner2 = #{ b : bool; i : int; } +type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option; } +type t4 = #{ s : string; t4_inner : t4_inner; } +|}] + (* But you can't put unboxed products into normal tuples (yet) *) type t_nope = string * #(string * bool) [%%expect{| @@ -43,6 +51,20 @@ Error: Tuple element types must have layout value. because it's the type of a tuple element. |}] +type t_nope_inner = #{ s : string; b : bool } +type t_nope = string * t_nope_inner +[%%expect{| +type t_nope_inner = #{ s : string; b : bool; } +Line 2, characters 23-35: +2 | type t_nope = string * t_nope_inner + ^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of "t_nope_inner" is value & value + because of the definition of t_nope_inner at line 1, characters 0-45. + But the layout of "t_nope_inner" must be a sublayout of value + because it's the type of a tuple element. +|}] + (********************************************) (* Test 2: Simple kind annotations on types *) @@ -53,6 +75,13 @@ type t1 = #(float# * bool) type t2 = #(string option * t1) |}] +type t1 : float64 & value = #{ f : float#; b : bool } +type t2 : value & (float64 & value) = #{ so : string option ; t1 : t1 } +[%%expect{| +type t1 = #{ f : float#; b : bool; } +type t2 = #{ so : string option; t1 : t1; } +|}] + type t2_wrong : value & float64 & value = #(string option * t1) [%%expect{| Line 1, characters 0-63: @@ -65,6 +94,17 @@ Error: The layout of type "#(string option * t1)" is value & (float64 & value) because of the definition of t2_wrong at line 1, characters 0-63. |}] +type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } +[%%expect{| +Line 1, characters 0-74: +1 | type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The layout of type "t2_wrong" is value & (float64 & value) + because it is an unboxed record. + But the layout of type "t2_wrong" must be a sublayout of value & float64 & value + because of the annotation on the declaration of the type t2_wrong. +|}] + type ('a : value & bits64) t3 = 'a type t4 = #(int * int64#) t3 type t5 = t4 t3 @@ -74,6 +114,17 @@ type t4 = #(int * int64#) t3 type t5 = t4 t3 |}] +type ('a : value & bits64) t3 = 'a +type t4_inner = #{ i : int; i64 : int64# } +type t4 = t4_inner t3 +type t5 = t4 t3 +[%%expect{| +type ('a : value & bits64) t3 = 'a +type t4_inner = #{ i : int; i64 : int64#; } +type t4 = t4_inner t3 +type t5 = t4 t3 +|}] + type t4_wrong = #(int * int) t3 [%%expect{| Line 1, characters 16-28: @@ -89,6 +140,22 @@ Error: This type "#(int * int)" should be an instance of type (* CR layouts v7.1: The above error should identify the component of the product that is problematic. *) +type t4_wrong_inner = #{ i1 : int; i2 : int } +type t4_wrong = t4_wrong_inner t3 +[%%expect{| +type t4_wrong_inner = #{ i1 : int; i2 : int; } +Line 2, characters 16-30: +2 | type t4_wrong = t4_wrong_inner t3 + ^^^^^^^^^^^^^^ +Error: This type "t4_wrong_inner" should be an instance of type + "('a : value & bits64)" + The layout of t4_wrong_inner is value & value + because of the definition of t4_wrong_inner at line 1, characters 0-45. + But the layout of t4_wrong_inner must be a sublayout of value & bits64 + because of the definition of t3 at line 1, characters 0-34. +|}] + + (* some mutually recusive types *) type ('a : value & bits64) t6 = 'a t7 and 'a t7 = { x : 'a t6 } @@ -111,6 +178,29 @@ Error: This type "bool" should be an instance of type "('a : value & bits64)" because of the definition of t6 at line 1, characters 0-37. |}] +type ('a : value & bits64) t6 = 'a t7 +and 'a t7 = { x : 'a t6 } +[%%expect{| +type ('a : value & bits64) t6 = 'a t7 +and ('a : value & bits64) t7 = { x : 'a t6; } +|}] + +type t9_record = #{ i : int; i64 : int64# } +type t9 = t9_record t7 +type t10 = bool t6 +[%%expect{| +type t9_record = #{ i : int; i64 : int64#; } +type t9 = t9_record t7 +Line 3, characters 11-15: +3 | type t10 = bool t6 + ^^^^ +Error: This type "bool" should be an instance of type "('a : value & bits64)" + The layout of bool is value + because it is the primitive type bool. + But the layout of bool must be a sublayout of value & bits64 + because of the definition of t6 at line 1, characters 0-37. +|}] + type ('a : value & bits64) t6_wrong = 'a t7_wrong and 'a t7_wrong = { x : #(int * int64) t6_wrong } [%%expect{| @@ -128,6 +218,23 @@ Error: This type "#(int * int64)" should be an instance of type (* CR layouts v7.1: The above error should identify the component of the product that is problematic. *) +type t6_wrong_inner_record = #{ i : int; i64 : int64 } +and ('a : value & bits64) t6_wrong = 'a t7_wrong +and 'a t7_wrong = { x : t6_wrong_inner_record t6_wrong } +[%%expect{| +Line 1, characters 0-54: +1 | type t6_wrong_inner_record = #{ i : int; i64 : int64 } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of t6_wrong_inner_record is any & any + because it is an unboxed record. + But the layout of t6_wrong_inner_record must be a sublayout of + value & bits64 + because of the annotation on 'a in the declaration of the type + t6_wrong. +|}] +(* CR layouts v7.2: The above has a very bad error message. *) + (* Just like t6/t7, but with the annotation on the other (the order doesn't matter) *) type 'a t11 = 'a t12 @@ -137,6 +244,13 @@ type ('a : value & bits64) t11 = 'a t12 and ('a : value & bits64) t12 = { x : 'a t11; } |}] +type 'a t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11 } +[%%expect{| +type ('a : value & bits64) t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11; } +|}] + (* You can make a universal variable have a product layout, but you have to ask for it *) type ('a : float64 & value) t = 'a @@ -212,6 +326,117 @@ val f_take_a_few_unboxed_tuples : |}] +(* Unboxed records version of the same test *) + +type t1_left = #{ i : int; b : bool } +type t1_right_inner = #{ i64 : int64#; so : string option } +type t1_right = #{ i : int; f : float#; inner : t1_right_inner } +type t1 = t1_left -> t1_right +[%%expect{| +type t1_left = #{ i : int; b : bool; } +type t1_right_inner = #{ i64 : int64#; so : string option; } +type t1_right = #{ i : int; f : float#; inner : t1_right_inner; } +type t1 = t1_left -> t1_right +|}] + +type make_record_result = #{ f : float#; s : string } +let f_make_an_unboxed_record (x : string) (y : float#) = #{ f = y; s = x } + +type inner = #{ f1 : float#; f2 : float# } +type t = #{ s : string; inner : inner } +let f_pull_apart_an_unboxed_record (x : t) = + match x with + | #{ s; inner = #{ f1; f2 } } -> + if s = "mul" then + Float_u.mul f1 f2 + else + Float_u.add f1 f2 +[%%expect{| +type make_record_result = #{ f : float#; s : string; } +val f_make_an_unboxed_record : string -> float# -> make_record_result = +type inner = #{ f1 : float#; f2 : float#; } +type t = #{ s : string; inner : inner; } +val f_pull_apart_an_unboxed_record : + t -> Stdlib_upstream_compatible.Float_u.t = +|}] + + +module type S = sig + type a + type b + type c + type d + type e + type f + type g + type h +end + +module F(X : S) = struct + include X + type mix_input_inner2 = #{ d : d; e : e } + type mix_input_inner = #{ c : c; inner2 : mix_input_inner2 } + type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f } + type mix_output_inner2 = #{ f : f; e : e } + type mix_output_inner = #{ c : c; inner2 : mix_output_inner2 } + type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d } + let f_mix_up_an_unboxed_record (x : mix_input) = + let #{ a; b; inner = #{ c; inner2 = #{ d; e } }; f } = x in + #{ b = b; inner = #{ c = c; inner2 = #{ f = f; e = e } }; a = a; d = d } + + type take_few_input1 = #{ a : a; b : b } + type take_few_input3 = #{ d : d; e : e } + type take_few_input5 = #{ g : g; h : h } + type take_few_output = + #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } + + let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 + (x3 : take_few_input3) x4 (x5 : take_few_input5) = + let #{ a; b } = x1 in + let #{ d; e } = x3 in + let #{ g; h } = x5 in + #{ h = h; g2 = g; x4 = x4; e2 = e; d = d; x2 = x2; b = b; a2 = a } +end +[%%expect{| +module type S = + sig type a type b type c type d type e type f type g type h end +module F : + functor (X : S) -> + sig + type a = X.a + type b = X.b + type c = X.c + type d = X.d + type e = X.e + type f = X.f + type g = X.g + type h = X.h + type mix_input_inner2 = #{ d : d; e : e; } + type mix_input_inner = #{ c : c; inner2 : mix_input_inner2; } + type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f; } + type mix_output_inner2 = #{ f : f; e : e; } + type mix_output_inner = #{ c : c; inner2 : mix_output_inner2; } + type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d; } + val f_mix_up_an_unboxed_record : mix_input -> mix_output + type take_few_input1 = #{ a : a; b : b; } + type take_few_input3 = #{ d : d; e : e; } + type take_few_input5 = #{ g : g; h : h; } + type take_few_output = #{ + h : h; + g2 : g; + x4 : f; + e2 : e; + d : d; + x2 : c; + b : b; + a2 : a; + } + val f_take_a_few_unboxed_records : + take_few_input1 -> + c -> take_few_input3 -> f -> take_few_input5 -> take_few_output + end +|}] + (***************************************************) (* Test 4: Unboxed products don't go in structures *) @@ -373,6 +598,194 @@ Error: This expression has type "('a : value_or_null)" But the layout of #('a * 'b) must be a sublayout of value because it's the type of a variable captured in an object. |}];; + +(* Unboxed records version of the same test *) + +type poly_var_inner = #{ i : int; b : bool } +type poly_var_type = [ `Foo of poly_var_inner ] +[%%expect{| +type poly_var_inner = #{ i : int; b : bool; } +Line 2, characters 31-45: +2 | type poly_var_type = [ `Foo of poly_var_inner ] + ^^^^^^^^^^^^^^ +Error: Polymorphic variant constructor argument types must have layout value. + The layout of "poly_var_inner" is value & value + because of the definition of poly_var_inner at line 1, characters 0-44. + But the layout of "poly_var_inner" must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type poly_var_term_record = #{ i : int; i2 : int } +let poly_var_term = `Foo #{ i = 1; i2 = 2 } +[%%expect{| +type poly_var_term_record = #{ i : int; i2 : int; } +Line 2, characters 25-43: +2 | let poly_var_term = `Foo #{ i = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^ +Error: This expression has type "poly_var_term_record" + but an expression was expected of type "('a : value_or_null)" + The layout of poly_var_term_record is value & value + because of the definition of poly_var_term_record at line 1, characters 0-50. + But the layout of poly_var_term_record must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type record_inner = #{ b : bool; f : float# } +type tuple_type = (int * record_inner) +[%%expect{| +type record_inner = #{ b : bool; f : float#; } +Line 2, characters 25-37: +2 | type tuple_type = (int * record_inner) + ^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of "record_inner" is value & float64 + because of the definition of record_inner at line 1, characters 0-45. + But the layout of "record_inner" must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record = #{ i : int; i2 : int } +let tuple_term = ("hi", #{ i = 1; i2 = 2 }) +[%%expect{| +type record = #{ i : int; i2 : int; } +Line 2, characters 24-42: +2 | let tuple_term = ("hi", #{ i = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^ +Error: This expression has type "record" but an expression was expected of type + "('a : value_or_null)" + The layout of record is value & value + because of the definition of record at line 1, characters 0-36. + But the layout of record must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record_inner = #{ i : int; b : bool } +type record = { x : record_inner } +[%%expect{| +type record_inner = #{ i : int; b : bool; } +Line 2, characters 0-34: +2 | type record = { x : record_inner } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "record_inner" has layout "value & value". + Records may not yet contain types of this layout. +|}] + +type inlined_inner = #{ i : int; b : bool } +type inlined_record = A of { x : inlined_inner } +[%%expect{| +type inlined_inner = #{ i : int; b : bool; } +Line 2, characters 22-48: +2 | type inlined_record = A of { x : inlined_inner } + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "inlined_inner" has layout "value & value". + Inlined records may not yet contain types of this layout. +|}] + +type variant_inner = #{ i : int; b : bool } +type variant = A of variant_inner +[%%expect{| +type variant_inner = #{ i : int; b : bool; } +Line 2, characters 15-33: +2 | type variant = A of variant_inner + ^^^^^^^^^^^^^^^^^^ +Error: Type "variant_inner" has layout "value & value". + Variants may not yet contain types of this layout. +|}] + +type sig_inner = #{ i : int; b : bool } +module type S = sig + val x : sig_inner +end +[%%expect{| +type sig_inner = #{ i : int; b : bool; } +Line 3, characters 10-19: +3 | val x : sig_inner + ^^^^^^^^^ +Error: This type signature for "x" is not a value type. + The layout of type sig_inner is value & value + because of the definition of sig_inner at line 1, characters 0-39. + But the layout of type sig_inner must be a sublayout of value + because it's the type of something stored in a module structure. +|}] + +type m_record = #{ i1 : int; i2 : int } +module M = struct + let x = #{ i1 = 1; i2 = 2 } +end +[%%expect{| +type m_record = #{ i1 : int; i2 : int; } +Line 3, characters 6-7: +3 | let x = #{ i1 = 1; i2 = 2 } + ^ +Error: Types of top-level module bindings must have layout "value", but + the type of "x" has layout "value & value". +|}] + +type object_inner = #{ i : int; b : bool } +type object_type = < x : object_inner > +[%%expect{| +type object_inner = #{ i : int; b : bool; } +Line 2, characters 21-37: +2 | type object_type = < x : object_inner > + ^^^^^^^^^^^^^^^^ +Error: Object field types must have layout value. + The layout of "object_inner" is value & value + because of the definition of object_inner at line 1, characters 0-42. + But the layout of "object_inner" must be a sublayout of value + because it's the type of an object field. +|}] + +type object_term_record = #{ i1 : int; i2 : int } +let object_term = object val x = #{ i1 = 1; i2 = 2 } end +[%%expect{| +type object_term_record = #{ i1 : int; i2 : int; } +Line 2, characters 29-30: +2 | let object_term = object val x = #{ i1 = 1; i2 = 2 } end + ^ +Error: Variables bound in a class must have layout value. + The layout of x is value & value + because of the definition of object_term_record at line 1, characters 0-49. + But the layout of x must be a sublayout of value + because it's the type of a class field. +|}] + +type class_record = #{ i1 : int; i2 : int } +class class_ = + object + method x = #{ i1 = 1; i2 = 2 } + end +[%%expect{| +type class_record = #{ i1 : int; i2 : int; } +Line 4, characters 15-34: +4 | method x = #{ i1 = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "class_record" + but an expression was expected of type "('a : value)" + The layout of class_record is value & value + because of the definition of class_record at line 1, characters 0-43. + But the layout of class_record must be a sublayout of value + because it's the type of an object field. +|}] + +type capture_record = #{ x : int; y : int } +let capture_in_object utup = object + val f = fun () -> + let #{ x; y } = utup in + x + y +end;; +[%%expect{| +type capture_record = #{ x : int; y : int; } +Line 4, characters 20-24: +4 | let #{ x; y } = utup in + ^^^^ +Error: This expression has type "('a : value_or_null)" + but an expression was expected of type "capture_record" + The layout of capture_record is value & value + because of the definition of capture_record at line 1, characters 0-43. + But the layout of capture_record must be a sublayout of value + because it's the type of a variable captured in an object. +|}];; + (****************************************************) (* Test 5: Methods may take/return unboxed products *) @@ -385,6 +798,23 @@ class class_with_utuple_manipulating_method : object method f : #(int * int) -> #(int * int) -> #(int * int) end |}] +type method_input = #{ a : int; b : int } +type method_output = #{ sum_a : int; sum_b : int } + +class class_with_urecord_manipulating_method = + object + method f (x : method_input) (y : method_input) = + let #{ a; b } = x in + let #{ a = c; b = d } = y in + #{ sum_a = a + c; sum_b = b + d } + end +[%%expect{| +type method_input = #{ a : int; b : int; } +type method_output = #{ sum_a : int; sum_b : int; } +class class_with_urecord_manipulating_method : + object method f : method_input -> method_input -> method_output end +|}] + (*******************************************) (* Test 6: Nested expansion in kind checks *) @@ -504,8 +934,43 @@ module F : sig type r = X.t4 t_constraint end |}] -(***********************************************) -(* Test 7: modal kinds for unboxed tuple types *) +(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and + boxed records, in the same way as below. + + CR layouts v7.2: These should typecheck for all record forms. +*) +module type S_coherence_deep = sig + type t1 : any + type t2 = #{ i : int; t1 : t1 } +end +[%%expect{| +Line 3, characters 24-31: +3 | type t2 = #{ i : int; t1 : t1 } + ^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of t1 is any + because of the definition of t1 at line 2, characters 2-15. + But the layout of t1 must be representable + because it is the type of record field t1. +|}] + +module type S_coherence_deep = sig + type t1 : any + type t2 = { t1 : t1 } [@@unboxed] +end +[%%expect{| +Line 3, characters 14-21: +3 | type t2 = { t1 : t1 } [@@unboxed] + ^^^^^^^ +Error: [@@unboxed] record element types must have a representable layout. + The layout of t1/2 is any + because of the definition of t1 at line 2, characters 2-15. + But the layout of t1/2 must be representable + because it is the type of record field t1. +|}] + +(*************************************************) +(* Test 7: modal kinds for unboxed product types *) let f_external_utuple_mode_crosses_local_1 : local_ #(int * int) -> #(int * int) = fun x -> x @@ -559,6 +1024,80 @@ Line 3, characters 67-68: Error: This value escapes its region. |}] +(* Unboxed records version of the same test *) + +type local_cross1 = #{ i1 : int; i2 : int } +let f_external_urecord_mode_crosses_local_1 + : local_ local_cross1 -> local_cross1 = fun x -> x +[%%expect{| +type local_cross1 = #{ i1 : int; i2 : int; } +val f_external_urecord_mode_crosses_local_1 : + local_ local_cross1 -> local_cross1 = +|}] + +type local_nocross1 = #{ i : int; s : string } +let f_internal_urecord_does_not_mode_cross_local_1 + : local_ local_nocross1 -> local_nocross1 = fun x -> x +[%%expect{| +type local_nocross1 = #{ i : int; s : string; } +Line 3, characters 55-56: +3 | : local_ local_nocross1 -> local_nocross1 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type local_cross2_inner = #{ b : bool; i : int } +type local_cross2 = #{ i : int; inner : local_cross2_inner } +let f_external_urecord_mode_crosses_local_2 + : local_ local_cross2 -> local_cross2 = fun x -> x +[%%expect{| +type local_cross2_inner = #{ b : bool; i : int; } +type local_cross2 = #{ i : int; inner : local_cross2_inner; } +val f_external_urecord_mode_crosses_local_2 : + local_ local_cross2 -> local_cross2 = +|}] + +type local_nocross2_inner = #{ b : bool; s : string } +type local_nocross2 = #{ i : int; inner : local_nocross2_inner } +let f_internal_urecord_does_not_mode_cross_local_2 + : local_ local_nocross2 -> local_nocross2 = fun x -> x +[%%expect{| +type local_nocross2_inner = #{ b : bool; s : string; } +type local_nocross2 = #{ i : int; inner : local_nocross2_inner; } +Line 4, characters 55-56: +4 | : local_ local_nocross2 -> local_nocross2 = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type t = #{ i1 : int; i2 : int } +type local_cross3_inner = #{ t : t; i : int } +type local_cross3 = #{ i : int; inner : local_cross3_inner } +let f_external_urecord_mode_crosses_local_3 + : local_ local_cross3 -> local_cross3 = fun x -> x +[%%expect{| +type t = #{ i1 : int; i2 : int; } +type local_cross3_inner = #{ t : t; i : int; } +type local_cross3 = #{ i : int; inner : local_cross3_inner; } +val f_external_urecord_mode_crosses_local_3 : + local_ local_cross3 -> local_cross3 = +|}] + +type t = #{ s : string; i : int } +type local_nocross3_inner = #{ t : t; b : bool } +type local_nocross3 = #{ i : int; inner : local_nocross3_inner } +let f_internal_urecord_does_not_mode_cross_local_3 + : local_ local_nocross3 -> local_nocross3 = fun x -> x +[%%expect{| +type t = #{ s : string; i : int; } +type local_nocross3_inner = #{ t : t; b : bool; } +type local_nocross3 = #{ i : int; inner : local_nocross3_inner; } +Line 5, characters 55-56: +5 | : local_ local_nocross3 -> local_nocross3 = fun x -> x + ^ +Error: This value escapes its region. +|}] + (****************************************************) (* Test 8: modal kinds for product kind annotations *) @@ -692,10 +1231,112 @@ external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] val sum : int = 3 |}] +(* Unboxed records version of the same test *) + +type t_product : value & value + +type ext_record_arg_record = #{ i : int; b : bool } +external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" +[%%expect{| +type t_product : value & value +type ext_record_arg_record = #{ i : int; b : bool; } +Line 4, characters 26-54: +4 | external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +type ext_record_arg_attr_record = #{ i : int; b : bool } +external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" +[%%expect{| +type ext_record_arg_attr_record = #{ i : int; b : bool; } +Line 2, characters 37-63: +2 | external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external ext_product_arg : t_product -> int = "foo" "bar" +[%%expect{| +Line 1, characters 27-43: +1 | external ext_product_arg : t_product -> int = "foo" "bar" + ^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" +[%%expect{| +Line 1, characters 38-47: +1 | external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" + ^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +type t = #{ i : int; b : bool } +external ext_record_return : int -> t = "foo" "bar" +[%%expect{| +type t = #{ i : int; b : bool; } +Line 2, characters 29-37: +2 | external ext_record_return : int -> t = "foo" "bar" + ^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +type t = #{ i : int; b : bool } +external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" +[%%expect{| +type t = #{ i : int; b : bool; } +Line 2, characters 47-48: +2 | external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" + ^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external ext_product_return : int -> t_product = "foo" "bar" +[%%expect{| +Line 1, characters 30-46: +1 | external ext_product_return : int -> t_product = "foo" "bar" + ^^^^^^^^^^^^^^^^ +Error: The primitive [foo] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" +[%%expect{| +Line 1, characters 48-57: +1 | external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" + ^^^^^^^^^ +Error: Don't know how to unbox this type. + Only "float", "int32", "int64", "nativeint", vector primitives, and + the corresponding unboxed types can be marked unboxed. +|}] + +external[@layout_poly] id : ('a : any). 'a -> 'a = "%identity" + +type id_record = #{ x : int; y : int } +let sum = + let #{ x; y } = id #{ x = 1; y = 2 } in + x + y +[%%expect{| +external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] +type id_record = #{ x : int; y : int; } +val sum : int = 3 +|}] + + (***********************************) -(* Test 9: not allowed in let recs *) +(* Test 10: not allowed in let recs *) -(* An example that is allowed on tuples but not unboxed tuples *) +(* An example that is allowed on tuples but not unboxed products *) let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () let[@warning "-26"] e2 = let rec x = #(1, y) and y = 42 in () [%%expect{| @@ -711,7 +1352,36 @@ Error: This expression has type "#('a * 'b)" because it's the type of the recursive variable x. |}] -(* This example motivates having a check in [type_let], because +let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () + +type letrec_record = #{ i1 : int; i2 : int } +let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () +[%%expect{| +val e1 : unit = () +type letrec_record = #{ i1 : int; i2 : int; } +Line 4, characters 37-56: +4 | let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "letrec_record" + but an expression was expected of type "('a : value_or_null)" + The layout of letrec_record is value & value + because of the definition of letrec_record at line 3, characters 0-44. + But the layout of letrec_record must be a sublayout of value + because it's the type of the recursive variable x. +|}] + +(* Unboxed records of kind value are also disallowed: *) +type letrec_record = #{ i : int } +let e2 = let rec x = #{ i = y } and y = 42 in () +[%%expect{| +type letrec_record = #{ i : int; } +Line 2, characters 21-31: +2 | let e2 = let rec x = #{ i = y } and y = 42 in () + ^^^^^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}] + +(* These examples motivate having a check in [type_let], because [Value_rec_check] is not set up to reject it, but we don't support even this limited form of unboxed let rec (yet). *) let _ = let rec _x = #(3, 10) and _y = 42 in 42 @@ -727,8 +1397,23 @@ Error: This expression has type "#('a * 'b)" because it's the type of the recursive variable _x. |}] +type letrec_simple = #{ i1 : int; i2 : int } +let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 +[%%expect{| +type letrec_simple = #{ i1 : int; i2 : int; } +Line 2, characters 21-41: +2 | let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "letrec_simple" + but an expression was expected of type "('a : value_or_null)" + The layout of letrec_simple is value & value + because of the definition of letrec_simple at line 1, characters 0-44. + But the layout of letrec_simple must be a sublayout of value + because it's the type of the recursive variable _x. +|}] + (**********************************************************) -(* Test 10: not allowed in [@@unboxed] declarations (yet) *) +(* Test 11: not allowed in [@@unboxed] declarations (yet) *) type ('a : value & value) t = A of 'a [@@unboxed] [%%expect{| @@ -766,8 +1451,53 @@ Error: Type "#(int * int)" has layout "value & value". [@@unboxed] inlined records may not yet contain types of this layout. |}] +type unboxed_record = #{ i1 : int; i2 : int } +type t = A of unboxed_record [@@unboxed] +[%%expect{| +type unboxed_record = #{ i1 : int; i2 : int; } +Line 2, characters 9-28: +2 | type t = A of unboxed_record [@@unboxed] + ^^^^^^^^^^^^^^^^^^^ +Error: Type "unboxed_record" has layout "value & value". + Unboxed variants may not yet contain types of this layout. +|}] + +type ('a : value & value) t = A of { x : 'a } [@@unboxed] +[%%expect{| +Line 1, characters 37-43: +1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] + ^^^^^^ +Error: Type "'a" has layout "value & value". + [@@unboxed] inlined records may not yet contain types of this layout. +|}] + +type unboxed_inline_record = #{ i1 : int; i2 : int } +type t = A of { x : unboxed_inline_record } [@@unboxed] +[%%expect{| +type unboxed_inline_record = #{ i1 : int; i2 : int; } +Line 2, characters 16-41: +2 | type t = A of { x : unboxed_inline_record } [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "unboxed_inline_record" has layout "value & value". + [@@unboxed] inlined records may not yet contain types of this layout. +|}] + +(* Unboxed records of kind value are allowed *) + +type unboxed_record = #{ i : int } +type t = A of unboxed_record [@@unboxed] +[%%expect{| +type unboxed_record = #{ i : int; } +type t = A of unboxed_record [@@unboxed] +|}] + +type t = A of { x : unboxed_record } [@@unboxed] +[%%expect{| +type t = A of { x : unboxed_record; } [@@unboxed] +|}] + (**************************************) -(* Test 11: Unboxed tuples and arrays *) +(* Test 12: Unboxed tuples and arrays *) (* You can write the type of an array of unboxed tuples, but not create one. Soon, you can do both. *) @@ -786,13 +1516,7 @@ type t4 = #(string * #(float# * bool option)) array arrays to beta. *) let _ = [| #(1,2) |] [%%expect{| -Line 1, characters 8-20: -1 | let _ = [| #(1,2) |] - ^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type #(int * int), - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +- : #(int * int) array = [|#(1, 2)|] |}] let _ = Array.init 3 (fun _ -> #(1,2)) @@ -836,13 +1560,7 @@ let f x : #(int * int) = array_get x 3 [%%expect{| external array_get : ('a : any_non_null). 'a array -> int -> 'a = "%array_safe_get" [@@layout_poly] -Line 3, characters 25-38: -3 | let f x : #(int * int) = array_get x 3 - ^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type #(int * int), - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +val f : #(int * int) array -> #(int * int) = |}] external[@layout_poly] array_set : ('a : any_non_null) . 'a array -> int -> 'a -> unit = @@ -851,18 +1569,66 @@ let f x = array_set x 3 #(1,2) [%%expect{| external array_set : ('a : any_non_null). 'a array -> int -> 'a -> unit = "%array_safe_set" [@@layout_poly] -Line 3, characters 10-30: -3 | let f x = array_set x 3 #(1,2) - ^^^^^^^^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type #(int * int), - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. +val f : #(int * int) array -> unit = +|}] + +(* You can write the type of an array of unboxed records and create one. *) +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array + +type t3_record = #{ i : int; b : bool } +type t3 = t3_record array + +type t4_inner = #{ f : float#; bo : bool option } +type t4_record = #{ s : string; inner : t4_inner } +type t4 = t4_record array +[%%expect{| +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array +type t3_record = #{ i : int; b : bool; } +type t3 = t3_record array +type t4_inner = #{ f : float#; bo : bool option; } +type t4_record = #{ s : string; inner : t4_inner; } +type t4 = t4_record array |}] +type array_record = #{ i1 : int; i2 : int } +let _ = [| #{ i1 = 1; i2 = 2 } |] +[%%expect{| +type array_record = #{ i1 : int; i2 : int; } +- : array_record array = [|#{i1 = 1; i2 = 2}|] +|}] + +(* However, such records can't be passed to [Array.init]. *) +type array_init_record = #{ i1 : int; i2 : int } +let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) +[%%expect{| +type array_init_record = #{ i1 : int; i2 : int; } +Line 2, characters 31-50: +2 | let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "array_init_record" + but an expression was expected of type "('a : value)" + The layout of array_init_record is value & value + because of the definition of array_init_record at line 1, characters 0-48. + But the layout of array_init_record must be a sublayout of value. +|}] + +(* Arrays of unboxed records of kind value *are* allowed in all cases *) +type array_record = #{ i : int } +let _ = [| #{ i = 1 } |] +[%%expect{| +type array_record = #{ i : int; } +- : array_record array = [|#{i = 1}|] +|}] + +let _ = Array.init 3 (fun i -> #{ i }) +[%%expect{| +- : array_record array = [|#{i = 0}; #{i = 1}; #{i = 2}|] +|}] (***********************************************************) -(* Test 12: Unboxed products are not allowed as class args *) +(* Test 13: Unboxed products are not allowed as class args *) class product_instance_variable x = let sum = let #(a,b) = x in a + b in @@ -881,8 +1647,40 @@ Error: This expression has type "('a : value)" because it's the type of a term-level argument to a class constructor. |}] +type class_arg_record = #{ a : int; b : int } +class product_instance_variable x = + let sum = let #{ a; b } = x in a + b in + object + method y = sum + end;; +[%%expect{| +type class_arg_record = #{ a : int; b : int; } +Line 3, characters 28-29: +3 | let sum = let #{ a; b } = x in a + b in + ^ +Error: This expression has type "('a : value)" + but an expression was expected of type "class_arg_record" + The layout of class_arg_record is value & value + because of the definition of class_arg_record at line 1, characters 0-45. + But the layout of class_arg_record must be a sublayout of value + because it's the type of a term-level argument to a class constructor. +|}] + +(* But unboxed records of kind value are: *) +type class_arg_record = #{ a : string } +class product_instance_variable x = + let s = let #{ a } = x in a in + object + method y = s + end;; +[%%expect{| +type class_arg_record = #{ a : string; } +class product_instance_variable : + class_arg_record -> object method y : string end +|}] + (*****************************************) -(* Test 13: No lazy unboxed products yet *) +(* Test 14: No lazy unboxed products yet *) let x = lazy #(1,2) @@ -911,8 +1709,52 @@ Error: This type "#(int * int)" should be an instance of type "('a : value)" because the type argument of lazy_t has layout value. |}] +type lazy_record = #{ i1 : int; i2 : int } +let x = lazy #{ i1 = 1; i2 = 2 } +[%%expect{| +type lazy_record = #{ i1 : int; i2 : int; } +Line 2, characters 13-32: +2 | let x = lazy #{ i1 = 1; i2 = 2 } + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "lazy_record" + but an expression was expected of type "('a : value)" + The layout of lazy_record is value & value + because of the definition of lazy_record at line 1, characters 0-42. + But the layout of lazy_record must be a sublayout of value + because it's the type of a lazy expression. +|}] + +type lazy_t_record = #{ i1 : int; i2 : int } +type t = lazy_t_record lazy_t +[%%expect{| +type lazy_t_record = #{ i1 : int; i2 : int; } +Line 2, characters 9-22: +2 | type t = lazy_t_record lazy_t + ^^^^^^^^^^^^^ +Error: This type "lazy_t_record" should be an instance of type "('a : value)" + The layout of lazy_t_record is value & value + because of the definition of lazy_t_record at line 1, characters 0-44. + But the layout of lazy_t_record must be a sublayout of value + because the type argument of lazy_t has layout value. +|}] + +(* Again, unboxed records of kind value can be: *) + +type t = #{ i : int } +let x = lazy #{ i = 1 } +[%%expect{| +type t = #{ i : int; } +val x : t lazy_t = +|}] + +type t2 = t lazy_t +[%%expect{| +type t2 = t lazy_t +|}] + + (***************************************) -(* Test 14: Coercions work covariantly *) +(* Test 15: Coercions work covariantly *) type t = private int @@ -932,8 +1774,26 @@ Error: Type "#(int * int)" is not a subtype of "#(t * t)" Type "int" is not a subtype of "t" |}] +(* Unboxed records can't be coerced *) + +type t = private int + +type coerce_record = #{ t1 : t; t2 : t } +type coerce_int_record = #{ i1 : int; i2 : int } +let f (x : coerce_record) = + let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b +[%%expect{| +type t = private int +type coerce_record = #{ t1 : t; t2 : t; } +type coerce_int_record = #{ i1 : int; i2 : int; } +Line 6, characters 28-52: +6 | let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type "coerce_record" is not a subtype of "coerce_int_record" +|}] + (************************************************) -(* Test 15: Not allowed as an optional argument *) +(* Test 16: Not allowed as an optional argument *) let f_optional_utuple ?(x = #(1,2)) () = x [%%expect{| @@ -948,8 +1808,23 @@ Error: This expression has type "#('a * 'b)" because the type argument of option has layout value. |}] +type optional_record = #{ i1 : int; i2 : int } +let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x +[%%expect{| +type optional_record = #{ i1 : int; i2 : int; } +Line 2, characters 29-48: +2 | let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x + ^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "optional_record" + but an expression was expected of type "('a : value)" + The layout of optional_record is value & value + because of the definition of optional_record at line 1, characters 0-46. + But the layout of optional_record must be a sublayout of value + because the type argument of option has layout value. +|}] + (******************************) -(* Test 16: Decomposing [any] *) +(* Test 17: Decomposing [any] *) type ('a : value) u = U of 'a [@@unboxed] type ('a : value) t = #('a u * 'a u) @@ -998,8 +1873,53 @@ Error: This type "#(int * string * int)" should be an instance of type |}] (* CR layouts v7.1: The appearance of [immutable_data] above is regrettable. *) +type ('a : value) u = U of 'a [@@unboxed] +type ('a : value) t = #{ u1 : 'a u; u2 : 'a u } + +type ('a : any mod global) needs_any_mod_global + +type should_work = int t needs_any_mod_global +[%%expect{| +type 'a u = U of 'a [@@unboxed] +type 'a t = #{ u1 : 'a u; u2 : 'a u; } +type ('a : any mod global) needs_any_mod_global +type should_work = int t needs_any_mod_global +|}] + +type should_fail = string t needs_any_mod_global +[%%expect{| +Line 1, characters 19-27: +1 | type should_fail = string t needs_any_mod_global + ^^^^^^^^ +Error: This type "string t" should be an instance of type "('a : any mod global)" + The kind of string t is value & value + because of the definition of t at line 2, characters 0-47. + But the kind of string t must be a subkind of any mod global + because of the definition of needs_any_mod_global at line 4, characters 0-47. +|}] + +type ('a : any mod external_) t + +type s_record = #{ i1 : int; s : string; i2 : int } +type s = s_record t +[%%expect{| +type ('a : any mod external_) t +type s_record = #{ i1 : int; s : string; i2 : int; } +Line 4, characters 9-17: +4 | type s = s_record t + ^^^^^^^^ +Error: This type "s_record" should be an instance of type + "('a : any mod external_)" + The kind of s_record is + immutable_data & immutable_data & immutable_data + because of the definition of s_record at line 3, characters 0-51. + But the kind of s_record must be a subkind of any mod external_ + because of the definition of t at line 1, characters 0-31. +|}] +(* CR layouts v7.1: Both the above have very bad error messages. *) + (********************************************) -(* Test 17: Subkinding with sorts and [any] *) +(* Test 18: Subkinding with sorts and [any] *) (* CR layouts: Change to use [any] instead of [any_non_null] when doing so won't cause trouble with the [alpha] check. *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics.ml b/testsuite/tests/typing-layouts-products/basics_unboxed_records.ml similarity index 99% rename from testsuite/tests/typing-layouts-unboxed-records/basics.ml rename to testsuite/tests/typing-layouts-products/basics_unboxed_records.ml index 2827e5b0d71..5f6726da4dc 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics.ml +++ b/testsuite/tests/typing-layouts-products/basics_unboxed_records.ml @@ -1,7 +1,6 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; { expect; } @@ -682,7 +681,7 @@ val update_t : t -> unit = type ('a : any) t = #{ x : int; y : 'a } [%%expect{| -type ('a : value_or_null) t = #{ x : int; y : 'a; } +type 'a t = #{ x : int; y : 'a; } |}] (* CR layouts v7.2: once we allow record declarations with unknown kind (right diff --git a/testsuite/tests/typing-layouts-products/exhaustiveness.ml b/testsuite/tests/typing-layouts-products/exhaustiveness.ml index 289088f5ea6..f7601c696fe 100644 --- a/testsuite/tests/typing-layouts-products/exhaustiveness.ml +++ b/testsuite/tests/typing-layouts-products/exhaustiveness.ml @@ -16,3 +16,34 @@ let f t t' = type t = A | B val f : t -> 'a -> bool = |}] + +type t = A | B +type r = #{ x : t; y : t } + +let f t t' = + match #{ x = t; y = t' } with + | #{ x = A; y = _ } -> true + | #{ x = B; y = _ } -> false +[%%expect{| +type t = A | B +type r = #{ x : t; y : t; } +val f : t -> t -> bool = +|}] + +(* This is a regression test. The example below used to give + #{y=A; _ } as a counterexample instead of #{y=A; x=B}. *) +let g t t' = + match #{ x = t; y = t' } with + | #{ x = A; _ } -> true + | #{ y = B; _ } -> false +[%%expect{| +Lines 2-4, characters 2-26: +2 | ..match #{ x = t; y = t' } with +3 | | #{ x = A; _ } -> true +4 | | #{ y = B; _ } -> false +Warning 8 [partial-match]: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +#{y=A; x=B} + +val g : t -> t -> bool = +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml b/testsuite/tests/typing-layouts-products/letrec.ml similarity index 77% rename from testsuite/tests/typing-layouts-unboxed-records/letrec.ml rename to testsuite/tests/typing-layouts-products/letrec.ml index 847b2fa41a6..81ad1611598 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/letrec.ml +++ b/testsuite/tests/typing-layouts-products/letrec.ml @@ -1,20 +1,22 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; { expect; } *) +(* This test was made to error by disallowing singleton recursive unboxed types. + We keep it in case these are re-allowed, in which case it should error with: + [This kind of expression is not allowed as right-hand side of "let rec"] *) type t : value = #{ t : t } let rec t = #{ t = t } [%%expect{| -type t = #{ t : t; } -Line 2, characters 12-22: -2 | let rec t = #{ t = t } - ^^^^^^^^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" +Line 1, characters 0-27: +1 | type t : value = #{ t : t } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t" is recursive without boxing: + "t" contains "t" |}] type bx = { bx : ubx } @@ -34,10 +36,7 @@ let rec t = { bx = #{ ubx = t } } val t : bx = {bx = } |}] -(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) +(* The below is adapted from [testsuite/tests/letrec-check/unboxed.ml]. *) type t = #{x: int64} let rec x = #{x = y} and y = 3L;; diff --git a/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference new file mode 100644 index 00000000000..174e4975100 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_inline_unboxed_record.ml", line 10, characters 22-24: +10 | type variant = Foo of #{ x : string } + ^^ +Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.ml similarity index 82% rename from testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml rename to testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.ml index 5540637473e..9a4052ecef1 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.ml +++ b/testsuite/tests/typing-layouts-products/parsing_inline_unboxed_record.ml @@ -1,5 +1,4 @@ (* TEST - flags = "-extension-universe beta"; setup-ocamlc.byte-build-env; ocamlc_byte_exit_status = "2"; ocamlc.byte; diff --git a/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference new file mode 100644 index 00000000000..7c389fd11e2 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_module_dot_unboxed_record.ml", line 14, characters 11-12: +14 | let t = M.#{ i = 1 } + ^ +Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.ml similarity index 87% rename from testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml rename to testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.ml index 0309a84c82a..fdbd7a50dcc 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.ml +++ b/testsuite/tests/typing-layouts-products/parsing_module_dot_unboxed_record.ml @@ -1,5 +1,4 @@ (* TEST - flags = "-extension-universe beta"; setup-ocamlc.byte-build-env; ocamlc_byte_exit_status = "2"; ocamlc.byte; diff --git a/testsuite/tests/typing-layouts-products/product_arrays.ml b/testsuite/tests/typing-layouts-products/product_arrays.ml index 2aaeeeec00e..d6aadab2171 100644 --- a/testsuite/tests/typing-layouts-products/product_arrays.ml +++ b/testsuite/tests/typing-layouts-products/product_arrays.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; + flags = "-extension layouts_beta"; { expect; } @@ -13,7 +13,7 @@ (* CR layouts v7.1: The PR with middle-end support for product arrays can move this test to beta. *) -(* CR layouts v7.1: Everywhere this file says "any_non_null" it should instead +(* CR layouts v7.1: Everywhere this file says "any" it should instead say any. This is caused by [any] meaning different things alpha and beta - we can fix it when we move this test to beta. *) @@ -1864,10 +1864,8 @@ external blit_scannable : #(int * float * string) array -> int -> #(int * float * string) array -> int -> int -> unit = "%arrayblit" val blit_scannable_app : - ('a : value_or_null). - #(int * float * string) array -> - 'a -> #(int * float * string) array -> int -> int -> unit = - + #(int * float * string) array -> + 'a -> #(int * float * string) array -> int -> int -> unit = external blit_ignorable : #(float# * int * int64# * bool) array -> int -> #(float# * int * int64# * bool) array -> int -> int -> unit @@ -2130,3 +2128,122 @@ Error: Unboxed product array elements must be external or contain all gc scannable types. The product type this function is applied at is not external but contains an element of sort float64. |}] + +(***************************************************) +(* Test 27: Typing of %array_element_size_in_bytes *) + +(* We check you get an error if using a non-value on either side, to guard + against people thinking you use it with the element type rather than the + array. *) + +external[@layout_poly] bytes_bad1 : ('a : any_non_null). 'a -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 36-66: +1 | external[@layout_poly] bytes_bad1 : ('a : any_non_null). 'a -> int + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad2 : ('a : any_non_null). 'a -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 43-45: +1 | external bytes_bad2 : ('a : any_non_null). 'a -> int + ^^ +Error: Types in an external must have a representable layout. + The layout of 'a is any + because of the annotation on the universal variable 'a. + But the layout of 'a must be representable + because it's the type of an argument in an external declaration. +|}] + +external bytes_bad3 : float# -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-35: +1 | external bytes_bad3 : float# -> int + ^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad4 : #(int * int) -> int + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-41: +1 | external bytes_bad4 : #(int * int) -> int + ^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external[@layout_poly] bytes_bad5 : ('a : any_non_null). int -> 'a + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 36-66: +1 | external[@layout_poly] bytes_bad5 : ('a : any_non_null). int -> 'a + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad6 : ('a : any_non_null). int -> 'a + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 50-52: +1 | external bytes_bad6 : ('a : any_non_null). int -> 'a + ^^ +Error: Types in an external must have a representable layout. + The layout of 'a is any + because of the annotation on the universal variable 'a. + But the layout of 'a must be representable + because it's the type of the result of an external declaration. +|}] + +external bytes_bad7 : int -> float# + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-35: +1 | external bytes_bad7 : int -> float# + ^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external bytes_bad8 : int -> #(float# * float#) + = "%array_element_size_in_bytes" +[%%expect{| +Line 1, characters 22-47: +1 | external bytes_bad8 : int -> #(float# * float#) + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The primitive [%array_element_size_in_bytes] is used in an invalid declaration. + The declaration contains argument/return types with the wrong layout. +|}] + +external[@layout_poly] bytes_good1 : ('a : any_non_null). 'a array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good1 : ('a : any_non_null). 'a array -> int + = "%array_element_size_in_bytes" [@@layout_poly] +|}] + +external bytes_good2 : int array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good2 : int array -> int = "%array_element_size_in_bytes" +|}] + +external bytes_good3 : float# array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good3 : float# array -> int = "%array_element_size_in_bytes" +|}] + +external bytes_good4 : #(float# * int) array -> int + = "%array_element_size_in_bytes" +[%%expect{| +external bytes_good4 : #(float# * int) array -> int + = "%array_element_size_in_bytes" +|}] diff --git a/testsuite/tests/typing-layouts-products/product_iarrays.ml b/testsuite/tests/typing-layouts-products/product_iarrays.ml index 82773c9e516..261b8950263 100644 --- a/testsuite/tests/typing-layouts-products/product_iarrays.ml +++ b/testsuite/tests/typing-layouts-products/product_iarrays.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha"; + flags = "-extension layouts_beta"; { expect; } diff --git a/testsuite/tests/typing-layouts-products/recursive.ml b/testsuite/tests/typing-layouts-products/recursive.ml new file mode 100644 index 00000000000..48b586ec093 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/recursive.ml @@ -0,0 +1,475 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + { + expect; + } +*) + +(* We only allow recursion of unboxed product types through boxing, otherwise + the type is uninhabitable and usually also infinite-size. *) + +(***********************************************) +(* Allowed (guarded) recursive unboxed records *) + +(* Guarded by `list` *) +type t = #{ tl: t list } +[%%expect{| +type t = #{ tl : t list; } +|}] + +module AbstractList : sig + type 'a t +end = struct + type 'a t = Cons of 'a * 'a list | Nil +end +[%%expect{| +module AbstractList : sig type 'a t end +|}] + +type t = #{ tl: t AbstractList.t } +[%%expect{| +type t = #{ tl : t AbstractList.t; } +|}] + +type 'a mylist = Cons of 'a * 'a list | Nil +and t = { t : t mylist } [@@unboxed] +[%%expect{| +type 'a mylist = Cons of 'a * 'a list | Nil +and t = { t : t mylist; } [@@unboxed] +|}] + +(* This passes the unboxed recursion check (as [pair] always has jkind + [value & value], [(int, bad) pair] is indeed finite-size, but it fails the + jkind check *) +type ('a, 'b) pair = #{ a : 'a ; b : 'b } +type bad = #{ bad : (int, bad) pair } +[%%expect{| +type ('a, 'b) pair = #{ a : 'a; b : 'b; } +Line 2, characters 0-37: +2 | type bad = #{ bad : (int, bad) pair } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: + The layout of bad is value & value + because of the definition of pair at line 1, characters 0-41. + But the layout of bad must be a sublayout of value + because of the definition of pair at line 1, characters 0-41. +|}] + +(* This fails the unboxed recursion check; we must look into [pair] since it's + part of the same mutually recursive type decl. *) +type ('a, 'b) pair = #{ a : 'a ; b : 'b } +and bad = #{ bad : (int, bad) pair } +[%%expect{| +Line 2, characters 0-36: +2 | and bad = #{ bad : (int, bad) pair } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "(int, bad) pair", + "(int, bad) pair" contains "bad" +|}] + +(* Guarded by a function *) +type t = #{ f1 : t -> t ; f2 : t -> t } +[%%expect{| +type t = #{ f1 : t -> t; f2 : t -> t; } +|}] + +(* Guarded by a tuple *) +type a = #{ b : b } +and b = a * a +[%%expect{| +type a = #{ b : b; } +and b = a * a +|}] + +(* Guarded by a function *) +type a = #{ b : b } +and b = #{ c1 : c ; c2 : c } +and c = unit -> a +[%%expect{| +type a = #{ b : b; } +and b = #{ c1 : c; c2 : c; } +and c = unit -> a +|}] + +(* Recursion through modules guarded by a function *) +module rec A : sig + type t = #{ b1 : B.t ; b2 : B.t } +end = struct + type t = #{ b1 : B.t ; b2 : B.t } +end +and B : sig + type t = unit -> A.t +end = struct + type t = unit -> A.t +end +[%%expect{| +module rec A : sig type t = #{ b1 : B.t; b2 : B.t; } end +and B : sig type t = unit -> A.t end +|}] + +(**********************************) +(* Infinite-sized unboxed records *) + +type bad = #{ bad : bad ; i : int} +[%%expect{| +Line 1, characters 0-34: +1 | type bad = #{ bad : bad ; i : int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type a_bad = #{ b_bad : b_bad } +and b_bad = #{ a_bad : a_bad } +[%%expect{| +Line 1, characters 0-31: +1 | type a_bad = #{ b_bad : b_bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "a_bad" is recursive without boxing: + "a_bad" contains "b_bad", + "b_bad" contains "a_bad" +|}] + +type bad : any = #{ bad : bad } +[%%expect{| +Line 1, characters 0-31: +1 | type bad : any = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad = #{ x : #(int * u) } +and u = T of bad [@@unboxed] +[%%expect{| +Line 1, characters 0-30: +1 | type bad = #{ x : #(int * u) } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "u", + "u" contains "bad" +|}] + +type 'a record_id = #{ a : 'a } +type 'a alias_id = 'a +[%%expect{| +type 'a record_id = #{ a : 'a; } +type 'a alias_id = 'a +|}] + +type bad = bad record_id +[%%expect{| +Line 1, characters 0-24: +1 | type bad = bad record_id + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The type abbreviation "bad" is cyclic: + "bad" = "bad record_id", + "bad record_id" contains "bad" +|}] + +type bad = bad alias_id +[%%expect{| +Line 1, characters 0-23: +1 | type bad = bad alias_id + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: The type abbreviation "bad" is cyclic: + "bad" = "bad alias_id", + "bad alias_id" = "bad" +|}] + + +type 'a bad = #{ bad : 'a bad ; u : 'a} +[%%expect{| +Line 1, characters 0-39: +1 | type 'a bad = #{ bad : 'a bad ; u : 'a} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "'a bad" contains "'a bad" +|}] + +type 'a bad = { bad : 'a bad ; u : 'a} +[%%expect{| +type 'a bad = { bad : 'a bad; u : 'a; } +|}] + +type bad : float64 = #{ bad : bad ; i : int} +[%%expect{| +Line 1, characters 0-44: +1 | type bad : float64 = #{ bad : bad ; i : int} + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad = #{ a : t ; b : t } +[%%expect{| +type bad = #{ a : t; b : t; } +|}] + +type 'a bad = #{ a : 'a bad } +[%%expect{| +Line 1, characters 0-29: +1 | type 'a bad = #{ a : 'a bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "'a bad" contains "'a bad" +|}] + +type bad = #( s * s ) +and ('a : any) record_id2 = #{ a : 'a } +and s = #{ u : u } +and u = #(int * bad record_id2) +[%%expect{| +Line 1, characters 0-21: +1 | type bad = #( s * s ) + ^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" = "#(s * s)", + "#(s * s)" contains "s", + "s" contains "u", + "u" = "#(int * bad record_id2)", + "#(int * bad record_id2)" contains "bad record_id2", + "bad record_id2" contains "bad" +|}] + +type bad = #( s * s ) +and ('a : any) record_id2 = #{ a : 'a } +and s = #{ u : u } +and u = #(int * bad record_id2) +[%%expect{| +Line 1, characters 0-21: +1 | type bad = #( s * s ) + ^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" = "#(s * s)", + "#(s * s)" contains "s", + "s" contains "u", + "u" = "#(int * bad record_id2)", + "#(int * bad record_id2)" contains "bad record_id2", + "bad record_id2" contains "bad" +|}] + +(* We also check recursive types via modules *) +module rec Bad_rec1 : sig + type t = #( s * s ) + and s = #{ u : Bad_rec2.u } +end = struct + type t = #( s * s ) + and s = #{ u : Bad_rec2.u } +end +and Bad_rec2 : sig + type u = Bad_rec1.t id + and 'a id = 'a +end = struct + type u = Bad_rec1.t id + and 'a id = 'a +end +[%%expect{| +Lines 1-7, characters 0-3: +1 | module rec Bad_rec1 : sig +2 | type t = #( s * s ) +3 | and s = #{ u : Bad_rec2.u } +4 | end = struct +5 | type t = #( s * s ) +6 | and s = #{ u : Bad_rec2.u } +7 | end +Error: The definition of "Bad_rec1.t" is recursive without boxing: + "Bad_rec1.t" = "#(Bad_rec1.s * Bad_rec1.s)", + "#(Bad_rec1.s * Bad_rec1.s)" contains "Bad_rec1.s", + "Bad_rec1.s" contains "Bad_rec2.u", + "Bad_rec2.u" = "Bad_rec1.t Bad_rec2.id", + "Bad_rec1.t Bad_rec2.id" = "Bad_rec1.t" +|}] + +(* When we allow records with elements of unrepresentable layout, this should + still be disallowed. *) +module M : sig + type ('a : any) opaque_id : any +end = struct + type ('a : any) opaque_id = 'a +end +[%%expect{| +module M : sig type ('a : any) opaque_id : any end +|}] +type a = #{ b : b M.opaque_id } +and b = #{ a : a M.opaque_id } +[%%expect{| +Line 1, characters 12-29: +1 | type a = #{ b : b M.opaque_id } + ^^^^^^^^^^^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of b M.opaque_id is any + because of the definition of opaque_id at line 2, characters 2-33. + But the layout of b M.opaque_id must be representable + because it is the type of record field b. +|}] + +(* Make sure we look through [as] types *) + +type 'a t = #{ x: ('a s as 'm) list ; m : 'm } +and 'b s = #{ x : 'b t } +[%%expect{| +Line 1, characters 0-46: +1 | type 'a t = #{ x: ('a s as 'm) list ; m : 'm } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t" is recursive without boxing: + "'a t" contains "'a s", + "'a s" contains "'a t" +|}] + +type 'a t = #{ x: ('a s as 'm) } +and 'b s = #{ x : 'b t } +[%%expect{| +Line 1, characters 0-32: +1 | type 'a t = #{ x: ('a s as 'm) } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t" is recursive without boxing: + "'a t" contains "'a s", + "'a s" contains "'a t" +|}] + +(***************************************) +(* Singleton recursive unboxed records *) + +type 'a safe = #{ a : 'a } +type x = int safe safe +[%%expect{| +type 'a safe = #{ a : 'a; } +type x = int safe safe +|}] + +type 'a id = 'a +type x = #{ x : x id } +[%%expect{| +type 'a id = 'a +type x = #{ x : x id; } +|}] + +(* CR layouts v7.2: allow bounded repetition of the same type constructor of + unboxed records. *) +type 'a safe = #{ a : 'a } +and x = int safe safe +[%%expect{| +Line 2, characters 0-21: +2 | and x = int safe safe + ^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "x" is recursive without boxing: + "x" = "int safe safe", + "int safe safe" contains "int safe" +|}] + +(* We could allow these, as although they have unguarded recursion, + they are finite size (thanks to the fact that we represent single-field + records as the layout of the field rather than as a singleton product). + However, allowing them makes checking for recursive types more difficult, + and they are uninhabitable anyway. *) + +type bad : value = #{ bad : bad } +[%%expect{| +Line 1, characters 0-33: +1 | type bad : value = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad : float64 = #{ bad : bad } +[%%expect{| +Line 1, characters 0-35: +1 | type bad : float64 = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + + +type bad : value = #{ bad : bad } +[%%expect{| +Line 1, characters 0-33: +1 | type bad : value = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +type bad = #{ bad : bad } +[%%expect{| +Line 1, characters 0-25: +1 | type bad = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" +|}] + +(* We actually can create singleton recursive unboxed record types, + through recursive modules *) + +module F (X : sig type t end) = struct + type u = #{ u : X.t } +end + +module rec M : sig + type u + type t = u +end = struct + include F(M) + type t = u +end +[%%expect{| +module F : functor (X : sig type t end) -> sig type u = #{ u : X.t; } end +module rec M : sig type u type t = u end +|}] + +module F (X : sig + type u + type t = #{ u : u } + end) = struct + type u = X.t = #{ u : X.u } +end + +module rec M : sig + type u + type t = #{ u : u } +end = struct + include F(M) + type t = #{ u : u } + let rec u = #{ u } +end +[%%expect{| +module F : + functor (X : sig type u type t = #{ u : u; } end) -> + sig type u = X.t = #{ u : X.u; } end +Line 14, characters 14-20: +14 | let rec u = #{ u } + ^^^^^^ +Error: This kind of expression is not allowed as right-hand side of "let rec" +|}] + + +(* This should still error once unboxed records elements need not have a + representable layout *) +module type S = sig + type u : any + type t = #{ a : u ; b : u } +end +module F (X : S) = struct + type u = X.t = #{ a : X.u ; b : X.u} +end + +module rec M : S = struct + include F(M) + type t = #{ a : u ; b : u } + let rec u = #{ u ; u } +end +[%%expect{| +Line 3, characters 14-21: +3 | type t = #{ a : u ; b : u } + ^^^^^^^ +Error: Unboxed record element types must have a representable layout. + The layout of u is any + because of the definition of u at line 2, characters 2-14. + But the layout of u must be representable + because it is the type of record field a. +|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/separability.ml b/testsuite/tests/typing-layouts-products/separability.ml similarity index 100% rename from testsuite/tests/typing-layouts-unboxed-records/separability.ml rename to testsuite/tests/typing-layouts-products/separability.ml diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml b/testsuite/tests/typing-layouts-products/typing_misc_unboxed_records.ml similarity index 99% rename from testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml rename to testsuite/tests/typing-layouts-products/typing_misc_unboxed_records.ml index a15c7fddaa4..01bfbc96624 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing_misc_unboxed_records.ml +++ b/testsuite/tests/typing-layouts-products/typing_misc_unboxed_records.ml @@ -1,5 +1,4 @@ (* TEST - flags = "-extension layouts_beta"; { expect; } diff --git a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml b/testsuite/tests/typing-layouts-products/typing_warnings_unboxed_records.ml similarity index 98% rename from testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml rename to testsuite/tests/typing-layouts-products/typing_warnings_unboxed_records.ml index b56729eeaed..c6f3d3d2340 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/typing-warnings.ml +++ b/testsuite/tests/typing-layouts-products/typing_warnings_unboxed_records.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w +A -strict-sequence -extension layouts_beta"; + flags = " -w +A -strict-sequence"; expect; *) @@ -32,10 +32,7 @@ external ignore_product : ('a : value & value). 'a -> unit = "%ignore" |}] (* This below tests are adapted from - [testsuite/tests/typing-warnings/records.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) + [testsuite/tests/typing-warnings/records.ml]. *) (* Use type information *) module M1 = struct diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml b/testsuite/tests/typing-layouts-products/unboxed_records.ml similarity index 97% rename from testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml rename to testsuite/tests/typing-layouts-products/unboxed_records.ml index 882c107a389..927e1b74603 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.ml +++ b/testsuite/tests/typing-layouts-products/unboxed_records.ml @@ -3,19 +3,6 @@ include stdlib_upstream_compatible; flambda2; { - ocamlc_byte_exit_status = "2"; - setup-ocamlc.byte-build-env; - compiler_reference = "${test_source_directory}/unboxed_records_stable.compilers.reference"; - ocamlc.byte; - check-ocamlc.byte-output; - }{ - ocamlc_byte_exit_status = "2"; - setup-ocamlc.byte-build-env; - flags = "-extension-universe upstream_compatible"; - compiler_reference = "${test_source_directory}/unboxed_records_stable.compilers.reference"; - ocamlc.byte; - check-ocamlc.byte-output; - }{ ocamlc_byte_exit_status = "2"; setup-ocamlc.byte-build-env; flags = "-extension-universe no_extensions"; @@ -46,7 +33,13 @@ }{ flags = "-extension layouts_beta"; bytecode; - } + }{ + flags = ""; + bytecode; + }{ + flags = ""; + native; + } *) open Stdlib_upstream_compatible diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference b/testsuite/tests/typing-layouts-products/unboxed_records.reference similarity index 100% rename from testsuite/tests/typing-layouts-unboxed-records/unboxed_records.reference rename to testsuite/tests/typing-layouts-products/unboxed_records.reference diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml b/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml similarity index 92% rename from testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml rename to testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml index af39bb18f64..0c1d36b2e9e 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_alpha.ml +++ b/testsuite/tests/typing-layouts-products/unboxed_records_alpha.ml @@ -25,7 +25,11 @@ type t = { x : t_void; } [@@unboxed] type bad : void = #{ bad : bad } [%%expect{| -type bad = #{ bad : bad; } +Line 1, characters 0-32: +1 | type bad : void = #{ bad : bad } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "bad" is recursive without boxing: + "bad" contains "bad" |}] type ('a : void) bad = #{ bad : 'a bad ; u : 'a} @@ -33,19 +37,13 @@ type ('a : void) bad = #{ bad : 'a bad ; u : 'a} Line 1, characters 0-49: 1 | type ('a : void) bad = #{ bad : 'a bad ; u : 'a} ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of 'a bad is any & any - because it is an unboxed record. - But the layout of 'a bad must be representable - because it is the type of record field bad. +Error: The definition of "bad" is recursive without boxing: + "'a bad" contains "'a bad" |}] (******************************************************************************) (* The below is adapted from - [testsuite/tests/typing-layouts-products/basics_alpha.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) + [testsuite/tests/typing-layouts-products/basics_alpha.ml]. *) (* [t3] is allowed for unboxed tuples, and disallowed for (un)boxed records *) type t1 : any mod non_null diff --git a/testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference b/testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference new file mode 100644 index 00000000000..41eb03e2334 --- /dev/null +++ b/testsuite/tests/typing-layouts-products/unboxed_records_disabled.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_records.ml", line 47, characters 0-34: +47 | type ints = #{ x : int ; y : int } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This construct requires the stable version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference b/testsuite/tests/typing-layouts-products/unboxed_records_stable.compilers.reference similarity index 100% rename from testsuite/tests/typing-layouts-unboxed-records/unboxed_records_stable.compilers.reference rename to testsuite/tests/typing-layouts-products/unboxed_records_stable.compilers.reference diff --git a/testsuite/tests/typing-layouts-unboxed-records/unique.ml b/testsuite/tests/typing-layouts-products/unique.ml similarity index 96% rename from testsuite/tests/typing-layouts-unboxed-records/unique.ml rename to testsuite/tests/typing-layouts-products/unique.ml index e9d1845bcb4..c7ce98a42bd 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unique.ml +++ b/testsuite/tests/typing-layouts-products/unique.ml @@ -1,7 +1,7 @@ (* TEST flambda2; include stdlib_upstream_compatible; - flags = "-extension layouts_alpha -extension unique"; + flags = "-extension unique"; { expect; } @@ -15,7 +15,7 @@ let unique_use2 : ('a : value & value) @ unique -> unit = fun _ -> () type t = #{ x : string ; y : string } let mk : unit -> t @ unique = fun () -> #{ x = "hi"; y = "hi" } [%%expect{| -val unique_use : ('a : value_or_null). 'a @ unique -> unit = +val unique_use : 'a @ unique -> unit = val unique_use2 : ('a : value & value). 'a @ unique -> unit = type t = #{ x : string; y : string; } val mk : unit -> t @ unique = diff --git a/testsuite/tests/typing-layouts-unboxed-records/unused.ml b/testsuite/tests/typing-layouts-products/unused_unboxed_records.ml similarity index 93% rename from testsuite/tests/typing-layouts-unboxed-records/unused.ml rename to testsuite/tests/typing-layouts-products/unused_unboxed_records.ml index c9f53e69ea9..2f7ef566385 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/unused.ml +++ b/testsuite/tests/typing-layouts-products/unused_unboxed_records.ml @@ -1,12 +1,9 @@ (* TEST - flags = " -w +A -strict-sequence -extension layouts_beta"; + flags = " -w +A -strict-sequence"; expect; *) -(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml]. - - CR layouts v7.2: Once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) +(* Adapted from [testsuite/tests/typing-warnings/unused_types.ml]. *) module Unused_record : sig end = struct type t = #{ a : int; b : int } diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml deleted file mode 100644 index 34c7c5731d3..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_typing_atat_unboxed.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* TEST - flags = "-extension layouts_beta"; - expect; -*) -(* This test is adapted from - [testsuite/tests/typing-unboxed-types/test.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) - -(* Check the unboxing *) - -(* For records *) -type t2 = #{ f : string } ;; -[%%expect{| -type t2 = #{ f : string; } -|}];; - -let x = #{ f = "foo" } in -Obj.repr x == Obj.repr x.#f -;; -[%%expect{| -- : bool = true -|}];; - -(* Representation mismatch between module and signature must be rejected *) -module M : sig - type t = { a : string } -end = struct - type t = #{ a : string } -end;; -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = #{ a : string } -5 | end.. -Error: Signature mismatch: - Modules do not match: - sig type t = #{ a : string; } end - is not included in - sig type t = { a : string; } end - Type declarations do not match: - type t = #{ a : string; } - is not included in - type t = { a : string; } - The first is an unboxed record, but the second is a record. -|}];; - -module M : sig - type t = #{ a : string } -end = struct - type t = { a : string } -end;; -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = { a : string } -5 | end.. -Error: Signature mismatch: - Modules do not match: - sig type t = { a : string; } end - is not included in - sig type t = #{ a : string; } end - Type declarations do not match: - type t = { a : string; } - is not included in - type t = #{ a : string; } - The first is a record, but the second is an unboxed record. -|}] - -(* Check interference with representation of float arrays. *) -type t11 = #{ f : float };; -[%%expect{| -type t11 = #{ f : float; } -|}];; -let x = Array.make 10 #{ f = 3.14 } (* represented as a flat array *) -and f (a : t11 array) = a.(0) (* might wrongly assume an array of pointers *) -in assert (f x = #{ f = 3.14});; -[%%expect{| -- : unit = () -|}];; - -(* Check for a potential infinite loop in the typing algorithm. *) -type 'a t12 : value = #{ a : 'a t12 };; -[%%expect{| -type 'a t12 = #{ a : 'a t12; } -|}];; -let f (a : int t12 array) = a.(0);; -[%%expect{| -val f : int t12 array -> int t12 = -|}];; - -(* should work *) -type t14;; -type t15 = #{ a : t14 };; -[%%expect{| -type t14 -type t15 = #{ a : t14; } -|}];; - -(* should fail because the compiler knows that t is actually float and - optimizes the record's representation *) -module S : sig - type t - type u = { f1 : t; f2 : t } -end = struct - type t = #{ a : float } - type u = { f1 : t; f2 : t } -end;; -[%%expect{| -Lines 4-7, characters 6-3: -4 | ......struct -5 | type t = #{ a : float } -6 | type u = { f1 : t; f2 : t } -7 | end.. -Error: Signature mismatch: - Modules do not match: - sig type t = #{ a : float; } type u = { f1 : t; f2 : t; } end - is not included in - sig type t type u = { f1 : t; f2 : t; } end - Type declarations do not match: - type u = { f1 : t; f2 : t; } - is not included in - type u = { f1 : t; f2 : t; } - Their internal representations differ: - the first declaration uses unboxed float representation. -|}];; - -(* implementing [@@immediate] with unboxed records: this works because the - representation of [t] is [int] - *) -module T : sig - type t [@@immediate] -end = struct - type t = #{ i : int } -end;; -[%%expect{| -module T : sig type t : immediate end -|}];; - - -(* MPR#7682 *) -type f = #{field: 'a. 'a list} ;; -let g = Array.make 10 #{ field=[] };; -let h = g.(5);; -[%%expect{| -type f = #{ field : 'a. 'a list; } -val g : f array = - [|#{field = []}; #{field = []}; #{field = []}; #{field = []}; - #{field = []}; #{field = []}; #{field = []}; #{field = []}; - #{field = []}; #{field = []}|] -val h : f = #{field = []} -|}];; diff --git a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml b/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml deleted file mode 100644 index f48ce4c38d0..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/basics_from_unboxed_tuples_tests.ml +++ /dev/null @@ -1,1017 +0,0 @@ -(* TEST - flambda2; - include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; - { - expect; - } -*) - -(* These tests are adapted from the tuple tests in - [testsuite/tests/typing-layouts-products/basics.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) - -open Stdlib_upstream_compatible - -(**********************************************************) -(* Test 1: Basic unboxed product layouts and record types. *) - -type t2 = #{ s : string; f : float#; i : int } -[%%expect{| -type t2 = #{ s : string; f : float#; i : int; } -|}] - -(* You can put unboxed and normal products inside unboxed products *) -type t4_inner2 = #{ b : bool; i : int } -type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option } -type t4 = #{ s : string; t4_inner : t4_inner } -[%%expect{| -type t4_inner2 = #{ b : bool; i : int; } -type t4_inner = #{ i : int; t4_inner2 : t4_inner2; co : char option; } -type t4 = #{ s : string; t4_inner : t4_inner; } -|}] - -(* But you can't put unboxed products into tuples (yet) *) -type t_nope_inner = #{ s : string; b : bool } -type t_nope = string * t_nope_inner -[%%expect{| -type t_nope_inner = #{ s : string; b : bool; } -Line 2, characters 23-35: -2 | type t_nope = string * t_nope_inner - ^^^^^^^^^^^^ -Error: Tuple element types must have layout value. - The layout of "t_nope_inner" is value & value - because of the definition of t_nope_inner at line 1, characters 0-45. - But the layout of "t_nope_inner" must be a sublayout of value - because it's the type of a tuple element. -|}] - -(********************************************) -(* Test 2: Simple kind annotations on types *) - -type t1 : float64 & value = #{ f : float#; b : bool } -type t2 : value & (float64 & value) = #{ so : string option ; t1 : t1 } -[%%expect{| -type t1 = #{ f : float#; b : bool; } -type t2 = #{ so : string option; t1 : t1; } -|}] - -type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } -[%%expect{| -Line 1, characters 0-74: -1 | type t2_wrong : value & float64 & value = #{ so : string option; t1 : t1 } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type "t2_wrong" is value & (float64 & value) - because it is an unboxed record. - But the layout of type "t2_wrong" must be a sublayout of value & float64 & value - because of the annotation on the declaration of the type t2_wrong. -|}] - -type ('a : value & bits64) t3 = 'a -type t4_inner = #{ i : int; i64 : int64# } -type t4 = t4_inner t3 -type t5 = t4 t3 -[%%expect{| -type ('a : value & bits64) t3 = 'a -type t4_inner = #{ i : int; i64 : int64#; } -type t4 = t4_inner t3 -type t5 = t4 t3 -|}] - -type t4_wrong_inner = #{ i1 : int; i2 : int } -type t4_wrong = t4_wrong_inner t3 -[%%expect{| -type t4_wrong_inner = #{ i1 : int; i2 : int; } -Line 2, characters 16-30: -2 | type t4_wrong = t4_wrong_inner t3 - ^^^^^^^^^^^^^^ -Error: This type "t4_wrong_inner" should be an instance of type - "('a : value & bits64)" - The layout of t4_wrong_inner is value & value - because of the definition of t4_wrong_inner at line 1, characters 0-45. - But the layout of t4_wrong_inner must be a sublayout of value & bits64 - because of the definition of t3 at line 1, characters 0-34. -|}] - -(* some mutually recusive types *) -type ('a : value & bits64) t6 = 'a t7 -and 'a t7 = { x : 'a t6 } -[%%expect{| -type ('a : value & bits64) t6 = 'a t7 -and ('a : value & bits64) t7 = { x : 'a t6; } -|}] - -type t9_record = #{ i : int; i64 : int64# } -type t9 = t9_record t7 -type t10 = bool t6 -[%%expect{| -type t9_record = #{ i : int; i64 : int64#; } -type t9 = t9_record t7 -Line 3, characters 11-15: -3 | type t10 = bool t6 - ^^^^ -Error: This type "bool" should be an instance of type "('a : value & bits64)" - The layout of bool is value - because it is the primitive type bool. - But the layout of bool must be a sublayout of value & bits64 - because of the definition of t6 at line 1, characters 0-37. -|}] - -(* CR layouts v7.2: The below has a very bad error message. *) -type t6_wrong_inner_record = #{ i : int; i64 : int64 } -and ('a : value & bits64) t6_wrong = 'a t7_wrong -and 'a t7_wrong = { x : t6_wrong_inner_record t6_wrong } -[%%expect{| -Line 1, characters 0-54: -1 | type t6_wrong_inner_record = #{ i : int; i64 : int64 } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of t6_wrong_inner_record is any & any - because it is an unboxed record. - But the layout of t6_wrong_inner_record must be a sublayout of - value & bits64 - because of the annotation on 'a in the declaration of the type - t6_wrong. -|}] - -(* Just like t6/t7, but with the annotation on the other (the order doesn't - matter) *) -type 'a t11 = 'a t12 -and ('a : value & bits64) t12 = { x : 'a t11 } -[%%expect{| -type ('a : value & bits64) t11 = 'a t12 -and ('a : value & bits64) t12 = { x : 'a t11; } -|}] - -(*********************************************************************) -(* Test 3: Unboxed records are allowed in function args and returns *) - -type t1_left = #{ i : int; b : bool } -type t1_right_inner = #{ i64 : int64#; so : string option } -type t1_right = #{ i : int; f : float#; inner : t1_right_inner } -type t1 = t1_left -> t1_right -[%%expect{| -type t1_left = #{ i : int; b : bool; } -type t1_right_inner = #{ i64 : int64#; so : string option; } -type t1_right = #{ i : int; f : float#; inner : t1_right_inner; } -type t1 = t1_left -> t1_right -|}] - -type make_record_result = #{ f : float#; s : string } -let f_make_an_unboxed_record (x : string) (y : float#) = #{ f = y; s = x } - -type inner = #{ f1 : float#; f2 : float# } -type t = #{ s : string; inner : inner } -let f_pull_apart_an_unboxed_record (x : t) = - match x with - | #{ s; inner = #{ f1; f2 } } -> - if s = "mul" then - Float_u.mul f1 f2 - else - Float_u.add f1 f2 -[%%expect{| -type make_record_result = #{ f : float#; s : string; } -val f_make_an_unboxed_record : string -> float# -> make_record_result = -type inner = #{ f1 : float#; f2 : float#; } -type t = #{ s : string; inner : inner; } -val f_pull_apart_an_unboxed_record : - t -> Stdlib_upstream_compatible.Float_u.t = -|}] - - -module type S = sig - type a - type b - type c - type d - type e - type f - type g - type h -end - -module F(X : S) = struct - include X - type mix_input_inner2 = #{ d : d; e : e } - type mix_input_inner = #{ c : c; inner2 : mix_input_inner2 } - type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f } - type mix_output_inner2 = #{ f : f; e : e } - type mix_output_inner = #{ c : c; inner2 : mix_output_inner2 } - type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d } - let f_mix_up_an_unboxed_record (x : mix_input) = - let #{ a; b; inner = #{ c; inner2 = #{ d; e } }; f } = x in - #{ b = b; inner = #{ c = c; inner2 = #{ f = f; e = e } }; a = a; d = d } - - type take_few_input1 = #{ a : a; b : b } - type take_few_input3 = #{ d : d; e : e } - type take_few_input5 = #{ g : g; h : h } - type take_few_output = - #{ h : h; g2 : g; x4 : f; e2 : e; d : d; x2 : c; b : b; a2 : a } - - let f_take_a_few_unboxed_records (x1 : take_few_input1) x2 - (x3 : take_few_input3) x4 (x5 : take_few_input5) = - let #{ a; b } = x1 in - let #{ d; e } = x3 in - let #{ g; h } = x5 in - #{ h = h; g2 = g; x4 = x4; e2 = e; d = d; x2 = x2; b = b; a2 = a } -end -[%%expect{| -module type S = - sig type a type b type c type d type e type f type g type h end -module F : - functor (X : S) -> - sig - type a = X.a - type b = X.b - type c = X.c - type d = X.d - type e = X.e - type f = X.f - type g = X.g - type h = X.h - type mix_input_inner2 = #{ d : d; e : e; } - type mix_input_inner = #{ c : c; inner2 : mix_input_inner2; } - type mix_input = #{ a : a; b : b; inner : mix_input_inner; f : f; } - type mix_output_inner2 = #{ f : f; e : e; } - type mix_output_inner = #{ c : c; inner2 : mix_output_inner2; } - type mix_output = #{ b : b; inner : mix_output_inner; a : a; d : d; } - val f_mix_up_an_unboxed_record : mix_input -> mix_output - type take_few_input1 = #{ a : a; b : b; } - type take_few_input3 = #{ d : d; e : e; } - type take_few_input5 = #{ g : g; h : h; } - type take_few_output = #{ - h : h; - g2 : g; - x4 : f; - e2 : e; - d : d; - x2 : c; - b : b; - a2 : a; - } - val f_take_a_few_unboxed_records : - take_few_input1 -> - c -> take_few_input3 -> f -> take_few_input5 -> take_few_output - end -|}] - -(***************************************************) -(* Test 4: Unboxed products don't go in structures *) - -type poly_var_inner = #{ i : int; b : bool } -type poly_var_type = [ `Foo of poly_var_inner ] -[%%expect{| -type poly_var_inner = #{ i : int; b : bool; } -Line 2, characters 31-45: -2 | type poly_var_type = [ `Foo of poly_var_inner ] - ^^^^^^^^^^^^^^ -Error: Polymorphic variant constructor argument types must have layout value. - The layout of "poly_var_inner" is value & value - because of the definition of poly_var_inner at line 1, characters 0-44. - But the layout of "poly_var_inner" must be a sublayout of value - because it's the type of the field of a polymorphic variant. -|}] - -type poly_var_term_record = #{ i : int; i2 : int } -let poly_var_term = `Foo #{ i = 1; i2 = 2 } -[%%expect{| -type poly_var_term_record = #{ i : int; i2 : int; } -Line 2, characters 25-43: -2 | let poly_var_term = `Foo #{ i = 1; i2 = 2 } - ^^^^^^^^^^^^^^^^^^ -Error: This expression has type "poly_var_term_record" - but an expression was expected of type "('a : value_or_null)" - The layout of poly_var_term_record is value & value - because of the definition of poly_var_term_record at line 1, characters 0-50. - But the layout of poly_var_term_record must be a sublayout of value - because it's the type of the field of a polymorphic variant. -|}] - -type record_inner = #{ b : bool; f : float# } -type tuple_type = (int * record_inner) -[%%expect{| -type record_inner = #{ b : bool; f : float#; } -Line 2, characters 25-37: -2 | type tuple_type = (int * record_inner) - ^^^^^^^^^^^^ -Error: Tuple element types must have layout value. - The layout of "record_inner" is value & float64 - because of the definition of record_inner at line 1, characters 0-45. - But the layout of "record_inner" must be a sublayout of value - because it's the type of a tuple element. -|}] - -type record = #{ i : int; i2 : int } -let tuple_term = ("hi", #{ i = 1; i2 = 2 }) -[%%expect{| -type record = #{ i : int; i2 : int; } -Line 2, characters 24-42: -2 | let tuple_term = ("hi", #{ i = 1; i2 = 2 }) - ^^^^^^^^^^^^^^^^^^ -Error: This expression has type "record" but an expression was expected of type - "('a : value_or_null)" - The layout of record is value & value - because of the definition of record at line 1, characters 0-36. - But the layout of record must be a sublayout of value - because it's the type of a tuple element. -|}] - -type record_inner = #{ i : int; b : bool } -type record = { x : record_inner } -[%%expect{| -type record_inner = #{ i : int; b : bool; } -Line 2, characters 0-34: -2 | type record = { x : record_inner } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "record_inner" has layout "value & value". - Records may not yet contain types of this layout. -|}] - -type inlined_inner = #{ i : int; b : bool } -type inlined_record = A of { x : inlined_inner } -[%%expect{| -type inlined_inner = #{ i : int; b : bool; } -Line 2, characters 22-48: -2 | type inlined_record = A of { x : inlined_inner } - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "inlined_inner" has layout "value & value". - Inlined records may not yet contain types of this layout. -|}] - -type variant_inner = #{ i : int; b : bool } -type variant = A of variant_inner -[%%expect{| -type variant_inner = #{ i : int; b : bool; } -Line 2, characters 15-33: -2 | type variant = A of variant_inner - ^^^^^^^^^^^^^^^^^^ -Error: Type "variant_inner" has layout "value & value". - Variants may not yet contain types of this layout. -|}] - -type sig_inner = #{ i : int; b : bool } -module type S = sig - val x : sig_inner -end -[%%expect{| -type sig_inner = #{ i : int; b : bool; } -Line 3, characters 10-19: -3 | val x : sig_inner - ^^^^^^^^^ -Error: This type signature for "x" is not a value type. - The layout of type sig_inner is value & value - because of the definition of sig_inner at line 1, characters 0-39. - But the layout of type sig_inner must be a sublayout of value - because it's the type of something stored in a module structure. -|}] - -type m_record = #{ i1 : int; i2 : int } -module M = struct - let x = #{ i1 = 1; i2 = 2 } -end -[%%expect{| -type m_record = #{ i1 : int; i2 : int; } -Line 3, characters 6-7: -3 | let x = #{ i1 = 1; i2 = 2 } - ^ -Error: Types of top-level module bindings must have layout "value", but - the type of "x" has layout "value & value". -|}] - -type object_inner = #{ i : int; b : bool } -type object_type = < x : object_inner > -[%%expect{| -type object_inner = #{ i : int; b : bool; } -Line 2, characters 21-37: -2 | type object_type = < x : object_inner > - ^^^^^^^^^^^^^^^^ -Error: Object field types must have layout value. - The layout of "object_inner" is value & value - because of the definition of object_inner at line 1, characters 0-42. - But the layout of "object_inner" must be a sublayout of value - because it's the type of an object field. -|}] - -type object_term_record = #{ i1 : int; i2 : int } -let object_term = object val x = #{ i1 = 1; i2 = 2 } end -[%%expect{| -type object_term_record = #{ i1 : int; i2 : int; } -Line 2, characters 29-30: -2 | let object_term = object val x = #{ i1 = 1; i2 = 2 } end - ^ -Error: Variables bound in a class must have layout value. - The layout of x is value & value - because of the definition of object_term_record at line 1, characters 0-49. - But the layout of x must be a sublayout of value - because it's the type of a class field. -|}] - -type class_record = #{ i1 : int; i2 : int } -class class_ = - object - method x = #{ i1 = 1; i2 = 2 } - end -[%%expect{| -type class_record = #{ i1 : int; i2 : int; } -Line 4, characters 15-34: -4 | method x = #{ i1 = 1; i2 = 2 } - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "class_record" - but an expression was expected of type "('a : value)" - The layout of class_record is value & value - because of the definition of class_record at line 1, characters 0-43. - But the layout of class_record must be a sublayout of value - because it's the type of an object field. -|}] - -type capture_record = #{ x : int; y : int } -let capture_in_object utup = object - val f = fun () -> - let #{ x; y } = utup in - x + y -end;; -[%%expect{| -type capture_record = #{ x : int; y : int; } -Line 4, characters 20-24: -4 | let #{ x; y } = utup in - ^^^^ -Error: This expression has type "('a : value_or_null)" - but an expression was expected of type "capture_record" - The layout of capture_record is value & value - because of the definition of capture_record at line 1, characters 0-43. - But the layout of capture_record must be a sublayout of value - because it's the type of a variable captured in an object. -|}];; - -(****************************************************) -(* Test 5: Methods may take/return unboxed products *) - -type method_input = #{ a : int; b : int } -type method_output = #{ sum_a : int; sum_b : int } - -class class_with_urecord_manipulating_method = - object - method f (x : method_input) (y : method_input) = - let #{ a; b } = x in - let #{ a = c; b = d } = y in - #{ sum_a = a + c; sum_b = b + d } - end -[%%expect{| -type method_input = #{ a : int; b : int; } -type method_output = #{ sum_a : int; sum_b : int; } -class class_with_urecord_manipulating_method : - object method f : method_input -> method_input -> method_output end -|}] - -(*******************************************) -(* Test 6: Nested expansion in kind checks *) - -(* This typechecks for unboxed tuples, but fail for [@@unboxed], unboxed, and - boxed records, in the same way as below. - - CR layouts v7.2: These should typecheck for all record forms. -*) -module type S_coherence_deep = sig - type t1 : any - type t2 = #{ i : int; t1 : t1 } -end -[%%expect{| -Line 3, characters 24-31: -3 | type t2 = #{ i : int; t1 : t1 } - ^^^^^^^ -Error: Unboxed record element types must have a representable layout. - The layout of t1 is any - because of the definition of t1 at line 2, characters 2-15. - But the layout of t1 must be representable - because it is the type of record field t1. -|}] - -module type S_coherence_deep = sig - type t1 : any - type t2 = { t1 : t1 } [@@unboxed] -end -[%%expect{| -Line 3, characters 14-21: -3 | type t2 = { t1 : t1 } [@@unboxed] - ^^^^^^^ -Error: [@@unboxed] record element types must have a representable layout. - The layout of t1/2 is any - because of the definition of t1 at line 2, characters 2-15. - But the layout of t1/2 must be representable - because it is the type of record field t1. -|}] - -(***********************************************) -(* Test 7: modal kinds for unboxed record types *) - -type local_cross1 = #{ i1 : int; i2 : int } -let f_external_urecord_mode_crosses_local_1 - : local_ local_cross1 -> local_cross1 = fun x -> x -[%%expect{| -type local_cross1 = #{ i1 : int; i2 : int; } -val f_external_urecord_mode_crosses_local_1 : - local_ local_cross1 -> local_cross1 = -|}] - -type local_nocross1 = #{ i : int; s : string } -let f_internal_urecord_does_not_mode_cross_local_1 - : local_ local_nocross1 -> local_nocross1 = fun x -> x -[%%expect{| -type local_nocross1 = #{ i : int; s : string; } -Line 3, characters 55-56: -3 | : local_ local_nocross1 -> local_nocross1 = fun x -> x - ^ -Error: This value escapes its region. -|}] - -type local_cross2_inner = #{ b : bool; i : int } -type local_cross2 = #{ i : int; inner : local_cross2_inner } -let f_external_urecord_mode_crosses_local_2 - : local_ local_cross2 -> local_cross2 = fun x -> x -[%%expect{| -type local_cross2_inner = #{ b : bool; i : int; } -type local_cross2 = #{ i : int; inner : local_cross2_inner; } -val f_external_urecord_mode_crosses_local_2 : - local_ local_cross2 -> local_cross2 = -|}] - -type local_nocross2_inner = #{ b : bool; s : string } -type local_nocross2 = #{ i : int; inner : local_nocross2_inner } -let f_internal_urecord_does_not_mode_cross_local_2 - : local_ local_nocross2 -> local_nocross2 = fun x -> x -[%%expect{| -type local_nocross2_inner = #{ b : bool; s : string; } -type local_nocross2 = #{ i : int; inner : local_nocross2_inner; } -Line 4, characters 55-56: -4 | : local_ local_nocross2 -> local_nocross2 = fun x -> x - ^ -Error: This value escapes its region. -|}] - -type t = #{ i1 : int; i2 : int } -type local_cross3_inner = #{ t : t; i : int } -type local_cross3 = #{ i : int; inner : local_cross3_inner } -let f_external_urecord_mode_crosses_local_3 - : local_ local_cross3 -> local_cross3 = fun x -> x -[%%expect{| -type t = #{ i1 : int; i2 : int; } -type local_cross3_inner = #{ t : t; i : int; } -type local_cross3 = #{ i : int; inner : local_cross3_inner; } -val f_external_urecord_mode_crosses_local_3 : - local_ local_cross3 -> local_cross3 = -|}] - -type t = #{ s : string; i : int } -type local_nocross3_inner = #{ t : t; b : bool } -type local_nocross3 = #{ i : int; inner : local_nocross3_inner } -let f_internal_urecord_does_not_mode_cross_local_3 - : local_ local_nocross3 -> local_nocross3 = fun x -> x -[%%expect{| -type t = #{ s : string; i : int; } -type local_nocross3_inner = #{ t : t; b : bool; } -type local_nocross3 = #{ i : int; inner : local_nocross3_inner; } -Line 5, characters 55-56: -5 | : local_ local_nocross3 -> local_nocross3 = fun x -> x - ^ -Error: This value escapes its region. -|}] - -(****************************************************) -(* Test 8: modal kinds for product kind annotations *) - -(* Nothing unique to unboxed records here *) - -(*********************) -(* Test 9: externals *) - -type t_product : value & value - -type ext_record_arg_record = #{ i : int; b : bool } -external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" -[%%expect{| -type t_product : value & value -type ext_record_arg_record = #{ i : int; b : bool; } -Line 4, characters 26-54: -4 | external ext_record_arg : ext_record_arg_record -> int = "foo" "bar" - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -type ext_record_arg_attr_record = #{ i : int; b : bool } -external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" -[%%expect{| -type ext_record_arg_attr_record = #{ i : int; b : bool; } -Line 2, characters 37-63: -2 | external ext_record_arg_with_attr : (ext_record_arg_attr_record [@unboxed]) -> int = "foo" - ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -external ext_product_arg : t_product -> int = "foo" "bar" -[%%expect{| -Line 1, characters 27-43: -1 | external ext_product_arg : t_product -> int = "foo" "bar" - ^^^^^^^^^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" -[%%expect{| -Line 1, characters 38-47: -1 | external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" - ^^^^^^^^^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -type t = #{ i : int; b : bool } -external ext_record_return : int -> t = "foo" "bar" -[%%expect{| -type t = #{ i : int; b : bool; } -Line 2, characters 29-37: -2 | external ext_record_return : int -> t = "foo" "bar" - ^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -type t = #{ i : int; b : bool } -external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" -[%%expect{| -type t = #{ i : int; b : bool; } -Line 2, characters 47-48: -2 | external ext_record_return_with_attr : int -> (t [@unboxed]) = "foo" - ^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -external ext_product_return : int -> t_product = "foo" "bar" -[%%expect{| -Line 1, characters 30-46: -1 | external ext_product_return : int -> t_product = "foo" "bar" - ^^^^^^^^^^^^^^^^ -Error: The primitive [foo] is used in an invalid declaration. - The declaration contains argument/return types with the wrong layout. -|}] - -external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" -[%%expect{| -Line 1, characters 48-57: -1 | external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" - ^^^^^^^^^ -Error: Don't know how to unbox this type. - Only "float", "int32", "int64", "nativeint", vector primitives, and - the corresponding unboxed types can be marked unboxed. -|}] - -external[@layout_poly] id : ('a : any). 'a -> 'a = "%identity" - -type id_record = #{ x : int; y : int } -let sum = - let #{ x; y } = id #{ x = 1; y = 2 } in - x + y -[%%expect{| -external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] -type id_record = #{ x : int; y : int; } -val sum : int = 3 -|}] - -(***********************************) -(* Test 9: not allowed in let recs *) - -(* An example that is allowed on tuples but not unboxed products *) -let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () - -type letrec_record = #{ i1 : int; i2 : int } -let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () -[%%expect{| -val e1 : unit = () -type letrec_record = #{ i1 : int; i2 : int; } -Line 4, characters 37-56: -4 | let[@warning "-26"] e2 = let rec x = #{ i1 = 1; i2 = y } and y = 42 in () - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "letrec_record" - but an expression was expected of type "('a : value_or_null)" - The layout of letrec_record is value & value - because of the definition of letrec_record at line 3, characters 0-44. - But the layout of letrec_record must be a sublayout of value - because it's the type of the recursive variable x. -|}] - -(* Unboxed records of kind value are also disallowed: *) -type letrec_record = #{ i : int } -let e2 = let rec x = #{ i = y } and y = 42 in () -[%%expect{| -type letrec_record = #{ i : int; } -Line 2, characters 21-31: -2 | let e2 = let rec x = #{ i = y } and y = 42 in () - ^^^^^^^^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" -|}] - -(* This example motivates having a check in [type_let], because - [Value_rec_check] is not set up to reject it, but we don't support even this - limited form of unboxed let rec (yet). *) -type letrec_simple = #{ i1 : int; i2 : int } -let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 -[%%expect{| -type letrec_simple = #{ i1 : int; i2 : int; } -Line 2, characters 21-41: -2 | let _ = let rec _x = #{ i1 = 3; i2 = 10 } and _y = 42 in 42 - ^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "letrec_simple" - but an expression was expected of type "('a : value_or_null)" - The layout of letrec_simple is value & value - because of the definition of letrec_simple at line 1, characters 0-44. - But the layout of letrec_simple must be a sublayout of value - because it's the type of the recursive variable _x. -|}] - -(**********************************************************) -(* Test 10: unboxed products not allowed in [@@unboxed] declarations (yet) *) - -type unboxed_record = #{ i1 : int; i2 : int } -type t = A of unboxed_record [@@unboxed] -[%%expect{| -type unboxed_record = #{ i1 : int; i2 : int; } -Line 2, characters 9-28: -2 | type t = A of unboxed_record [@@unboxed] - ^^^^^^^^^^^^^^^^^^^ -Error: Type "unboxed_record" has layout "value & value". - Unboxed variants may not yet contain types of this layout. -|}] - -type ('a : value & value) t = A of { x : 'a } [@@unboxed] -[%%expect{| -Line 1, characters 37-43: -1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] - ^^^^^^ -Error: Type "'a" has layout "value & value". - [@@unboxed] inlined records may not yet contain types of this layout. -|}] - -type unboxed_inline_record = #{ i1 : int; i2 : int } -type t = A of { x : unboxed_inline_record } [@@unboxed] -[%%expect{| -type unboxed_inline_record = #{ i1 : int; i2 : int; } -Line 2, characters 16-41: -2 | type t = A of { x : unboxed_inline_record } [@@unboxed] - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "unboxed_inline_record" has layout "value & value". - [@@unboxed] inlined records may not yet contain types of this layout. -|}] - -(* Unboxed records of kind value are allowed *) - -type unboxed_record = #{ i : int } -type t = A of unboxed_record [@@unboxed] -[%%expect{| -type unboxed_record = #{ i : int; } -type t = A of unboxed_record [@@unboxed] -|}] - -type t = A of { x : unboxed_record } [@@unboxed] -[%%expect{| -type t = A of { x : unboxed_record; } [@@unboxed] -|}] - - -(**************************************) -(* Test 11: Unboxed records and arrays *) - -(* You can write the type of an array of unboxed records, but not create - one. Soon, you can do both. *) -type ('a : value & value) t1 = 'a array -type ('a : bits64 & (value & float64)) t2 = 'a array - -type t3_record = #{ i : int; b : bool } -type t3 = t3_record array - -type t4_inner = #{ f : float#; bo : bool option } -type t4_record = #{ s : string; inner : t4_inner } -type t4 = t4_record array -[%%expect{| -type ('a : value & value) t1 = 'a array -type ('a : bits64 & (value & float64)) t2 = 'a array -type t3_record = #{ i : int; b : bool; } -type t3 = t3_record array -type t4_inner = #{ f : float#; bo : bool option; } -type t4_record = #{ s : string; inner : t4_inner; } -type t4 = t4_record array -|}] - -type array_record = #{ i1 : int; i2 : int } -let _ = [| #{ i1 = 1; i2 = 2 } |] -[%%expect{| -type array_record = #{ i1 : int; i2 : int; } -Line 2, characters 8-33: -2 | let _ = [| #{ i1 = 1; i2 = 2 } |] - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value layout value & value detected as sort for type array_record, - but this requires extension layouts_alpha, which is not enabled. - If you intended to use this layout, please add this flag to your build file. - Otherwise, please report this error to the Jane Street compilers team. -|}] - -type array_init_record = #{ i1 : int; i2 : int } -let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) -[%%expect{| -type array_init_record = #{ i1 : int; i2 : int; } -Line 2, characters 31-50: -2 | let _ = Array.init 3 (fun _ -> #{ i1 = 1; i2 = 2 }) - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "array_init_record" - but an expression was expected of type "('a : value)" - The layout of array_init_record is value & value - because of the definition of array_init_record at line 1, characters 0-48. - But the layout of array_init_record must be a sublayout of value. -|}] - -(* Arrays of unboxed records of kind value *are* allowed *) -type array_record = #{ i : int } -let _ = [| #{ i = 1 } |] -[%%expect{| -type array_record = #{ i : int; } -- : array_record array = [|#{i = 1}|] -|}] - -let _ = Array.init 3 (fun i -> #{ i }) -[%%expect{| -- : array_record array = [|#{i = 0}; #{i = 1}; #{i = 2}|] -|}] - -(***********************************************************) -(* Test 12: Unboxed products are not allowed as class args *) - -type class_arg_record = #{ a : int; b : int } -class product_instance_variable x = - let sum = let #{ a; b } = x in a + b in - object - method y = sum - end;; -[%%expect{| -type class_arg_record = #{ a : int; b : int; } -Line 3, characters 28-29: -3 | let sum = let #{ a; b } = x in a + b in - ^ -Error: This expression has type "('a : value)" - but an expression was expected of type "class_arg_record" - The layout of class_arg_record is value & value - because of the definition of class_arg_record at line 1, characters 0-45. - But the layout of class_arg_record must be a sublayout of value - because it's the type of a term-level argument to a class constructor. -|}] - -(* But unboxed records of kind value are: *) -type class_arg_record = #{ a : string } -class product_instance_variable x = - let s = let #{ a } = x in a in - object - method y = s - end;; -[%%expect{| -type class_arg_record = #{ a : string; } -class product_instance_variable : - class_arg_record -> object method y : string end -|}] - - -(*****************************************) -(* Test 13: No lazy unboxed products yet *) - -type lazy_record = #{ i1 : int; i2 : int } -let x = lazy #{ i1 = 1; i2 = 2 } -[%%expect{| -type lazy_record = #{ i1 : int; i2 : int; } -Line 2, characters 13-32: -2 | let x = lazy #{ i1 = 1; i2 = 2 } - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "lazy_record" - but an expression was expected of type "('a : value)" - The layout of lazy_record is value & value - because of the definition of lazy_record at line 1, characters 0-42. - But the layout of lazy_record must be a sublayout of value - because it's the type of a lazy expression. -|}] - -type lazy_t_record = #{ i1 : int; i2 : int } -type t = lazy_t_record lazy_t -[%%expect{| -type lazy_t_record = #{ i1 : int; i2 : int; } -Line 2, characters 9-22: -2 | type t = lazy_t_record lazy_t - ^^^^^^^^^^^^^ -Error: This type "lazy_t_record" should be an instance of type "('a : value)" - The layout of lazy_t_record is value & value - because of the definition of lazy_t_record at line 1, characters 0-44. - But the layout of lazy_t_record must be a sublayout of value - because the type argument of lazy_t has layout value. -|}] - -(* Again, unboxed records of kind value can be: *) - -type t = #{ i : int } -let x = lazy #{ i = 1 } -[%%expect{| -type t = #{ i : int; } -val x : t lazy_t = -|}] - -type t2 = t lazy_t -[%%expect{| -type t2 = t lazy_t -|}] - -(*********************************************) -(* Test 14: Unboxed records can't be coerced *) - -type t = private int - -type coerce_record = #{ t1 : t; t2 : t } -type coerce_int_record = #{ i1 : int; i2 : int } -let f (x : coerce_record) = - let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b -[%%expect{| -type t = private int -type coerce_record = #{ t1 : t; t2 : t; } -type coerce_int_record = #{ i1 : int; i2 : int; } -Line 6, characters 28-52: -6 | let #{ i1 = a; i2 = b } = (x :> coerce_int_record) in a + b - ^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type "coerce_record" is not a subtype of "coerce_int_record" -|}] - -(************************************************) -(* Test 15: Not allowed as an optional argument *) - -type optional_record = #{ i1 : int; i2 : int } -let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x -[%%expect{| -type optional_record = #{ i1 : int; i2 : int; } -Line 2, characters 29-48: -2 | let f_optional_urecord ?(x = #{ i1 = 1; i2 = 2 }) () = x - ^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "optional_record" - but an expression was expected of type "('a : value)" - The layout of optional_record is value & value - because of the definition of optional_record at line 1, characters 0-46. - But the layout of optional_record must be a sublayout of value - because the type argument of option has layout value. -|}] - -(******************************) -(* Test 16: Decomposing [any] *) - -type ('a : value) u = U of 'a [@@unboxed] -type ('a : value) t = #{ u1 : 'a u; u2 : 'a u } - -type ('a : any mod global) needs_any_mod_global - -type should_work = int t needs_any_mod_global -[%%expect{| -type 'a u = U of 'a [@@unboxed] -type 'a t = #{ u1 : 'a u; u2 : 'a u; } -type ('a : any mod global) needs_any_mod_global -type should_work = int t needs_any_mod_global -|}] - -type should_fail = string t needs_any_mod_global -[%%expect{| -Line 1, characters 19-27: -1 | type should_fail = string t needs_any_mod_global - ^^^^^^^^ -Error: This type "string t" should be an instance of type "('a : any mod global)" - The kind of string t is value & value - because of the definition of t at line 2, characters 0-47. - But the kind of string t must be a subkind of any mod global - because of the definition of needs_any_mod_global at line 4, characters 0-47. -|}] - -type ('a : any mod external_) t - -type s_record = #{ i1 : int; s : string; i2 : int } -type s = s_record t -[%%expect{| -type ('a : any mod external_) t -type s_record = #{ i1 : int; s : string; i2 : int; } -Line 4, characters 9-17: -4 | type s = s_record t - ^^^^^^^^ -Error: This type "s_record" should be an instance of type - "('a : any mod external_)" - The kind of s_record is - immutable_data & immutable_data & immutable_data - because of the definition of s_record at line 3, characters 0-51. - But the kind of s_record must be a subkind of any mod external_ - because of the definition of t at line 1, characters 0-31. -|}] -(* CR layouts v7.1: Both the above have very bad error messages. *) diff --git a/testsuite/tests/typing-layouts-unboxed-records/disabled.ml b/testsuite/tests/typing-layouts-unboxed-records/disabled.ml deleted file mode 100644 index 61ba712ee89..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/disabled.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* TEST - expect; -*) - -(* Types *) -type t = #{ a : int } -[%%expect{| -Line 1, characters 0-21: -1 | type t = #{ a : int } - ^^^^^^^^^^^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -(* Construction *) -let _ = #{ u = () } -[%%expect{| -Line 1, characters 8-19: -1 | let _ = #{ u = () } - ^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -(* Field *) -let get r = r.#x -[%%expect{| -Line 1, characters 12-16: -1 | let get r = r.#x - ^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] - -(* Patterns *) -let #{ u = () } = () -[%%expect{| -Line 1, characters 4-15: -1 | let #{ u = () } = () - ^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml b/testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml deleted file mode 100644 index 55307a90abf..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/exhaustiveness.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* TEST - flags = "-w +8 -extension layouts_beta"; - expect; -*) - -(* This is a regression test. The example below used to give an exhaustiveness - warning because we forgot a case in [Parmatch.simple_match]. *) - -type t = A | B -type r = #{ x : t; y : t } - -let f t t' = - match #{ x = t; y = t' } with - | #{ x = A; y = _ } -> true - | #{ x = B; y = _ } -> false -[%%expect{| -type t = A | B -type r = #{ x : t; y : t; } -val f : t -> t -> bool = -|}] - -(* This is a regression test. The example below used to give - #{y=A; _ } as a counterexample instead of #{y=A; x=B}. *) -let g t t' = - match #{ x = t; y = t' } with - | #{ x = A; _ } -> true - | #{ y = B; _ } -> false -[%%expect{| -Lines 2-4, characters 2-26: -2 | ..match #{ x = t; y = t' } with -3 | | #{ x = A; _ } -> true -4 | | #{ y = B; _ } -> false -Warning 8 [partial-match]: this pattern-matching is not exhaustive. -Here is an example of a case that is not matched: -#{y=A; x=B} - -val g : t -> t -> bool = -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/modality.ml b/testsuite/tests/typing-layouts-unboxed-records/modality.ml deleted file mode 100644 index c4d6e3bf8ca..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/modality.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* TEST - flags = "-extension layouts_beta"; - expect; -*) - -(* This test is adapted from - [testsuite/tests/typing-local/local.ml]. - - CR layouts v7.2: once unboxed records are in stable, fold this test back into - the original or move it to [typing-layouts-products]. *) -type 'a gbl = #{ global_ gbl : 'a } -[%%expect{| -type 'a gbl = #{ global_ gbl : 'a; } -|}] - -let foo (local_ x) = x.#gbl -[%%expect{| -val foo : local_ 'a gbl -> 'a = -|}] -let foo y = - let x = local_ #{ gbl = y } in - x.#gbl -[%%expect{| -val foo : 'a -> 'a = -|}] -let foo (local_ #{ gbl }) = gbl -[%%expect{| -val foo : local_ 'a gbl -> 'a = -|}] -let foo y = - let #{ gbl } = local_ #{ gbl = y } in - gbl -[%%expect{| -val foo : 'a -> 'a = -|}] -let foo (local_ gbl) = - let _ = #{ gbl } in - () -[%%expect{| -Line 2, characters 13-16: -2 | let _ = #{ gbl } in - ^^^ -Error: This value escapes its region. -|}] -let foo () = - let gbl = local_ ref 5 in - let _ = #{ gbl } in - () -[%%expect{| -Line 3, characters 13-16: -3 | let _ = #{ gbl } in - ^^^ -Error: This value escapes its region. -|}] - -(* Global fields are preserved in module inclusion *) -module M : sig - type t = #{ global_ foo : string } -end = struct - type t = #{ foo : string } -end -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = #{ foo : string } -5 | end -Error: Signature mismatch: - Modules do not match: - sig type t = #{ foo : string; } end - is not included in - sig type t = #{ global_ foo : string; } end - Type declarations do not match: - type t = #{ foo : string; } - is not included in - type t = #{ global_ foo : string; } - Fields do not match: - "foo : string;" - is not the same as: - "global_ foo : string;" - The second is global_ and the first is not. -|}] - -module M : sig - type t = #{ foo : string } -end = struct - type t = #{ global_ foo : string } -end -[%%expect{| -Lines 3-5, characters 6-3: -3 | ......struct -4 | type t = #{ global_ foo : string } -5 | end -Error: Signature mismatch: - Modules do not match: - sig type t = #{ global_ foo : string; } end - is not included in - sig type t = #{ foo : string; } end - Type declarations do not match: - type t = #{ global_ foo : string; } - is not included in - type t = #{ foo : string; } - Fields do not match: - "global_ foo : string;" - is not the same as: - "foo : string;" - The first is global_ and the second is not. -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference deleted file mode 100644 index 9c0cd4c1811..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_inline_unboxed_record.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -File "parsing_inline_unboxed_record.ml", line 11, characters 22-24: -11 | type variant = Foo of #{ x : string } - ^^ -Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference deleted file mode 100644 index 11f6958ebe9..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/parsing_module_dot_unboxed_record.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -File "parsing_module_dot_unboxed_record.ml", line 15, characters 11-12: -15 | let t = M.#{ i = 1 } - ^ -Error: Syntax error diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml deleted file mode 100644 index a9e00527391..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml +++ /dev/null @@ -1,197 +0,0 @@ -(* TEST - flambda2; - include stdlib_upstream_compatible; - flags = "-extension layouts_beta"; - { - expect; - } -*) - -(* CR layouts v7.2: figure out the story for recursive unboxed products. - Consider that the following is allowed upstream: - type t = { t : t } [@@unboxed] - We should also give good errors for infinite-size unboxed records (see the - test at the bottom of this file with a depth-100 kind). -*) - -(************************************) -(* Basic recursive unboxed products *) - -type t : value = #{ t : t } -[%%expect{| -type t = #{ t : t; } -|}] - -type t : float64 = #{ t : t } -[%%expect{| -type t = #{ t : t; } -|}] - - -type t : value = #{ t : t } -[%%expect{| -type t = #{ t : t; } -|}] - -(* CR layouts v7.2: Once we support unboxed records with elements of kind [any], - and detect bad recursive unboxed records with an occurs check, this error - should improve. -*) -type bad = #{ bad : bad ; i : int} -[%%expect{| -Line 1, characters 0-34: -1 | type bad = #{ bad : bad ; i : int} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of bad is any & any - because it is an unboxed record. - But the layout of bad must be representable - because it is the type of record field bad. -|}] - -type bad = #{ bad : bad } -[%%expect{| -Line 1, characters 0-25: -1 | type bad = #{ bad : bad } - ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of bad is any - because a dummy kind of any is used to check mutually recursive datatypes. - Please notify the Jane Street compilers group if you see this output. - But the layout of bad must be representable - because it is the type of record field bad. -|}] - -type a_bad = #{ b_bad : b_bad } -and b_bad = #{ a_bad : a_bad } -[%%expect{| -Line 1, characters 0-31: -1 | type a_bad = #{ b_bad : b_bad } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of a_bad is any - because a dummy kind of any is used to check mutually recursive datatypes. - Please notify the Jane Street compilers group if you see this output. - But the layout of a_bad must be representable - because it is the type of record field a_bad. -|}] - -type bad : any = #{ bad : bad } -[%%expect{| -Line 1, characters 0-31: -1 | type bad : any = #{ bad : bad } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of bad is any - because of the annotation on the declaration of the type bad. - But the layout of bad must be representable - because it is the type of record field bad. -|}] - -type 'a id = #{ a : 'a } -type bad = bad id -[%%expect{| -type 'a id = #{ a : 'a; } -Line 2, characters 0-17: -2 | type bad = bad id - ^^^^^^^^^^^^^^^^^ -Error: The type abbreviation "bad" is cyclic: - "bad" = "bad id", - "bad id" contains "bad" -|}] - - -type 'a bad = #{ bad : 'a bad ; u : 'a} -[%%expect{| -Line 1, characters 0-39: -1 | type 'a bad = #{ bad : 'a bad ; u : 'a} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: - The layout of 'a bad is any & any - because it is an unboxed record. - But the layout of 'a bad must be representable - because it is the type of record field bad. -|}] - -type 'a bad = { bad : 'a bad ; u : 'a} -[%%expect{| -type 'a bad = { bad : 'a bad; u : 'a; } -|}] - -(****************************) -(* A particularly bad error *) - -type bad : float64 = #{ bad : bad ; i : int} -[%%expect{| -Line 1, characters 0-44: -1 | type bad : float64 = #{ bad : bad ; i : int} - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type "bad" is (((((((((((((((((((((((((((((((((((( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - ( - (float64 & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value) & value - because it is an unboxed record. - But the layout of type "bad" must be a sublayout of float64 - because of the annotation on the declaration of the type bad. -|}] diff --git a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference b/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference deleted file mode 100644 index 75e6f993887..00000000000 --- a/testsuite/tests/typing-layouts-unboxed-records/unboxed_records_disabled.compilers.reference +++ /dev/null @@ -1,4 +0,0 @@ -File "unboxed_records.ml", line 54, characters 0-34: -54 | type ints = #{ x : int ; y : int } - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/testsuite/tests/typing-layouts/jkinds.ml b/testsuite/tests/typing-layouts/jkinds.ml index eec92625b42..119aab32b9b 100644 --- a/testsuite/tests/typing-layouts/jkinds.ml +++ b/testsuite/tests/typing-layouts/jkinds.ml @@ -279,8 +279,8 @@ Error: Layout void is more experimental than allowed by the enabled layouts exte |}] type a : immediate -type b : value mod global unique many uncontended portable external_ = a -type c : value mod global unique many uncontended portable external_ +type b : value mod global unique many uncontended portable unyielding external_ = a +type c : value mod global unique many uncontended portable unyielding external_ type d : immediate = c [%%expect{| type a : immediate @@ -290,8 +290,8 @@ type d = c |}] type a : immediate64 -type b : value mod global unique many uncontended portable external64 = a -type c : value mod global unique many uncontended portable external64 +type b : value mod global unique many uncontended portable unyielding external64 = a +type c : value mod global unique many uncontended portable unyielding external64 type d : immediate64 = c [%%expect{| type a : immediate64 diff --git a/testsuite/tests/typing-layouts/layout_poly.ml b/testsuite/tests/typing-layouts/layout_poly.ml index acbd1dd0d0c..8037325d149 100644 --- a/testsuite/tests/typing-layouts/layout_poly.ml +++ b/testsuite/tests/typing-layouts/layout_poly.ml @@ -1,10 +1,6 @@ (* TEST include stdlib_upstream_compatible; { - flags = "-extension layouts"; - expect; - }{ - flags = "-extension layouts_beta"; expect; } *) @@ -715,8 +711,8 @@ Error: "[@layout_poly]" on this external declaration has no variable for it to operate on. |}] -(***********************************************) -(* New untested array prims are gated to alpha *) +(********************************************************) +(* Newer prims are gated to appropriate maturity levels *) external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = "%makearray_dynamic" @@ -724,7 +720,7 @@ external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a Lines 1-2, characters 0-22: 1 | external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = 2 | "%makearray_dynamic" -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used |}] external[@layout_poly] arrayblit : @@ -735,5 +731,14 @@ Lines 1-3, characters 0-14: 1 | external[@layout_poly] arrayblit : 2 | ('a : any_non_null). 'a array -> int -> 'a array -> int -> int -> unit = 3 | "%arrayblit" -Error: This construct requires the alpha version of the extension "layouts", which is disabled and cannot be used +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = + "%makearray_dynamic_uninit" +[%%expect{| +Lines 1-2, characters 0-29: +1 | external[@layout_poly] makearray_dynamic : ('a : any_non_null). int -> 'a -> 'a array = +2 | "%makearray_dynamic_uninit" +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used |}] diff --git a/testsuite/tests/typing-layouts/or_null.ml b/testsuite/tests/typing-layouts/or_null.ml deleted file mode 100644 index a33be00ac66..00000000000 --- a/testsuite/tests/typing-layouts/or_null.ml +++ /dev/null @@ -1,332 +0,0 @@ -(* TEST - reason = "Unboxed types aren't implemented yet"; - skip; - expect; -*) -(* CR layouts (v3): enable this test *) - -module type Or_null = sig - (* CR layouts (v3): Not sure how to express that None and Some should - be part of this module. They're not quite constructors. So the syntax - here might plausibly change. *) - type 'a t = 'a or_null = - | None - | Some of 'a - - val none : 'a or_null - val some : 'a -> 'a or_null - val value : 'a or_null -> default:'a -> 'a - val get : 'a or_null -> 'a - val bind : 'a or_null -> ('a -> 'b or_null) -> 'b or_null - (* unlike [option] we cannot have [join] *) - val map : ('a -> 'b) -> 'a or_null -> 'b or_null - val fold : none:'a -> some:('b -> 'a) -> 'b or_null -> 'a - val iter : ('a -> unit) -> 'a or_null -> unit - - val is_none : 'a or_null -> bool - val is_some : 'a or_null -> bool - val equal : ('a -> 'a -> bool) -> 'a or_null -> 'a or_null -> bool - val compare : ('a -> 'a -> int) -> 'a or_null -> 'a or_null -> int - - val to_result : none:'e -> 'a or_null -> ('a, 'e) result - val to_list : 'a or_null -> 'a list - val to_seq : 'a or_null -> 'a Seq.t - - val to_option : 'a or_null -> 'a option - val of_option : 'a option -> 'a or_null -end - -module Or_null : Or_null = Or_null - -(* CR layouts (v3): check output to see how bad the pretty-printing is. - In particular, it would be nice to suppress layout annotations that - are implied by the rest of the signature, but this may be hard. *) -[%%expect {| -success -|}] - -(* ensure that immediacy "looks through" or_null *) -type t1 : immediate = int or_null -type t2 : immediate = bool or_null - -[%%expect {| -success -|}] - -type t : immediate = string or_null - -[%%expect {| -error -|}] - -type t : value = string or_null - -[%%expect {| -success -|}] - -(* ensure that or_null can't be repeated *) -type 'a t = 'a or_null or_null - -[%%expect {| -error -|}] - -(* check inference around or_null *) -type 'a t = 'a or_null -type ('a : immediate) t = 'a or_null - -[%%expect {| -success -success (inferring an immediate jkind for [t] and non_null_immediate for ['a]) -|}] - -(* more jkind checking *) -type t : non_null_value = string or_null - -[%%expect {| -error -|}] - -type t1 : non_null_value = string -type t2 : non_null_value = int -type t3 : non_null_immediate = int -type t4 : value = int or_null - -[%%expect {| -success -|}] - -(* magic looking-through of [or_null] can't be abstracted over *) -type 'a t = 'a or_null -type q1 : value = string t -type q2 : immediate = int t (* but t isn't abstract, so this is OK *) - -[%%expect {| -success -|}] - -type q = string t t - -[%%expect {| -error -|}] - -type q = int t t - -[%%expect {| -error -|}] - -type 'a q1 = 'a t -type ('a : immediate) q2 : immediate = 'a t - -[%%expect {| -success -|}] - -module type T = sig - type t -end - -[%%expect {| -success -|}] - -(* this should be rejected, because the default for [t] is [non_null_value] *) -module M : T = struct - type t = string or_null -end - -[%%expect {| -error -|}] - -module M : T = struct - type t = int or_null -end - -[%%expect {| -error -|}] - -module M : sig - type 'a t -end = struct - type 'a t = 'a or_null -end - -(* CR layouts (v3): This error message had better be excellent, because the - solution -- to add a [: value] annotation -- will be unusual. Normally, - people think of [value] as the default! *) -[%%expect {| -error -|}] - -module M : sig - type 'a t : value -end = struct - type 'a t = 'a or_null -end - -[%%expect {| -success -|}] - -type t = string M.t - -[%%expect {| -success -|}] - -type t = int M.t - -[%%expect {| -success -|}] - -type t = (int M.t : immediate) (* this is the one that requires "looking through" *) - -[%%expect {| -error -|}] - -(* tests that or_null actually works at runtime *) - -let x = match Or_null.some 5 with - | None -> 6 - | Some n -> n - -let x = match Or_null.Some 5 with - | None -> 6 - | Some n -> n - -let x = match Or_null.some "hello" with - | None -> "bad" - | Some s -> s - -let x = match Or_null.Some "hello" with - | None -> "bad" - | Some s -> s - -let x = match Or_null.none with - | None -> 6 - | Some s -> s - -let x = match Or_null.None with - | None -> 6 - | Some s -> s - -let x = match Or_null.none with - | None -> "good" - | Some s -> s - -let x = match Or_null.None with - | None -> "good" - | Some s -> s - -[%%expect {| -5 -5 -"hello" -"hello" -6 -6 -"good" -"good" -|}] - -let b = Or_null.some 0 = Obj.magic 0 - -(* this should work because they're immediate, though it's technically unspecified *) -let b = Or_null.some 0 == Obj.magic 0 - -let b = (Or_null.none : int or_null) = Obj.magic 0 - -let b = (Or_null.none : string or_null) = Obj.magic 0 - -let b = (Or_null.none : int or_null) = Obj.magic (Or_null.none : string or_null) - -[%%expect {| -true -true -false -false -true -|}] - -(* CR layouts (v3): make other reference-implementation tests for the - [Or_null] interface once we have the quickcheck-like architecture - (TANDC-1809). *) - -(* check allocation behavior *) - -let measure_alloc f = - (* NB: right-to-left evaluation order gets this right *) - let baseline_allocation = Gc.allocated_bytes() -. Gc.allocated_bytes() in - let before = Gc.allocated_bytes () in - let result = (f[@inlined never]) () in - let after = Gc.allocated_bytes () in - (after -. before) -. baseline_allocation, result - -[%%expect {| -success -|}] - -let alloc = measure_alloc (fun () -> let x = Or_null.some 5 in ()) -let alloc = measure_alloc (fun () -> let x = Or_null.Some 5 in ()) -let alloc = - measure_alloc (fun () -> - (* this should infer f to be local, and thus the closures at usage - sites won't allocate *) - let bind opt f = Or_null.(match opt with - None -> None - Some x -> f x - ) in - let x = Or_null.some 5 in - let y = Or_null.some 6 in - let f a b = bind x (fun x -> bind y Or_null.(fun y -> some (x + y))) in - f x y) - -[%%expect {| -0 -0 -0 -|}] - -(* sub-typing *) - -let f x = (x : int :> int or_null) -let f x = (x : string :> string or_null) -let f x = (x : int list :> int or_null list) -let f x = (x : string list :> string or_null list) -let f x = (x : int list :> int list or_null) -let f x = (x : string list :> string list or_null) - -[%%expect {| -success -|}] - -let f x = (x : int or_null :> int) - -[%%expect {| -error -|}] - -let f x = (x : string or_null :> string) - -[%%expect {| -error -|}] - -let f x = (x : int :> int or_null or_null) - -[%%expect {| -error -|}] - -let f x = (x : int :> string or_null) - -[%%expect {| -error -|}] diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml index f9957b277e8..bdbc9f5978f 100644 --- a/testsuite/tests/typing-local/local.ml +++ b/testsuite/tests/typing-local/local.ml @@ -1202,6 +1202,53 @@ Line 3, characters 12-15: Error: This value escapes its region. |}] +(* Unboxed records version of the same test *) + +type 'a gbl = #{ global_ gbl : 'a } +[%%expect{| +type 'a gbl = #{ global_ gbl : 'a; } +|}] + +let foo (local_ x) = x.#gbl +[%%expect{| +val foo : local_ 'a gbl -> 'a = +|}] +let foo y = + let x = local_ #{ gbl = y } in + x.#gbl +[%%expect{| +val foo : 'a -> 'a = +|}] +let foo (local_ #{ gbl }) = gbl +[%%expect{| +val foo : local_ 'a gbl -> 'a = +|}] +let foo y = + let #{ gbl } = local_ #{ gbl = y } in + gbl +[%%expect{| +val foo : 'a -> 'a = +|}] +let foo (local_ gbl) = + let _ = #{ gbl } in + () +[%%expect{| +Line 2, characters 13-16: +2 | let _ = #{ gbl } in + ^^^ +Error: This value escapes its region. +|}] +let foo () = + let gbl = local_ ref 5 in + let _ = #{ gbl } in + () +[%%expect{| +Line 3, characters 13-16: +3 | let _ = #{ gbl } in + ^^^ +Error: This value escapes its region. +|}] + (* Global fields are preserved in module inclusion *) module M : sig type t = { global_ foo : string } @@ -1255,6 +1302,60 @@ Error: Signature mismatch: The first is global_ and the second is not. |}] +(* Unboxed records version of the same test *) + +module M : sig + type t = #{ global_ foo : string } +end = struct + type t = #{ foo : string } +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ foo : string } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = #{ foo : string; } end + is not included in + sig type t = #{ global_ foo : string; } end + Type declarations do not match: + type t = #{ foo : string; } + is not included in + type t = #{ global_ foo : string; } + Fields do not match: + "foo : string;" + is not the same as: + "global_ foo : string;" + The second is global_ and the first is not. +|}] + +module M : sig + type t = #{ foo : string } +end = struct + type t = #{ global_ foo : string } +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ global_ foo : string } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = #{ global_ foo : string; } end + is not included in + sig type t = #{ foo : string; } end + Type declarations do not match: + type t = #{ global_ foo : string; } + is not included in + type t = #{ foo : string; } + Fields do not match: + "global_ foo : string;" + is not the same as: + "foo : string;" + The first is global_ and the second is not. +|}] + (* Special handling of tuples in matches and let bindings *) let escape : 'a -> unit = fun x -> () diff --git a/testsuite/tests/typing-modes/lazy.ml b/testsuite/tests/typing-modes/lazy.ml index 1802de84380..fd834b214e5 100644 --- a/testsuite/tests/typing-modes/lazy.ml +++ b/testsuite/tests/typing-modes/lazy.ml @@ -43,8 +43,7 @@ let foo (x @ local) = val foo : local_ 'a lazy_t -> 'a = |}] -(* one can construct portable lazy, if both the thunk and the result are - portable *) +(* one can construct [portable] lazy only if the result is [portable] *) let foo () = let l = lazy (let x @ nonportable = fun x -> x in x) in use_portable l @@ -55,32 +54,21 @@ Line 3, characters 17-18: Error: This value is "nonportable" but expected to be "portable". |}] +(* thunk is evaluated only when [uncontended] lazy is forced, so the thunk can be + [nonportable] even if the lazy is [portable]. *) let foo (x @ nonportable) = let l = lazy (let _ = x in ()) in use_portable l [%%expect{| -Line 3, characters 17-18: -3 | use_portable l - ^ -Error: This value is "nonportable" but expected to be "portable". -|}] - -let foo (x @ portable) = - let l = lazy (let _ = x in let y = fun () -> () in y) in - use_portable l -[%%expect{| -val foo : 'a @ portable -> unit = +val foo : 'a -> unit = |}] -(* inside a portable lazy, things are available as contended *) +(* For the same reason, [portable] lazy can close over things at [uncontended]. *) let foo (x @ uncontended) = - let l @ portable = lazy ( let x' @ uncontended = x in ()) in + let l @ portable = lazy ( let _x @ uncontended = x in ()) in use_portable l [%%expect{| -Line 2, characters 53-54: -2 | let l @ portable = lazy ( let x' @ uncontended = x in ()) in - ^ -Error: This value is "contended" but expected to be "uncontended". +val foo : 'a -> unit = |}] (* Portable lazy gives portable result *) @@ -91,6 +79,7 @@ let foo (x @ portable) = val foo : 'a lazy_t @ portable -> unit = |}] +(* Nonportable lazy gives nonportable result *) let foo (x @ nonportable) = match x with | lazy r -> use_portable x diff --git a/testsuite/tests/typing-modes/module.ml b/testsuite/tests/typing-modes/module.ml index 9dc270a43da..eb9309fd966 100644 --- a/testsuite/tests/typing-modes/module.ml +++ b/testsuite/tests/typing-modes/module.ml @@ -1,4 +1,5 @@ (* TEST + flags+="-extension mode_alpha"; expect; *) @@ -24,7 +25,7 @@ end val portable_use : 'a @ portable -> unit = module type S = sig val x : 'a -> unit end module type SL = sig type 'a t end -module M : sig type 'a t = int val x : 'a -> unit end +module M : sig type 'a t = int val x : 'a -> unit @@ portable end module F : functor (X : S) -> sig type t = int val x : 'a -> unit end |}] @@ -180,3 +181,82 @@ val foo : unit -> unit = |}] (* Pmty_alias is not testable *) + +(* module alias *) +module type S = sig + val foo : 'a -> 'a + val baz : 'a -> 'a @@ portable +end + +module M : S = struct + let foo = fun x -> x + let baz = fun x -> x +end +[%%expect{| +module type S = sig val foo : 'a -> 'a val baz : 'a -> 'a @@ portable end +module M : S +|}] + +let (bar @ portable) () = + let module N = M in + M.baz (); + N.baz () +[%%expect{| +val bar : unit -> unit = +|}] + +let (bar @ portable) () = + let module N = M in + N.foo () +[%%expect{| +Line 3, characters 4-9: +3 | N.foo () + ^^^^^ +Error: The value "N.foo" is nonportable, so cannot be used inside a function that is portable. +|}] + +let (bar @ portable) () = + let module N = M in + M.foo () +[%%expect{| +Line 3, characters 4-9: +3 | M.foo () + ^^^^^ +Error: The value "M.foo" is nonportable, so cannot be used inside a function that is portable. +|}] + +(* chained aliases. Creating alias of alias is fine. *) +let (bar @ portable) () = + let module N = M in + let module N' = N in + M.baz (); + N.baz (); + N'.baz () +[%%expect{| +val bar : unit -> unit = +|}] + +(* locks are accumulated and not lost *) +let (bar @ portable) () = + let module N = M in + let module N' = N in + N'.foo () +[%%expect{| +Line 4, characters 4-10: +4 | N'.foo () + ^^^^^^ +Error: The value "N'.foo" is nonportable, so cannot be used inside a function that is portable. +|}] + +(* module aliases in structures still walk locks. *) +let (bar @ portable) () = + let module N = struct + module L = M + end in + N.L.foo () +[%%expect{| +Line 3, characters 19-20: +3 | module L = M + ^ +Error: Modules are nonportable, so cannot be used inside a function that is portable. +|}] diff --git a/testsuite/tests/typing-modes/val_modalities.ml b/testsuite/tests/typing-modes/val_modalities.ml index e105ca35d73..a1cd08d4ffb 100644 --- a/testsuite/tests/typing-modes/val_modalities.ml +++ b/testsuite/tests/typing-modes/val_modalities.ml @@ -67,24 +67,23 @@ module M : sig val x : string @@ portable contended end (* Testing the defaulting behaviour. "module type of" triggers the defaulting logic. - Note that the defaulting will mutate the original module type. -*) + Note that the defaulting will mutate the original module type: it zaps the + inferred modalities and make them fully fixed. *) module Module_type_of_comonadic = struct module M = struct let x @ portable = fun x -> x end (* for comonadic axes, we default to id = meet_with_max, which is the - weakest. The original modality is not mutated. *) + weakest. *) module M' : module type of M = struct let x @ portable = fun x -> x end - let _ = portable_use M.x (* The original modality stays portable *) - let _ = portable_use M'.x + let _ = portable_use M.x (* The original inferred modality is zapped *) end [%%expect{| -Line 11, characters 25-29: -11 | let _ = portable_use M'.x - ^^^^ +Line 10, characters 25-28: +10 | let _ = portable_use M.x (* The original inferred modality is zapped *) + ^^^ Error: This value is "nonportable" but expected to be "portable". |}] @@ -901,3 +900,64 @@ let () = () [%%expect{| |}] + +(* CR zqian: finer treatment of packing and unpacking *) +module type Empty = sig end + +module type S = sig + val foo : 'a -> 'a + val baz : 'a -> 'a @@ portable +end + +module M : S = struct + let foo = fun x -> x + let baz = fun x -> x +end +[%%expect{| +module type Empty = sig end +module type S = sig val foo : 'a -> 'a val baz : 'a -> 'a @@ portable end +module M : S +|}] + +let (bar @ portable) () = + let m = (module M : Empty) in + () +[%%expect{| +Line 2, characters 20-21: +2 | let m = (module M : Empty) in + ^ +Error: Modules are nonportable, so cannot be used inside a function that is portable. +|}] + +let m = (module M : S) +[%%expect{| +val m : (module S) = +|}] + +let (bar @ portable) () = + let module M' = (val m : Empty) in + () +[%%expect{| +Line 2, characters 25-26: +2 | let module M' = (val m : Empty) in + ^ +Error: The value "m" is nonportable, so cannot be used inside a function that is portable. +|}] + +(* CR zqian: this mode crossing should work *) +module M : sig + val x : int +end = struct + let x = 42 +end + +let (foo @ portable) () = + let _ = M.x in + () +[%%expect{| +module M : sig val x : int end +Line 8, characters 10-13: +8 | let _ = M.x in + ^^^ +Error: The value "M.x" is nonportable, so cannot be used inside a function that is portable. +|}] diff --git a/testsuite/tests/typing-modes/yielding.ml b/testsuite/tests/typing-modes/yielding.ml new file mode 100644 index 00000000000..e472f807124 --- /dev/null +++ b/testsuite/tests/typing-modes/yielding.ml @@ -0,0 +1,80 @@ +(* TEST + expect; +*) + +(* CR dkalinichenko: allow [yielding] at toplevel? *) +let my_effect : unit -> unit @@ yielding = print_endline "Hello, world!" +[%%expect{| +Line 1, characters 4-72: +1 | let my_effect : unit -> unit @@ yielding = print_endline "Hello, world!" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This value is "yielding" but expected to be "unyielding". +|}] + +let storage = ref "" + +let with_effect : ((string -> unit) @ local yielding -> 'a) -> 'a = + fun f -> f ((:=) storage) + +[%%expect{| +val storage : string ref = {contents = ""} +val with_effect : (local_ (string -> unit) @ yielding -> 'a) -> 'a = +|}] + +let () = with_effect (fun k -> k "Hello, world!") + +let _ = !storage + +[%%expect{| +- : string = "Hello, world!" +|}] + +let run_yielding : (string -> unit) @ local yielding -> unit = fun f -> f "my string" + +let () = with_effect (fun k -> run_yielding k) + +let _ = !storage + +[%%expect{| +val run_yielding : local_ (string -> unit) @ yielding -> unit = +- : string = "my string" +|}] + +let run_unyielding : (string -> unit) @ local unyielding -> unit = fun f -> f "another string" + +let () = with_effect (fun k -> run_unyielding k) + +[%%expect{| +val run_unyielding : local_ (string -> unit) -> unit = +Line 3, characters 46-47: +3 | let () = with_effect (fun k -> run_unyielding k) + ^ +Error: This value is "yielding" but expected to be "unyielding". +|}] + +(* CR dkalinichenko: default [local] arguments to [yielding]. *) + +let run_default : (string -> unit) @ local -> unit = fun f -> f "some string" + +let () = with_effect (fun k -> run_default k) + +[%%expect{| +val run_default : local_ (string -> unit) -> unit = +Line 3, characters 43-44: +3 | let () = with_effect (fun k -> run_default k) + ^ +Error: This value is "yielding" but expected to be "unyielding". +|}] + +(* A closure over a [yielding] value must be [yielding]. *) + +let () = with_effect (fun k -> + let closure @ local unyielding = fun () -> k () in + run_unyielding k) + +[%%expect{| +Line 2, characters 45-46: +2 | let closure @ local unyielding = fun () -> k () in + ^ +Error: The value "k" is yielding, so cannot be used inside a function that may not yield. +|}] diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml index 9825f4fdfc3..eaa02e604e6 100644 --- a/testsuite/tests/typing-unboxed-types/test.ml +++ b/testsuite/tests/typing-unboxed-types/test.ml @@ -34,6 +34,19 @@ Obj.repr x == Obj.repr x.f - : bool = true |}];; +(* For unboxed records *) +type t2 = #{ f : string } ;; +[%%expect{| +type t2 = #{ f : string; } +|}];; + +let x = #{ f = "foo" } in +Obj.repr x == Obj.repr x.#f +;; +[%%expect{| +- : bool = true +|}];; + (* For inline records *) type t3 = B of { g : string } [@@ocaml.unboxed];; [%%expect{| @@ -95,17 +108,24 @@ Error: This type cannot be unboxed because its constructor has more than one field. |}];; -(* let rec must be rejected *) +(* This test was made to error by disallowing singleton recursive unboxed types. + We keep it in case these are re-allowed, in which case it should error with: + [This kind of expression is not allowed as right-hand side of "let rec"] *) type t10 : value = A of t10 [@@ocaml.unboxed];; [%%expect{| -type t10 = A of t10 [@@unboxed] +Line 1, characters 0-45: +1 | type t10 : value = A of t10 [@@ocaml.unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t10" is recursive without boxing: + "t10" contains "t10" |}];; let rec x = A x;; [%%expect{| -Line 1, characters 12-15: +Line 1, characters 14-15: 1 | let rec x = A x;; - ^^^ -Error: This kind of expression is not allowed as right-hand side of "let rec" + ^ +Error: This expression has type "t1" but an expression was expected of type + "string" |}];; (* Representation mismatch between module and signature must be rejected *) @@ -271,6 +291,50 @@ Error: Signature mismatch: the second declaration uses unboxed representation. |}];; +module M : sig + type t = { a : string } +end = struct + type t = #{ a : string } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = #{ a : string } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = #{ a : string; } end + is not included in + sig type t = { a : string; } end + Type declarations do not match: + type t = #{ a : string; } + is not included in + type t = { a : string; } + The first is an unboxed record, but the second is a record. +|}];; + +module M : sig + type t = #{ a : string } +end = struct + type t = { a : string } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = { a : string } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = { a : string; } end + is not included in + sig type t = #{ a : string; } end + Type declarations do not match: + type t = { a : string; } + is not included in + type t = #{ a : string; } + The first is a record, but the second is an unboxed record. +|}] + (* Check interference with representation of float arrays. *) type t11 = L of float [@@ocaml.unboxed];; @@ -284,20 +348,62 @@ in assert (f x = L 3.14);; - : unit = () |}];; -(* Check for a potential infinite loop in the typing algorithm. *) +type t11 = #{ f : float };; +[%%expect{| +type t11 = #{ f : float; } +|}];; +let x = Array.make 10 #{ f = 3.14 } (* represented as a flat array *) +and f (a : t11 array) = a.(0) (* might wrongly assume an array of pointers *) +in assert (f x = #{ f = 3.14});; +[%%expect{| +- : unit = () +|}];; + +(* Check for a potential infinite loop in the typing algorithm. + (This test was made to error upon disallowing singleton recursive [@@unboxed] + types. We keep it around in case these are re-allowed.) *) type 'a t12 = M of 'a t12 [@@ocaml.unboxed];; [%%expect{| -type 'a t12 = M of 'a t12 [@@unboxed] +Line 1, characters 0-43: +1 | type 'a t12 = M of 'a t12 [@@ocaml.unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t12" is recursive without boxing: + "'a t12" contains "'a t12" +|}];; +let f (a : int t12 array) = a.(0);; +[%%expect{| +Line 1, characters 15-18: +1 | let f (a : int t12 array) = a.(0);; + ^^^ +Error: Unbound type constructor "t12" +Hint: Did you mean "t1", "t11" or "t2"? +|}];; + +type 'a t12 : value = #{ a : 'a t12 };; +[%%expect{| +Line 1, characters 0-37: +1 | type 'a t12 : value = #{ a : 'a t12 };; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "t12" is recursive without boxing: + "'a t12" contains "'a t12" |}];; let f (a : int t12 array) = a.(0);; [%%expect{| -val f : int t12 array -> int t12 = +Line 1, characters 15-18: +1 | let f (a : int t12 array) = a.(0);; + ^^^ +Error: Unbound type constructor "t12" +Hint: Did you mean "t1", "t11" or "t2"? |}];; (* Check for another possible loop *) type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];; [%%expect{| -type t13 = A : 'a t12 -> t13 [@@unboxed] +Line 1, characters 17-20: +1 | type t13 = A : _ t12 -> t13 [@@ocaml.unboxed];; + ^^^ +Error: Unbound type constructor "t12" +Hint: Did you mean "t1", "t11", "t13" or "t2"? |}];; @@ -308,6 +414,12 @@ type t15 = A of t14 [@@ocaml.unboxed];; type t14 type t15 = A of t14 [@@unboxed] |}];; +type t14;; +type t15 = #{ a : t14 };; +[%%expect{| +type t14 +type t15 = #{ a : t14; } +|}];; (* should fail because the compiler knows that t is actually float and optimizes the record's representation *) @@ -337,6 +449,32 @@ Error: Signature mismatch: the first declaration uses unboxed float representation. |}];; +module S : sig + type t + type u = { f1 : t; f2 : t } +end = struct + type t = #{ a : float } + type u = { f1 : t; f2 : t } +end;; +[%%expect{| +Lines 4-7, characters 6-3: +4 | ......struct +5 | type t = #{ a : float } +6 | type u = { f1 : t; f2 : t } +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = #{ a : float; } type u = { f1 : t; f2 : t; } end + is not included in + sig type t type u = { f1 : t; f2 : t; } end + Type declarations do not match: + type u = { f1 : t; f2 : t; } + is not included in + type u = { f1 : t; f2 : t; } + Their internal representations differ: + the first declaration uses unboxed float representation. +|}];; + (* implementing [@@immediate] with [@@ocaml.unboxed]: this works because the representation of [t] is [int] *) @@ -349,6 +487,15 @@ end;; module T : sig type t : immediate end |}];; +module T : sig + type t [@@immediate] +end = struct + type t = #{ i : int } +end;; +[%%expect{| +module T : sig type t : immediate end +|}];; + (* Another corner case *) type 'a s type ('a, 'p) t = private 'a s @@ -372,6 +519,18 @@ val g : f array = val h : f = {field = []} |}];; +type f = #{field: 'a. 'a list} ;; +let g = Array.make 10 #{ field=[] };; +let h = g.(5);; +[%%expect{| +type f = #{ field : 'a. 'a list; } +val g : f array = + [|#{field = []}; #{field = []}; #{field = []}; #{field = []}; + #{field = []}; #{field = []}; #{field = []}; #{field = []}; + #{field = []}; #{field = []}|] +val h : f = #{field = []} +|}];; + (* Using [@@immediate] information (GPR#1469) *) type 'a t [@@immediate];; type u = U : 'a t -> u [@@unboxed];; diff --git a/testsuite/tests/typing-unboxed/test.ml b/testsuite/tests/typing-unboxed/test.ml index 4c5287e1ab0..ee4da937b43 100644 --- a/testsuite/tests/typing-unboxed/test.ml +++ b/testsuite/tests/typing-unboxed/test.ml @@ -756,7 +756,11 @@ Error: The native code version of the primitive is mandatory (* PR#7424 *) type 'a b = B of 'a b b [@@unboxed];; [%%expect{| -type 'a b = B of 'a b b [@@unboxed] +Line 1, characters 0-35: +1 | type 'a b = B of 'a b b [@@unboxed];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of "b" is recursive without boxing: + "'a b" contains "'a b b" |}] diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index edfe3fe8458..843ec3355ff 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -124,8 +124,12 @@ let rec print_struct_const = function let same_custom x y = Nativeint.equal (Obj.raw_field x 0) (Obj.raw_field (Obj.repr y) 0) +external is_null : Obj.t -> bool = "%is_null" + let rec print_obj x = - if Obj.is_block x then begin + if is_null x then + printf "null" + else if Obj.is_block x then begin let tag = Obj.tag x in if tag = Obj.string_tag then printf "%S" (Obj.magic x : string) diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index d0227ef029b..10383768c1f 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -75,6 +75,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct type t = O.t + external is_null : O.t -> bool = "%is_null" + + (* Normally, [Obj.is_block] can't be called on [value_or_null]s. + But here we need to handle nullable values at toplevel. *) + let is_real_block o = O.is_block o && not (is_null o) + module ObjTbl = Hashtbl.Make(struct type t = O.t let equal = (==) @@ -94,7 +100,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let list = ref [] in for i = start_offset to O.size obj - 1 do let arg = O.field obj i in - if not (O.is_block arg) then + if is_null arg then + list := Oval_constr (Oide_ident (Out_name.create ""), []) :: !list + else if not (O.is_block arg) then list := Oval_int (O.obj arg : int) :: !list (* Note: this could be a char or a constant constructor... *) else if O.tag arg = Obj.string_tag then @@ -268,7 +276,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let nested_values = ObjTbl.create 8 in let nest_gen err f depth obj ty = let repr = obj in - if not (O.is_block repr) then + if not (is_real_block repr) then f depth obj ty else if ObjTbl.mem nested_values repr then @@ -302,14 +310,14 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct (tree_of_labeled_val_list 0 depth obj labeled_tys) | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> - if O.is_block obj then + if is_real_block obj then match check_depth depth obj ty with Some x -> x | None -> let rec tree_of_conses tree_list depth obj ty_arg = if !printer_steps < 0 || depth < 0 then Oval_ellipsis :: tree_list - else if O.is_block obj then + else if is_real_block obj then let tree = nest tree_of_val (depth - 1) (O.field obj 0) ty_arg in @@ -421,19 +429,32 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct ~loc:Location.none Positive path env in let constant, tag = - if O.is_block obj - then false, O.tag obj - else true, O.obj obj - in - let {cstr_uid} = - Datarepr.find_constr_by_tag ~constant tag cstrs + (* CR dkalinichenko: the null case being represented + by [-1] is hacky, but there's no simple fix. *) + if is_null obj then + true, -1 + else if O.is_block obj then + false, O.tag obj + else + true, O.obj obj in let {cd_id;cd_args;cd_res} = try + (* CR dkalinichenko: this is broken for unboxed variants: + unless the tag of the inner value just happens to be 0, + [Datarepr.find_constr_by_tag] will fail. *) + let {cstr_uid} = + Datarepr.find_constr_by_tag ~constant tag cstrs + in List.find (fun {cd_uid} -> Uid.equal cd_uid cstr_uid) constr_list with - | Not_found -> raise Datarepr.Constr_not_found + | Datarepr.Constr_not_found | Not_found -> + (* If a [Variant_with_null] is not a [Null], + it's guaranteed to be [This value]. *) + match rep with + | Variant_with_null -> List.nth constr_list 1 + | _ -> raise Datarepr.Constr_not_found in let type_params = match cd_res with @@ -447,11 +468,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let unbx = match rep with | Variant_unboxed -> true + | Variant_with_null when tag = -1 -> false + | Variant_with_null -> true | Variant_boxed _ | Variant_extensible -> false - | Variant_with_null -> - (* CR layouts v3.0: fix this. *) - Misc.fatal_error "[Variant_with_null] not implemented\ - in bytecode" in begin match cd_args with diff --git a/typing/ctype.ml b/typing/ctype.ml index 8ac146ae94d..547b8f2d62c 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2116,6 +2116,20 @@ let unbox_once env ty = | Tpoly (ty, _) -> Stepped ty | _ -> Final_result +let contained_without_boxing env ty = + match get_desc ty with + | Tconstr _ -> + begin match unbox_once env ty with + | Stepped ty -> [ty] + | Stepped_record_unboxed_product tys -> tys + | Final_result | Missing _ -> [] + end + | Tunboxed_tuple labeled_tys -> + List.map snd labeled_tys + | Tpoly (ty, _) -> [ty] + | Tvar _ | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil | Tlink _ + | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ -> [] + (* We use ty_prev to track the last type for which we found a definition, allowing us to return a type for which a definition was found even if we eventually bottom out at a missing cmi file, or otherwise. *) diff --git a/typing/ctype.mli b/typing/ctype.mli index 6caadd85790..a5d3460cdd8 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -581,6 +581,10 @@ val get_unboxed_type_approximation : Env.t -> type_expr -> type_expr [get_unboxed_type_representation], but doesn't indicate whether the type was fully expanded or not. *) +val contained_without_boxing : Env.t -> type_expr -> type_expr list + (* Return all types that are directly contained without boxing + (or "without indirection" or "flatly") *) + (* Given the row from a variant type, determine if it is immediate. Currently just checks that all constructors have no arguments, doesn't consider void. *) diff --git a/typing/datarepr.ml b/typing/datarepr.ml index c83d8aea3d9..8ee479d833e 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -283,7 +283,8 @@ let find_constr ~constant tag cstrs = (function | ({cstr_tag=Ordinary {runtime_tag=tag'}; cstr_constant},_) -> tag' = tag && cstr_constant = constant - | ({cstr_tag=(Extension _ | Null)},_) -> false) + | ({cstr_tag=Null; cstr_constant}, _) -> tag = -1 && cstr_constant = constant + | ({cstr_tag=Extension _},_) -> false) cstrs with | Not_found -> raise Constr_not_found diff --git a/typing/env.ml b/typing/env.ml index ac7dba4540f..05afafe143b 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -339,6 +339,12 @@ type lock = | Exclave_lock | Unboxed_lock (* to prevent capture of terms with non-value types *) +type locks = lock list + +let locks_empty = [] + +let locks_is_empty l = l = locks_empty + type lock_item = | Value | Module @@ -719,8 +725,14 @@ and module_data = mda_address : address_lazy; mda_shape: Shape.t; } +and module_alias_locks = locks + (** If the module is an alias for another module, this is the list of locks + from the original module to this module. This is accumulative: write + [module B = A;; module C = B;;], then [C] will record all locks from [A] + to [C]. Empty if not an alias. *) + and module_entry = - | Mod_local of module_data + | Mod_local of module_data * module_alias_locks | Mod_persistent | Mod_unbound of module_unbound_reason @@ -936,7 +948,7 @@ let diff env1 env2 = (* Functions for use in "wrap" parameters in IdTbl *) let wrap_identity x = x let wrap_value vda = Val_bound vda -let wrap_module mda = Mod_local mda +let wrap_module mda = Mod_local (mda, locks_empty) (* Forward declarations *) @@ -1239,7 +1251,7 @@ let check_functor_appl let find_ident_module id env = match find_same_module id env.modules with - | Mod_local data -> data + | Mod_local (data, _) -> data | Mod_unbound _ -> raise Not_found | Mod_persistent -> match Ident.to_global id with @@ -1529,7 +1541,7 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id = end | Module -> begin match IdTbl.find_same_without_locks id env.modules with - | Mod_local { mda_shape; _ } -> mda_shape + | Mod_local ({ mda_shape; _ }, _) -> mda_shape | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) | Mod_unbound _ -> (* Only present temporarily while approximating the environment for @@ -1765,7 +1777,7 @@ let iter_env wrap proj1 proj2 f env () = (fun id (path, entry) -> match entry with | Mod_unbound _ -> () - | Mod_local data -> + | Mod_local (data, _) -> iter_components (Pident id) path data.mda_components | Mod_persistent -> ()) env.modules; @@ -1811,7 +1823,7 @@ let rec find_shadowed_comps path env = List.filter_map (fun (p, data) -> match data with - | Mod_local x -> Some (p, x) + | Mod_local (x, _) -> Some (p, x) | Mod_unbound _ | Mod_persistent -> None) (IdTbl.find_all wrap_module (Ident.name id) env.modules) | Pdot (p, s) -> @@ -2077,7 +2089,7 @@ let rec components_of_module_maker NameMap.add (Ident.name id) mda c.comp_modules; env := store_module ~update_summary:false ~check:None - id addr pres md shape !env + id addr pres md shape locks_empty !env | Sig_modtype(id, decl, _) -> let final_decl = (* The prefixed items get the same scope as [cm_path], which is @@ -2352,7 +2364,7 @@ and store_extension ~check ~rebind id addr ext shape env = summary = Env_extension(env.summary, id, ext) } and store_module ?(update_summary=true) ~check - id addr presence md shape env = + id addr presence md shape alias_locks env = let open Subst.Lazy in let loc = md.md_loc in Option.iter @@ -2373,7 +2385,7 @@ and store_module ?(update_summary=true) ~check if not update_summary then env.summary else Env_module (env.summary, id, presence, force_module_decl md) in { env with - modules = IdTbl.add id (Mod_local mda) env.modules; + modules = IdTbl.add id (Mod_local (mda, alias_locks)) env.modules; summary } and store_modtype ?(update_summary=true) id info shape env = @@ -2466,7 +2478,7 @@ and add_extension ~check ?shape ~rebind id ext env = store_extension ~check ~rebind id addr ext shape env and add_module_declaration_lazy - ~update_summary ?(arg=false) ?shape ~check id presence md env = + ~update_summary ?(arg=false) ?shape ~check id presence md ?(locks = []) env = let check = if not check then None @@ -2478,13 +2490,13 @@ and add_module_declaration_lazy let addr = module_declaration_address env id presence md in let shape = shape_or_leaf md.Subst.Lazy.md_uid shape in let env = - store_module ~update_summary ~check id addr presence md shape env + store_module ~update_summary ~check id addr presence md shape locks env in if arg then add_functor_arg id env else env -let add_module_declaration ?(arg=false) ?shape ~check id presence md env = +let add_module_declaration ?(arg=false) ?shape ~check id presence md ?locks env = add_module_declaration_lazy ~update_summary:true ~arg ?shape ~check id - presence (Subst.Lazy.of_module_decl md) env + presence (Subst.Lazy.of_module_decl md) ?locks env and add_modtype_lazy ~update_summary ?shape id info env = let shape = shape_or_leaf info.Subst.Lazy.mtd_uid shape in @@ -2543,9 +2555,9 @@ let enter_extension ~scope ~rebind name ext env = let env = store_extension ~check:true ~rebind id addr ext shape env in (id, env) -let enter_module_declaration ~scope ?arg ?shape s presence md env = +let enter_module_declaration ~scope ?arg ?shape s presence md ?locks env = let id = Ident.create_scoped ~scope s in - (id, add_module_declaration ?arg ?shape ~check:true id presence md env) + (id, add_module_declaration ?arg ?shape ~check:true id presence md ?locks env) let enter_modtype ~scope name mtd env = let id = Ident.create_scoped ~scope name in @@ -2608,7 +2620,8 @@ module Add_signature(T : Types.Wrapped)(M : sig val add_value: ?shape:Shape.t -> mode:(Mode.allowed * 'r0) Mode.Value.t -> Ident.t -> T.value_description -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool - -> Ident.t -> module_presence -> T.module_declaration -> t -> t + -> Ident.t -> module_presence -> T.module_declaration -> ?locks:locks -> + t -> t val add_modtype: ?shape:Shape.t -> Ident.t -> T.modtype_declaration -> t -> t end) = struct open T @@ -2688,7 +2701,7 @@ let add_cltype = add_cltype ?shape:None let add_modtype_lazy = add_modtype_lazy ?shape:None let add_modtype = add_modtype ?shape:None let add_module_declaration_lazy ?(arg=false) = - add_module_declaration_lazy ~arg ?shape:None ~check:false + add_module_declaration_lazy ~arg ?shape:None ~check:false ?locks:None let add_signature sg env = let _, env = add_signature Shape.Map.empty None sg env in env @@ -3002,8 +3015,9 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = may_lookup_error errors loc env (Unbound_module (Lident s)) in match data with - | Mod_local mda -> begin + | Mod_local (mda, alias_locks) -> begin use_module ~use ~loc path mda; + let locks = alias_locks @ locks in match load with | Load -> path, locks, (mda : a) | Don't_load -> path, locks, (() : a) @@ -3568,37 +3582,27 @@ let open_signature (* General forms of the lookup functions *) -let walk_locks_for_module_lookup ~errors ~lock ~loc ~env ~lid locks = - if lock then - walk_locks ~errors ~loc ~env ~item:Module ~lid mda_mode None locks - else - mode_default mda_mode - -let lookup_module_path ~errors ~use ~lock ~loc ~load lid env : Path.t * _ = - let path, locks = - match lid with - | Lident s -> - if !Clflags.transparent_modules && not load then - let path, locks, _ = - lookup_ident_module Don't_load ~errors ~use ~loc s env - in - path, locks - else - let path, locks, _ = - lookup_ident_module Load ~errors ~use ~loc s env - in - path, locks - | Ldot(l, s) -> - let path, locks, _ = lookup_dot_module ~errors ~use ~loc l s env in +let lookup_module_path ~errors ~use ~loc ~load lid env = + match lid with + | Lident s -> + if !Clflags.transparent_modules && not load then + let path, locks, () = + lookup_ident_module Don't_load ~errors ~use ~loc s env + in path, locks - | Lapply _ as lid -> - let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in - Papply(path_f, path_arg), [] - in - let vmode = walk_locks_for_module_lookup ~errors ~lock ~loc ~lid ~env locks in - path, vmode + else + let path, locks, _ = + lookup_ident_module Load ~errors ~use ~loc s env + in + path, locks + | Ldot(l, s) -> + let path, locks, _ = lookup_dot_module ~errors ~use ~loc l s env in + path, locks + | Lapply _ as lid -> + let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + Papply(path_f, path_arg), [] -let lookup_module_instance_path ~errors ~use ~lock ~loc ~load name env = +let lookup_module_instance_path ~errors ~use ~loc ~load name env = (* The locks are whatever locks we would find if we went through [lookup_module_path] on a module not found in the environment *) let locks = IdTbl.get_all_locks env.modules in @@ -3614,15 +3618,7 @@ let lookup_module_instance_path ~errors ~use ~lock ~loc ~load name env = in path in - let vmode = - let lid : Longident.t = - (* This is only used for error reporting. Probably in the long term we - want [Longident.t] to include instance names *) - Lident (name |> Global_module.Name.to_string) - in - walk_locks_for_module_lookup ~errors ~lock ~loc ~lid ~env locks - in - path, vmode + path, locks let lookup_value_lazy ~errors ~use ~loc lid env = match lid with @@ -3817,17 +3813,14 @@ let find_cltype_index id env = find_index_tbl id env.cltypes (* Ordinary lookup functions *) -let lookup_module_path ?(use=true) ?(lock=use) ~loc ~load lid env = - let path, vmode = - lookup_module_path ~errors:true ~use ~lock ~loc ~load lid env - in - path, vmode.mode +let walk_locks ~loc ~env ~item ~lid mode ty locks = + walk_locks ~errors:true ~loc ~env ~item ~lid mode ty locks -let lookup_module_instance_path ?(use=true) ?(lock=use) ~loc ~load lid env = - let path, vmode = - lookup_module_instance_path ~errors:true ~use ~lock ~loc ~load lid env - in - path, vmode.mode +let lookup_module_path ?(use=true) ~loc ~load lid env = + lookup_module_path ~errors:true ~use ~loc ~load lid env + +let lookup_module_instance_path ?(use=true) ~loc ~load lid env = + lookup_module_instance_path ~errors:true ~use ~loc ~load lid env let lookup_module ?(use=true) ?(lock=use) ~loc lid env = let path, desc, vmode = lookup_module ~errors:true ~use ~lock ~loc lid env in @@ -3987,7 +3980,7 @@ let fold_modules f lid env acc = (fun name (p, entry) acc -> match entry with | Mod_unbound _ -> acc - | Mod_local mda -> + | Mod_local (mda, _) -> let md = Subst.Lazy.force_module_decl mda.mda_declaration in @@ -4419,6 +4412,7 @@ let report_lookup_error _loc env ppf = function | Error (Areality, _) -> "local", "might escape" | Error (Linearity, _) -> "once", "is many" | Error (Portability, _) -> "nonportable", "is portable" + | Error (Yielding, _) -> "yielding", "may not yield" in let s, hint = match context with diff --git a/typing/env.mli b/typing/env.mli index b1540ee1880..2cb293671aa 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -204,6 +204,12 @@ type shared_context = | Module | Probe +type locks + +val locks_empty : locks + +val locks_is_empty : locks -> bool + (** Items whose accesses are affected by locks *) type lock_item = | Value @@ -262,6 +268,13 @@ type actual_mode = { (** Explains why [mode] is high. *) } +(** Takes the [mode] and [ty] of a value at definition site, walks through the list of + locks and constrains [mode] and [ty]. Return the access mode of the value allowed by + the locks. [ty] is optional as the function works on modules and classes as well, for + which [ty] should be [None]. *) +val walk_locks : loc:Location.t -> env:t -> item:lock_item -> lid:Longident.t -> + Mode.Value.l -> type_expr option -> locks -> actual_mode + val lookup_value: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t * value_description * actual_mode @@ -281,14 +294,16 @@ val lookup_cltype: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration +(* When locks are returned instead of walked for modules, the mode remains as + defined (always legacy), and thus not returned. *) val lookup_module_path: - ?use:bool -> ?lock:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> - Path.t * Mode.Value.l + ?use:bool -> loc:Location.t -> load:bool -> Longident.t -> t -> + Path.t * locks val lookup_modtype_path: ?use:bool -> loc:Location.t -> Longident.t -> t -> Path.t val lookup_module_instance_path: - ?use:bool -> ?lock:bool -> loc:Location.t -> load:bool -> - Global_module.Name.t -> t -> Path.t * Mode.Value.l + ?use:bool -> loc:Location.t -> load:bool -> Global_module.Name.t -> t -> + Path.t * locks val lookup_constructor: ?use:bool -> loc:Location.t -> constructor_usage -> Longident.t -> t -> @@ -386,7 +401,7 @@ val add_module: ?arg:bool -> ?shape:Shape.t -> val add_module_lazy: update_summary:bool -> Ident.t -> module_presence -> Subst.Lazy.module_type -> t -> t val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> - Ident.t -> module_presence -> module_declaration -> t -> t + Ident.t -> module_presence -> module_declaration -> ?locks:locks -> t -> t val add_module_declaration_lazy: ?arg:bool -> update_summary:bool -> Ident.t -> module_presence -> Subst.Lazy.module_declaration -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t @@ -450,7 +465,7 @@ val enter_module: module_type -> t -> Ident.t * t val enter_module_declaration: scope:int -> ?arg:bool -> ?shape:Shape.t -> string -> module_presence -> - module_declaration -> t -> Ident.t * t + module_declaration -> ?locks:locks -> t -> Ident.t * t val enter_modtype: scope:int -> string -> modtype_declaration -> t -> Ident.t * t val enter_class: scope:int -> string -> class_declaration -> t -> Ident.t * t diff --git a/typing/jkind.ml b/typing/jkind.ml index 27df68f136c..7c45cd9aa9e 100644 --- a/typing/jkind.ml +++ b/typing/jkind.ml @@ -436,7 +436,8 @@ module Const = struct contention = Contention.Const.min; portability = Portability.Const.min; uniqueness = Uniqueness.Const.max; - areality = Locality.Const.max + areality = Locality.Const.max; + yielding = Yielding.Const.min }; externality_upper_bound = Externality.max; nullability_upper_bound = Nullability.Non_null @@ -452,7 +453,8 @@ module Const = struct contention = Contention.Const.max; portability = Portability.Const.min; uniqueness = Uniqueness.Const.max; - areality = Locality.Const.max + areality = Locality.Const.max; + yielding = Yielding.Const.min }; externality_upper_bound = Externality.max; nullability_upper_bound = Nullability.Non_null @@ -774,7 +776,8 @@ module Const = struct linearity = parsed_modifiers.linearity; uniqueness = parsed_modifiers.uniqueness; portability = parsed_modifiers.portability; - contention = parsed_modifiers.contention + contention = parsed_modifiers.contention; + yielding = parsed_modifiers.yielding } in { layout = base.layout; @@ -1165,7 +1168,8 @@ let for_arrow = areality = Locality.Const.max; uniqueness = Uniqueness.Const.min; portability = Portability.Const.max; - contention = Contention.Const.min + contention = Contention.Const.min; + yielding = Yielding.Const.max }; externality_upper_bound = Externality.max; nullability_upper_bound = Non_null @@ -1358,6 +1362,8 @@ module Format_history = struct "it's the layout polymorphic type in an external declaration@ \ ([@@layout_poly] forces all variables of layout 'any' to be@ \ representable at call sites)" + | Peek_or_poke -> + fprintf ppf "it's the type being used for a peek or poke primitive" let format_concrete_legacy_creation_reason ppf : History.concrete_legacy_creation_reason -> unit = function @@ -1897,6 +1903,7 @@ module Debug_printers = struct | Optional_arg_default -> fprintf ppf "Optional_arg_default" | Layout_poly_in_external -> fprintf ppf "Layout_poly_in_external" | Unboxed_tuple_element -> fprintf ppf "Unboxed_tuple_element" + | Peek_or_poke -> fprintf ppf "Peek_or_poke" let concrete_legacy_creation_reason ppf : History.concrete_legacy_creation_reason -> unit = function diff --git a/typing/jkind_axis.ml b/typing/jkind_axis.ml index b81e66ad8ba..383cc942db8 100644 --- a/typing/jkind_axis.ml +++ b/typing/jkind_axis.ml @@ -142,6 +142,7 @@ module Axis = struct | Uniqueness : Mode.Uniqueness.Const.t t | Portability : Mode.Portability.Const.t t | Contention : Mode.Contention.Const.t t + | Yielding : Mode.Yielding.Const.t t end module Nonmodal = struct @@ -180,6 +181,8 @@ module Axis = struct (module Accent_lattice (Mode.Portability.Const) : Axis_s with type t = a) | Modal Contention -> (module Accent_lattice (Mode.Contention.Const) : Axis_s with type t = a) + | Modal Yielding -> + (module Accent_lattice (Mode.Yielding.Const) : Axis_s with type t = a) | Nonmodal Externality -> (module Externality : Axis_s with type t = a) | Nonmodal Nullability -> (module Nullability : Axis_s with type t = a) @@ -189,6 +192,7 @@ module Axis = struct Pack (Modal Uniqueness); Pack (Modal Portability); Pack (Modal Contention); + Pack (Modal Yielding); Pack (Nonmodal Externality); Pack (Nonmodal Nullability) ] @@ -198,6 +202,7 @@ module Axis = struct | Modal Uniqueness -> "uniqueness" | Modal Portability -> "portability" | Modal Contention -> "contention" + | Modal Yielding -> "yielding" | Nonmodal Externality -> "externality" | Nonmodal Nullability -> "nullability" end @@ -210,6 +215,7 @@ module Axis_collection (T : Misc.T1) = struct uniqueness : Mode.Uniqueness.Const.t T.t; portability : Mode.Portability.Const.t T.t; contention : Mode.Contention.Const.t T.t; + yielding : Mode.Yielding.Const.t T.t; externality : Externality.t T.t; nullability : Nullability.t T.t } @@ -221,6 +227,7 @@ module Axis_collection (T : Misc.T1) = struct | Modal Uniqueness -> values.uniqueness | Modal Portability -> values.portability | Modal Contention -> values.contention + | Modal Yielding -> values.yielding | Nonmodal Externality -> values.externality | Nonmodal Nullability -> values.nullability @@ -231,6 +238,7 @@ module Axis_collection (T : Misc.T1) = struct | Modal Uniqueness -> { values with uniqueness = value } | Modal Portability -> { values with portability = value } | Modal Contention -> { values with contention = value } + | Modal Yielding -> { values with yielding = value } | Nonmodal Externality -> { values with externality = value } | Nonmodal Nullability -> { values with nullability = value } @@ -246,6 +254,7 @@ module Axis_collection (T : Misc.T1) = struct uniqueness = f ~axis:Axis.(Modal Uniqueness); portability = f ~axis:Axis.(Modal Portability); contention = f ~axis:Axis.(Modal Contention); + yielding = f ~axis:Axis.(Modal Yielding); externality = f ~axis:Axis.(Nonmodal Externality); nullability = f ~axis:Axis.(Nonmodal Nullability) } diff --git a/typing/jkind_axis.mli b/typing/jkind_axis.mli index c3cf2aa42af..6ee32d23316 100644 --- a/typing/jkind_axis.mli +++ b/typing/jkind_axis.mli @@ -64,6 +64,7 @@ module Axis : sig | Uniqueness : Mode.Uniqueness.Const.t t | Portability : Mode.Portability.Const.t t | Contention : Mode.Contention.Const.t t + | Yielding : Mode.Yielding.Const.t t end module Nonmodal : sig @@ -98,6 +99,7 @@ module Axis_collection (T : Misc.T1) : sig uniqueness : Mode.Uniqueness.Const.t T.t; portability : Mode.Portability.Const.t T.t; contention : Mode.Contention.Const.t T.t; + yielding : Mode.Yielding.Const.t T.t; externality : Externality.t T.t; nullability : Nullability.t T.t } diff --git a/typing/jkind_intf.ml b/typing/jkind_intf.ml index 9cc1d7765f3..aa5403d2a18 100644 --- a/typing/jkind_intf.ml +++ b/typing/jkind_intf.ml @@ -207,6 +207,7 @@ module History = struct | Optional_arg_default | Layout_poly_in_external | Unboxed_tuple_element + | Peek_or_poke (* For sort variables that are in the "legacy" position on the jkind lattice, defaulting exactly to [value]. *) diff --git a/typing/mode.ml b/typing/mode.ml index b72beee20f2..9e1b9d638c2 100644 --- a/typing/mode.ml +++ b/typing/mode.ml @@ -317,6 +317,41 @@ module Lattices = struct module Contention_op = Opposite (Contention) + module Yielding = struct + type t = + | Yielding + | Unyielding + + include Total (struct + type nonrec t = t + + let min = Unyielding + + let max = Yielding + + let legacy = Unyielding + + let le a b = + match a, b with + | Unyielding, _ | _, Yielding -> true + | Yielding, Unyielding -> false + + let join a b = + match a, b with + | Yielding, _ | _, Yielding -> Yielding + | Unyielding, Unyielding -> Unyielding + + let meet a b = + match a, b with + | Unyielding, _ | _, Unyielding -> Unyielding + | Yielding, Yielding -> Yielding + + let print ppf = function + | Yielding -> Format.fprintf ppf "yielding" + | Unyielding -> Format.fprintf ppf "unyielding" + end) + end + type monadic = Uniqueness.t * Contention.t module Monadic = struct @@ -343,37 +378,50 @@ module Lattices = struct Format.fprintf ppf "%a,%a" Uniqueness.print a0 Contention.print a1 end - type 'areality comonadic_with = 'areality * Linearity.t * Portability.t + type 'areality comonadic_with = + 'areality * Linearity.t * Portability.t * Yielding.t module Comonadic_with (Areality : Areality) = struct type t = Areality.t comonadic_with - let min = Areality.min, Linearity.min, Portability.min + let min = Areality.min, Linearity.min, Portability.min, Yielding.min - let max = Areality.max, Linearity.max, Portability.max + let max = Areality.max, Linearity.max, Portability.max, Yielding.max - let legacy = Areality.legacy, Linearity.legacy, Portability.legacy + let legacy = + Areality.legacy, Linearity.legacy, Portability.legacy, Yielding.legacy - let le (a0, a1, a2) (b0, b1, b2) = + let le (a0, a1, a2, a3) (b0, b1, b2, b3) = Areality.le a0 b0 && Linearity.le a1 b1 && Portability.le a2 b2 - - let join (a0, a1, a2) (b0, b1, b2) = - Areality.join a0 b0, Linearity.join a1 b1, Portability.join a2 b2 - - let meet (a0, a1, a2) (b0, b1, b2) = - Areality.meet a0 b0, Linearity.meet a1 b1, Portability.meet a2 b2 - - let imply (a0, a1, a2) (b0, b1, b2) = - Areality.imply a0 b0, Linearity.imply a1 b1, Portability.imply a2 b2 - - let subtract (a0, a1, a2) (b0, b1, b2) = + && Yielding.le a3 b3 + + let join (a0, a1, a2, a3) (b0, b1, b2, b3) = + ( Areality.join a0 b0, + Linearity.join a1 b1, + Portability.join a2 b2, + Yielding.join a3 b3 ) + + let meet (a0, a1, a2, a3) (b0, b1, b2, b3) = + ( Areality.meet a0 b0, + Linearity.meet a1 b1, + Portability.meet a2 b2, + Yielding.meet a3 b3 ) + + let imply (a0, a1, a2, a3) (b0, b1, b2, b3) = + ( Areality.imply a0 b0, + Linearity.imply a1 b1, + Portability.imply a2 b2, + Yielding.imply a3 b3 ) + + let subtract (a0, a1, a2, a3) (b0, b1, b2, b3) = ( Areality.subtract a0 b0, Linearity.subtract a1 b1, - Portability.subtract a2 b2 ) + Portability.subtract a2 b2, + Yielding.subtract a3 b3 ) - let print ppf (a0, a1, a2) = - Format.fprintf ppf "%a,%a,%a" Areality.print a0 Linearity.print a1 - Portability.print a2 + let print ppf (a0, a1, a2, a3) = + Format.fprintf ppf "%a,%a,%a,%a" Areality.print a0 Linearity.print a1 + Portability.print a2 Yielding.print a3 end [@@inline] @@ -392,6 +440,7 @@ module Lattices = struct | Uniqueness_op : Uniqueness_op.t obj | Linearity : Linearity.t obj | Portability : Portability.t obj + | Yielding : Yielding.t obj | Contention_op : Contention_op.t obj | Monadic_op : Monadic_op.t obj | Comonadic_with_regionality : Comonadic_with_regionality.t obj @@ -404,6 +453,7 @@ module Lattices = struct | Uniqueness_op -> Format.fprintf ppf "Uniqueness_op" | Linearity -> Format.fprintf ppf "Linearity" | Portability -> Format.fprintf ppf "Portability" + | Yielding -> Format.fprintf ppf "Yielding" | Contention_op -> Format.fprintf ppf "Contention_op" | Monadic_op -> Format.fprintf ppf "Monadic_op" | Comonadic_with_locality -> Format.fprintf ppf "Comonadic_with_locality" @@ -415,6 +465,7 @@ module Lattices = struct | Regionality -> Regionality.min | Uniqueness_op -> Uniqueness_op.min | Contention_op -> Contention_op.min + | Yielding -> Yielding.min | Linearity -> Linearity.min | Portability -> Portability.min | Monadic_op -> Monadic_op.min @@ -428,6 +479,7 @@ module Lattices = struct | Contention_op -> Contention_op.max | Linearity -> Linearity.max | Portability -> Portability.max + | Yielding -> Yielding.max | Monadic_op -> Monadic_op.max | Comonadic_with_locality -> Comonadic_with_locality.max | Comonadic_with_regionality -> Comonadic_with_regionality.max @@ -441,6 +493,7 @@ module Lattices = struct | Contention_op -> Contention_op.le a b | Linearity -> Linearity.le a b | Portability -> Portability.le a b + | Yielding -> Yielding.le a b | Monadic_op -> Monadic_op.le a b | Comonadic_with_locality -> Comonadic_with_locality.le a b | Comonadic_with_regionality -> Comonadic_with_regionality.le a b @@ -454,6 +507,7 @@ module Lattices = struct | Contention_op -> Contention_op.join a b | Linearity -> Linearity.join a b | Portability -> Portability.join a b + | Yielding -> Yielding.join a b | Monadic_op -> Monadic_op.join a b | Comonadic_with_locality -> Comonadic_with_locality.join a b | Comonadic_with_regionality -> Comonadic_with_regionality.join a b @@ -467,6 +521,7 @@ module Lattices = struct | Contention_op -> Contention_op.meet a b | Linearity -> Linearity.meet a b | Portability -> Portability.meet a b + | Yielding -> Yielding.meet a b | Monadic_op -> Monadic_op.meet a b | Comonadic_with_locality -> Comonadic_with_locality.meet a b | Comonadic_with_regionality -> Comonadic_with_regionality.meet a b @@ -480,6 +535,7 @@ module Lattices = struct | Contention_op -> Contention_op.imply a b | Linearity -> Linearity.imply a b | Portability -> Portability.imply a b + | Yielding -> Yielding.imply a b | Comonadic_with_locality -> Comonadic_with_locality.imply a b | Comonadic_with_regionality -> Comonadic_with_regionality.imply a b | Monadic_op -> Monadic_op.imply a b @@ -493,6 +549,7 @@ module Lattices = struct | Contention_op -> Contention_op.subtract a b | Linearity -> Linearity.subtract a b | Portability -> Portability.subtract a b + | Yielding -> Yielding.subtract a b | Comonadic_with_locality -> Comonadic_with_locality.subtract a b | Comonadic_with_regionality -> Comonadic_with_regionality.subtract a b | Monadic_op -> Monadic_op.subtract a b @@ -505,6 +562,7 @@ module Lattices = struct | Contention_op -> Contention_op.print | Linearity -> Linearity.print | Portability -> Portability.print + | Yielding -> Yielding.print | Monadic_op -> Monadic_op.print | Comonadic_with_locality -> Comonadic_with_locality.print | Comonadic_with_regionality -> Comonadic_with_regionality.print @@ -521,11 +579,12 @@ module Lattices = struct | Contention_op, Contention_op -> Some Refl | Linearity, Linearity -> Some Refl | Portability, Portability -> Some Refl + | Yielding, Yielding -> Some Refl | Monadic_op, Monadic_op -> Some Refl | Comonadic_with_locality, Comonadic_with_locality -> Some Refl | Comonadic_with_regionality, Comonadic_with_regionality -> Some Refl | ( ( Locality | Regionality | Uniqueness_op | Contention_op | Linearity - | Portability | Monadic_op | Comonadic_with_locality + | Portability | Yielding | Monadic_op | Comonadic_with_locality | Comonadic_with_regionality ), _ ) -> None @@ -542,6 +601,7 @@ module Lattices_mono = struct | Areality : ('a comonadic_with, 'a) t | Linearity : ('areality comonadic_with, Linearity.t) t | Portability : ('areality comonadic_with, Portability.t) t + | Yielding : ('areality comonadic_with, Yielding.t) t | Uniqueness : (Monadic_op.t, Uniqueness_op.t) t | Contention : (Monadic_op.t, Contention_op.t) t @@ -552,6 +612,7 @@ module Lattices_mono = struct | Portability -> Format.fprintf ppf "portability" | Uniqueness -> Format.fprintf ppf "uniqueness" | Contention -> Format.fprintf ppf "contention" + | Yielding -> Format.fprintf ppf "yielding" let eq : type p r0 r1. (p, r0) t -> (p, r1) t -> (r0, r1) Misc.eq option = fun ax0 ax1 -> @@ -561,24 +622,29 @@ module Lattices_mono = struct | Portability, Portability -> Some Refl | Uniqueness, Uniqueness -> Some Refl | Contention, Contention -> Some Refl - | (Areality | Linearity | Uniqueness | Portability | Contention), _ -> + | Yielding, Yielding -> Some Refl + | ( ( Areality | Linearity | Uniqueness | Portability | Contention + | Yielding ), + _ ) -> None let proj : type p r. (p, r) t -> p -> r = fun ax t -> match ax, t with - | Areality, (a, _, _) -> a - | Linearity, (_, lin, _) -> lin - | Portability, (_, _, s) -> s + | Areality, (a, _, _, _) -> a + | Linearity, (_, lin, _, _) -> lin + | Portability, (_, _, s, _) -> s + | Yielding, (_, _, _, yld) -> yld | Uniqueness, (uni, _) -> uni | Contention, (_, con) -> con let update : type p r. (p, r) t -> r -> p -> p = fun ax r t -> match ax, t with - | Areality, (_, lin, portable) -> r, lin, portable - | Linearity, (area, _, portable) -> area, r, portable - | Portability, (area, lin, _) -> area, lin, r + | Areality, (_, lin, portable, yld) -> r, lin, portable, yld + | Linearity, (area, _, portable, yld) -> area, r, portable, yld + | Portability, (area, lin, _, yld) -> area, lin, r, yld + | Yielding, (area, lin, portable, _) -> area, lin, portable, r | Uniqueness, (_, con) -> r, con | Contention, (uni, _) -> uni, r end @@ -733,7 +799,7 @@ module Lattices_mono = struct end) let set_areality : type a0 a1. a1 -> a0 comonadic_with -> a1 comonadic_with = - fun r (_, lin, portable) -> r, lin, portable + fun r (_, lin, portable, yld) -> r, lin, portable, yld let proj_obj : type t r. (t, r) Axis.t -> t obj -> r obj = fun ax obj -> @@ -744,6 +810,8 @@ module Lattices_mono = struct | Linearity, Comonadic_with_regionality -> Linearity | Portability, Comonadic_with_locality -> Portability | Portability, Comonadic_with_regionality -> Portability + | Yielding, Comonadic_with_locality -> Yielding + | Yielding, Comonadic_with_regionality -> Yielding | Uniqueness, Monadic_op -> Uniqueness_op | Contention, Monadic_op -> Contention_op @@ -753,7 +821,7 @@ module Lattices_mono = struct | Locality -> Comonadic_with_locality | Regionality -> Comonadic_with_regionality | Uniqueness_op | Linearity | Monadic_op | Comonadic_with_regionality - | Comonadic_with_locality | Contention_op | Portability -> + | Comonadic_with_locality | Contention_op | Portability | Yielding -> assert false let rec src : type a b d. b obj -> (a, b, d) morph -> a obj = @@ -921,15 +989,17 @@ module Lattices_mono = struct | Comonadic_with_locality -> ( Locality.min, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.min ) | Comonadic_with_regionality -> ( Regionality.min, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.min ) let comonadic_to_monadic : type a. a comonadic_with obj -> a comonadic_with -> Monadic_op.t = - fun obj (_, linearity, portability) -> + fun obj (_, linearity, portability, _) -> match obj with | Comonadic_with_locality -> linear_to_unique linearity, portable_to_contended portability @@ -943,11 +1013,13 @@ module Lattices_mono = struct | Comonadic_with_locality -> ( Locality.max, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.max ) | Comonadic_with_regionality -> ( Regionality.max, unique_to_linear uniqueness, - contended_to_portable contention ) + contended_to_portable contention, + Yielding.max ) let rec apply : type a b d. b obj -> (a, b, d) morph -> a -> b = fun dst f a -> @@ -1036,7 +1108,8 @@ module Lattices_mono = struct match ax with | Areality -> Some (compose dst f (Proj (src', Areality))) | Linearity -> Some (Proj (src', Linearity)) - | Portability -> Some (Proj (src', Portability))) + | Portability -> Some (Proj (src', Portability)) + | Yielding -> Some (Proj (src', Yielding))) | Proj _, Monadic_to_comonadic_min -> None | Proj _, Monadic_to_comonadic_max -> None | Proj _, Comonadic_to_monadic _ -> None @@ -1482,6 +1555,24 @@ module Contention = struct let zap_to_legacy = zap_to_floor end +module Yielding = struct + module Const = C.Yielding + + module Obj = struct + type const = Const.t + + module Solver = S.Positive + + let obj = C.Yielding + end + + include Common (Obj) + + let legacy = of_const Const.legacy + + let zap_to_legacy = zap_to_floor +end + let regional_to_local m = S.Positive.via_monotone Locality.Obj.obj C.Regional_to_local m @@ -1562,20 +1653,25 @@ module Comonadic_with (Areality : Areality) = struct let areality = proj Areality m |> Areality.zap_to_legacy in let linearity = proj Linearity m |> Linearity.zap_to_legacy in let portability = proj Portability m |> Portability.zap_to_legacy in - areality, linearity, portability + let yielding = proj Yielding m |> Yielding.zap_to_legacy in + areality, linearity, portability, yielding let imply c m = Solver.via_monotone obj (Imply c) (Solver.disallow_left m) let legacy = of_const Const.legacy - let axis_of_error { left = area0, lin0, port0; right = area1, lin1, port1 } : + let axis_of_error + { left = area0, lin0, port0, yld0; right = area1, lin1, port1, yld1 } : error = if Areality.Const.le area0 area1 then if Linearity.Const.le lin0 lin1 then if Portability.Const.le port0 port1 - then assert false + then + if Yielding.Const.le yld0 yld1 + then assert false + else Error (Yielding, { left = yld0; right = yld1 }) else Error (Portability, { left = port0; right = port1 }) else Error (Linearity, { left = lin0; right = lin1 }) else Error (Areality, { left = area0; right = area1 }) @@ -1713,23 +1809,25 @@ module Value_with (Areality : Areality) = struct | Monadic ax -> Monadic.proj_obj ax | Comonadic ax -> Comonadic.proj_obj ax - type ('a, 'b, 'c, 'd, 'e) modes = + type ('a, 'b, 'c, 'd, 'e, 'f) modes = { areality : 'a; linearity : 'b; uniqueness : 'c; portability : 'd; - contention : 'e + contention : 'e; + yielding : 'f } - let split { areality; linearity; portability; uniqueness; contention } = + let split + { areality; linearity; portability; uniqueness; contention; yielding } = let monadic = uniqueness, contention in - let comonadic = areality, linearity, portability in + let comonadic = areality, linearity, portability, yielding in { comonadic; monadic } let merge { comonadic; monadic } = - let areality, linearity, portability = comonadic in + let areality, linearity, portability, yielding = comonadic in let uniqueness, contention = monadic in - { areality; linearity; portability; uniqueness; contention } + { areality; linearity; portability; uniqueness; contention; yielding } let print ?verbose () ppf { monadic; comonadic } = Format.fprintf ppf "%a;%a" @@ -1750,7 +1848,8 @@ module Value_with (Areality : Areality) = struct Linearity.Const.t, Uniqueness.Const.t, Portability.Const.t, - Contention.Const.t ) + Contention.Const.t, + Yielding.Const.t ) modes module Monadic = Monadic.Const @@ -1794,7 +1893,8 @@ module Value_with (Areality : Areality) = struct Linearity.Const.t option, Uniqueness.Const.t option, Portability.Const.t option, - Contention.Const.t option ) + Contention.Const.t option, + Yielding.Const.t option ) modes let none = @@ -1802,7 +1902,8 @@ module Value_with (Areality : Areality) = struct uniqueness = None; linearity = None; portability = None; - contention = None + contention = None; + yielding = None } let value opt ~default = @@ -1817,15 +1918,17 @@ module Value_with (Areality : Areality) = struct let contention = Option.value opt.contention ~default:default.contention in - { areality; uniqueness; linearity; portability; contention } + let yielding = Option.value opt.yielding ~default:default.yielding in + { areality; uniqueness; linearity; portability; contention; yielding } - let print ppf { areality; uniqueness; linearity; portability; contention } + let print ppf + { areality; uniqueness; linearity; portability; contention; yielding } = let option_print print ppf = function | None -> Format.fprintf ppf "None" | Some a -> Format.fprintf ppf "Some %a" print a in - Format.fprintf ppf "%a,%a,%a,%a,%a" + Format.fprintf ppf "%a,%a,%a,%a,%a,%a" (option_print Areality.Const.print) areality (option_print Linearity.Const.print) @@ -1836,6 +1939,8 @@ module Value_with (Areality : Areality) = struct portability (option_print Contention.Const.print) contention + (option_print Yielding.Const.print) + yielding end let diff m0 m1 = @@ -1847,7 +1952,8 @@ module Value_with (Areality : Areality) = struct diff Portability.Const.le m0.portability m1.portability in let contention = diff Contention.Const.le m0.contention m1.contention in - { areality; linearity; uniqueness; portability; contention } + let yielding = diff Yielding.Const.le m0.yielding m1.yielding in + { areality; linearity; uniqueness; portability; contention; yielding } (** See [Alloc.close_over] for explanation. *) let close_over m = @@ -2139,10 +2245,10 @@ module Alloc = Value_with (Locality) module Const = struct let alloc_as_value - ({ areality; linearity; portability; uniqueness; contention } : + ({ areality; linearity; portability; uniqueness; contention; yielding } : Alloc.Const.t) : Value.Const.t = let areality = C.locality_as_regionality areality in - { areality; linearity; portability; uniqueness; contention } + { areality; linearity; portability; uniqueness; contention; yielding } let locality_as_regionality = C.locality_as_regionality end @@ -2265,7 +2371,7 @@ module Modality = struct type t = | Const of Const.t - | Diff of Mode.lr * Mode.l + | Diff of Mode.lr * Mode.lr (** inferred modality. See [apply] for its behavior. *) | Undefined @@ -2305,7 +2411,7 @@ module Modality = struct | Const c -> Const.apply c x |> Mode.disallow_right | Undefined -> Misc.fatal_error "modality Undefined should not be applied." - | Diff (_, m) -> Mode.join [m; Mode.disallow_right x] + | Diff (_, m) -> Mode.join [Mode.allow_right m; x] let print ppf = function | Const c -> Const.print ppf c @@ -2316,13 +2422,15 @@ module Modality = struct | Const c -> c | Undefined -> Misc.fatal_error "modality Undefined should not be zapped." | Diff (mm, m) -> - let m = Mode.zap_to_floor m in (* For soundness, we want some [c] such that [m <= join c mm], which - gives [subtract_mm m <= c]. Note that [mm] is a variable, but we need - a constant. Therefore, we take its floor [mm' <= mm], and we have - [subtract_mm m <= subtract_mm' m <= c]. *) - let mm' = Mode.Guts.get_floor mm in - Const.Join_const (Mode.Const.subtract m mm') + gives [subtract_mm m <= c]. To satisfy coherence conditions (see + [mode_intf.ml]), we must zap [mm] and [m] fully. Note that [subtract] + is antitone for [mm] and monotone for [m], so we zap [mm] to ceil, + and [m] to floor, to get the floor of [c]. *) + let m = Mode.zap_to_floor m in + let mm = Mode.zap_to_ceil mm in + let c = Mode.Const.subtract m mm in + Const.Join_const c let zap_to_id = zap_to_floor @@ -2398,7 +2506,7 @@ module Modality = struct type t = | Const of Const.t | Undefined - | Exactly of Mode.lr * Mode.l + | Exactly of Mode.lr * Mode.lr (** inferred modality. See [apply] for its behavior. *) let sub_log left right ~log : (unit, error) Result.t = @@ -2437,7 +2545,7 @@ module Modality = struct | Const c -> Const.apply c x |> Mode.disallow_right | Undefined -> Misc.fatal_error "modality Undefined should not be applied." - | Exactly (_mm, m) -> m + | Exactly (_mm, m) -> Mode.disallow_right m let print ppf = function | Const c -> Const.print ppf c @@ -2451,7 +2559,17 @@ module Modality = struct let zap_to_ceil = function | Const c -> c | Undefined -> Misc.fatal_error "modality Undefined should not be zapped." - | Exactly _ -> Const.id + | Exactly (mm, m) -> + (* For soundness and completeness, we need some [c] such that [meet_c mm + = m], or equivalently [c = imply mm m]. To satisfy the coherence + conditions listed in [mode_intf.ml], we need to zap [mm] and [m] + fully. [imply] is antitone in [mm] but monotone in [m] , so we zap + [mm] to strongest and [m] to weakest, in order to get the weakest + [c]. *) + let m = Mode.zap_to_ceil m in + let mm = Mode.zap_to_floor mm in + let c = Mode.Const.imply mm m in + Const.Meet_const c let zap_to_id = zap_to_ceil @@ -2459,39 +2577,10 @@ module Modality = struct | Const c -> c | Undefined -> Misc.fatal_error "modality Undefined should not be zapped." | Exactly (mm, m) -> + (* Opposite to [zap_to_ceil]. *) let m = Mode.zap_to_floor m in - (* We want some [c] such that: - - Soundness: [meet_with c mm >= m]. - - Completeness: [meet_with c mm <= m]. - - Simplicity: Optionally, we want [c] to be as high as possible to make - [meet_with c] a simpler modality. - - We first rewrite completeness condition to [c <= imply_with mm m]. - We will take [c] to be [imply_with mm m] and prove soundness for it. - - To prove soundness [meet_with (imply_with mm m) mm >= m], we need to prove: - - [imply_with mm m >= m], or equivalently [meet mm m <= m] which is trivial. - - [mm >= m], which is guaranteed by the caller of [infer]. - In fact, the soundness condition holds for any [c] taken to be - [imply_with _ m] where the underscore can be anything. - - Note that [imply_with] requires its first argument to be a constant, so we - need to get a constant out of [mm]. First recall that [imply_with] is antitone - in its first argument. Now, we have several choices: - - Take its floor [mm' <= mm], and then [c' = imply_with mm' m]. [c'] is higher - than [c] and thus might be incomplete. - - Take its ceil [mm' >= mm]. Then, [c'] is lower than [c] and thus complete, - but might be less simple than [c]. - - Zap to floor. This gives us a [c' = c] that is complete and simple, but we - are imposing extra constraint to [mm] not requested by the caller. - - Zap to ceil. This gives us a [c' = c] that is complete, but less simple than - zapping it to floor. Also, we are imposing extra constraint. - - We prioritize completeness and "not imposing extra constarint" over - simplicity. So we take its ceil [mm' >= mm]. - *) - let mm' = Mode.Guts.get_ceil mm in - let c = Mode.Const.imply mm' m in + let mm = Mode.zap_to_ceil mm in + let c = Mode.Const.imply mm m in Const.Meet_const c let to_const_exn = function diff --git a/typing/mode_intf.mli b/typing/mode_intf.mli index 5b0f4897265..c7544f2dd48 100644 --- a/typing/mode_intf.mli +++ b/typing/mode_intf.mli @@ -263,7 +263,26 @@ module type S = sig and type 'd t = (Const.t, 'd) mode_monadic end - type 'a comonadic_with = private 'a * Linearity.Const.t * Portability.Const.t + module Yielding : sig + module Const : sig + type t = + | Yielding + | Unyielding + + include Lattice with type t := t + end + + type error = Const.t Solver.error + + include + Common + with module Const := Const + and type error := error + and type 'd t = (Const.t, 'd) mode_comonadic + end + + type 'a comonadic_with = private + 'a * Linearity.Const.t * Portability.Const.t * Yielding.Const.t type monadic = private Uniqueness.Const.t * Contention.Const.t @@ -274,6 +293,7 @@ module type S = sig | Areality : ('a comonadic_with, 'a) t | Linearity : ('areality comonadic_with, Linearity.Const.t) t | Portability : ('areality comonadic_with, Portability.Const.t) t + | Yielding : ('areality comonadic_with, Yielding.Const.t) t | Uniqueness : (monadic, Uniqueness.Const.t) t | Contention : (monadic, Contention.Const.t) t @@ -317,12 +337,13 @@ module type S = sig (Comonadic.Const.t, 'a) Axis.t -> (('a, 'd) mode_comonadic, 'a, 'd) axis - type ('a, 'b, 'c, 'd, 'e) modes = + type ('a, 'b, 'c, 'd, 'e, 'f) modes = { areality : 'a; linearity : 'b; uniqueness : 'c; portability : 'd; - contention : 'e + contention : 'e; + yielding : 'f } module Const : sig @@ -333,7 +354,8 @@ module type S = sig Linearity.Const.t, Uniqueness.Const.t, Portability.Const.t, - Contention.Const.t ) + Contention.Const.t, + Yielding.Const.t ) modes module Option : sig @@ -344,7 +366,8 @@ module type S = sig Linearity.Const.t option, Uniqueness.Const.t option, Portability.Const.t option, - Contention.Const.t option ) + Contention.Const.t option, + Yielding.Const.t option ) modes val none : t @@ -548,16 +571,24 @@ module type S = sig value description in the inferred module type. The caller should ensure that for comonadic axes, [md_mode >= mode]. *) - val infer : md_mode:Value.lr -> mode:Value.l -> t + val infer : md_mode:Value.lr -> mode:Value.lr -> t (* The following zapping functions possibly mutate a potentially inferred modality [m] to a constant modality [c]. The constant modality is - returned. [m <= c] holds, even after further mutations to [m]. *) + returned. The following coherence conditions hold: + - [m <= c] always holds, even after further mutations to [m]. + - [c0 <= c1] always holds, where [c0] and [c1] are results of two + abitrary zappings of some [m], even after further mutations to [m]. + Essentially that means [c0 = c1]. + + NB: zapping an inferred modality will zap both [md_mode] and [mode] that + it contains. The caller is reponsible for correct zapping order. + *) - (** Returns a const modality weaker than the given modality. *) + (** Zap an inferred modality towards identity modality. *) val zap_to_id : t -> Const.t - (** Returns a const modality lowest (strongest) possible. *) + (** Zap an inferred modality towards the lowest (strongest) modality. *) val zap_to_floor : t -> Const.t (** Asserts the given modality is a const modality, and returns it. *) diff --git a/typing/predef.ml b/typing/predef.ml index 6e140f2ffb1..e9f1fc39eca 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -477,10 +477,11 @@ let add_small_number_beta_extension_types add_type env = |> add_type ident_int16 ~jkind:Jkind.Const.Builtin.immediate let or_null_kind tvar = - (* CR layouts v3: use [Variant_with_null] when it's supported - in the backend. *) - variant [cstr ident_null []; - cstr ident_this [unrestricted tvar or_null_argument_sort]] + let cstrs = + [ cstr ident_null []; + cstr ident_this [unrestricted tvar or_null_argument_sort]] + in + Type_variant (cstrs, Variant_with_null) let add_or_null add_type env = let add_type1 = mk_add_type1 add_type in diff --git a/typing/primitive.ml b/typing/primitive.ml index d2cc075844f..b49b687c5c0 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -674,7 +674,20 @@ let prim_has_valid_reprs ~loc prim = any; is (Same_as_ocaml_repr C.value); ] - + | "%makearray_dynamic_uninit" -> + (* Restrictions on this primitive are checked in [Translprim] *) + check [ + is (Same_as_ocaml_repr C.value); + is (Same_as_ocaml_repr C.value); + ] + | "%array_element_size_in_bytes" -> + check [ + is (Same_as_ocaml_repr C.value); + is (Same_as_ocaml_repr C.value); + ] + | "%peek" | "%poke" -> + (* Arities and layouts of these primitives are checked in [Translprim] *) + fun _ -> Success | "%box_float" -> exactly [Same_as_ocaml_repr C.float64; Same_as_ocaml_repr C.value] | "%unbox_float" -> diff --git a/typing/printtyp.ml b/typing/printtyp.ml index e91897f5d75..134d25c9e85 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1419,7 +1419,8 @@ let tree_of_modes modes = tree_of_mode diff.uniqueness [Mode.Uniqueness.Const.Unique, Omd_new "unique"]; tree_of_mode diff.portability [Mode.Portability.Const.Portable, Omd_new "portable"]; tree_of_mode diff.contention [Mode.Contention.Const.Contended, Omd_new "contended"; - Mode.Contention.Const.Shared, Omd_new "shared"]] + Mode.Contention.Const.Shared, Omd_new "shared"]; + tree_of_mode diff.yielding [Mode.Yielding.Const.Yielding, Omd_new "yielding"]] in List.filter_map Fun.id l diff --git a/typing/typecore.ml b/typing/typecore.ml index a028ef1bbcf..fcc018534d4 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -300,7 +300,8 @@ let error_of_filter_arrow_failure ~explanation ~first ty_fun let type_module = ref ((fun _env _md -> assert false) : - Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t * + Env.locks) (* Forward declaration, to be filled in by Typemod.type_open *) @@ -551,6 +552,9 @@ let mode_lazy expected_mode = (* The thunk is evaluated only once, so we only require it to be [once], even if the [lazy] is [many]. *) |> Value.join_with (Comonadic Linearity) Linearity.Const.Once + (* The thunk is evaluated only when the [lazy] is [uncontended], so we only require it + to be [nonportable], even if the [lazy] is [portable]. *) + |> Value.join_with (Comonadic Portability) Portability.Const.Nonportable in {expected_mode with locality_context = Some Lazy }, closure_mode @@ -1273,7 +1277,7 @@ let add_module_variables env module_variables = Here, on the other hand, we're calling [type_module] outside the raised level, so there's no extra step to take. *) - let modl, md_shape = + let modl, md_shape, locks = !type_module env Ast_helper.( Mod.unpack ~loc:mv_loc @@ -1291,7 +1295,9 @@ let add_module_variables env module_variables = md_loc = mv_name.loc; md_uid = mv_uid; } in - Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env + Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md + (* the [locks] is always empty, but typecore doesn't need to know *) + ~locks env end ) env module_variables_as_list @@ -3011,7 +3017,7 @@ and type_pat_aux | Ppat_record(lid_sp_list, closed) -> type_record_pat Legacy lid_sp_list closed | Ppat_record_unboxed_product(lid_sp_list, closed) -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_record_pat Unboxed_product lid_sp_list closed | Ppat_array (mut, spl) -> let mut = @@ -6003,7 +6009,7 @@ and type_expect_ | Pexp_record(lid_sexp_list, opt_sexp) -> type_expect_record ~overwrite Legacy lid_sexp_list opt_sexp | Pexp_record_unboxed_product(lid_sexp_list, opt_sexp) -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; type_expect_record ~overwrite Unboxed_product lid_sexp_list opt_sexp | Pexp_field(srecord, lid) -> let (record, rmode, label, _) = @@ -6055,7 +6061,7 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_unboxed_field(srecord, lid) -> - Language_extension.assert_enabled ~loc Layouts Language_extension.Beta; + Language_extension.assert_enabled ~loc Layouts Language_extension.Stable; let (record, rmode, label, _) = type_label_access Unboxed_product env srecord Env.Projection lid in @@ -6403,7 +6409,7 @@ and type_expect_ with_local_level begin fun () -> let modl, pres, id, new_env = Typetexp.TyVarEnv.with_local_scope begin fun () -> - let modl, md_shape = !type_module env smodl in + let modl, md_shape, locks = !type_module env smodl in Mtype.lower_nongen lv modl.mod_type; let pres = match modl.mod_type with @@ -6424,7 +6430,7 @@ and type_expect_ | Some name -> let id, env = Env.enter_module_declaration - ~scope ~shape:md_shape name pres md env + ~scope ~shape:md_shape name pres md ~locks env in Some id, env in @@ -10815,6 +10821,7 @@ let report_error ~loc env = function | Error (Monadic Contention, _ ) -> contention_hint fail_reason submode_reason contention_context | Error (Comonadic Portability, _ ) -> [] + | Error (Comonadic Yielding, _) -> [] in Location.errorf ~loc ~sub "@[%t@]" begin match fail_reason with diff --git a/typing/typecore.mli b/typing/typecore.mli index 36c34591889..35a4a6befa6 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -332,7 +332,8 @@ val report_error: loc:Location.t -> Env.t -> error -> Location.error (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: - (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) ref + (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t * + Env.locks) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 30f24d1577f..d184a05d711 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -89,6 +89,7 @@ type error = | Unboxed_mutable_label | Recursive_abbrev of string * Env.t * reaching_type_path | Cycle_in_def of string * Env.t * reaching_type_path + | Unboxed_recursion of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option | Constraint_failed of Env.t * Errortrace.unification_error | Inconsistent_constraint of Env.t * Errortrace.unification_error @@ -933,7 +934,7 @@ let transl_declaration env sdecl (id, uid) = Ttype_record lbls, Type_record(lbls', rep), jkind | Ptype_record_unboxed_product lbls -> Language_extension.assert_enabled ~loc:sdecl.ptype_loc Layouts - Language_extension.Beta; + Language_extension.Stable; let lbls, lbls' = transl_labels ~record_form:Unboxed_product ~new_var_jkind:Any ~allow_unboxed:true env None true lbls Record_unboxed_product @@ -1743,11 +1744,6 @@ let update_decl_jkind env dpath decl = type_jkind; type_has_illegal_crossings }, type_jkind - (* CR layouts v3.0: remove this once [or_null] is [Variant_with_null]. - - No updating required for [or_null_reexport], and we must not - incorrectly override the jkind to [non_null]. - *) | Type_record_unboxed_product (lbls, rep) -> begin match rep with | Record_unboxed_product -> @@ -1770,9 +1766,6 @@ let update_decl_jkind env dpath decl = type_has_illegal_crossings }, type_jkind end - | Type_variant _ when - Builtin_attributes.has_or_null_reexport decl.type_attributes -> - decl, decl.type_jkind | Type_variant (cstrs, rep) -> let cstrs, rep, type_jkind = update_variant_kind cstrs rep in let type_jkind, type_has_illegal_crossings = add_crossings type_jkind in @@ -2065,6 +2058,110 @@ let check_well_founded_decl ~abs_env env loc path decl to_check = end)} in it.it_type_declaration it (Ctype.generic_instance_declaration decl) +(* We only allow recursion in unboxed product types to occur through boxes, + otherwise the type is uninhabitable and usually also infinite-size. + See [typing-layouts-unboxed-records/recursive.ml]. + + Because [check_well_founded] already ruled out recursion through structural + types, we just look for a cycle in nominal unboxed types ([@@unboxed] types + and unboxed records), tracking the set of seen paths. + + For each group of mutually recursive type declarations, we define the + following "type contains" transitive relation on type expressions: + + 1. Unboxed records and variants defined in the group contain their fields. + + If [type 'a t = #{ ...; lbl : u; ... }], + or [type 'a t = { lbl : u } [@@unboxed]], + or [type 'a t = U of u [@@unboxed]] + is in the recursive group, then ['a t] contains [u]. + + 2. Abbreviations defined in the group contain their expansions. + + If [type 'a t = u] is in the recursive group then ['a t] contains [u]. + + 3. Unboxed tuples contain their components. + + [#(u_1 * ...)] contains all [u_i]. + + 4. Types not in the group contain the parameters indicated by their layout. + + ['a t] contains ['a] if [layout_of 'a] or [any] occurs in ['a t]'s layout. + + For example, if [('a, 'b) t] has layout [layout_of 'a], it may contain + ['a], but not ['b]. If it has layout [any], we must conservatively + consider it to contain both ['a] and ['b]. + + Note: We don't yet have [layout_of], so currently only consider [any]. + + If a path starting from the type expression on the LHS of a declaration + contains two types with the same head type constructor, and that repeated + type is an unboxed record or variant, then the check raises a type error. + + CR layouts v7.2: accept safe types that expand the same path multiple times, + e.g. [type 'a t = #{ a : 'a } and x = int t t], either by using layouts + variables or the algorithm from "Unboxed data constructors - or, how cpp + decides a halting problem." + See https://github.com/ocaml-flambda/flambda-backend/pull/3407. +*) +type step_result = + | Contained of type_expr list + | Expanded_to of type_expr + | Is_cyclic +let check_unboxed_recursion ~abs_env env loc path0 ty0 to_check = + let contained_parameters tyl layout = + (* A type whose layout has [any] could contain all its parameters. + CR layouts v11: update this function for [layout_of] layouts. *) + let rec has_any : Jkind_types.Layout.Const.t -> bool = function + | Any -> true + | Base _ -> false + | Product l -> List.exists has_any l + in + if has_any layout then tyl else [] + in + let step_once parents ty = + match get_desc ty with + | Tconstr (path, tyl, _) -> + if to_check path then + if Path.Set.mem path parents then + Is_cyclic, parents + else + let parents = Path.Set.add path parents in + match Ctype.try_expand_safe_opt env ty with + | ty' -> + Expanded_to ty', parents + | exception Ctype.Cannot_expand -> + Contained (Ctype.contained_without_boxing env ty), parents + else + begin try + (* Determine contained types by layout for decls outside of the + recursive group *) + let jkind = (Env.find_type path env).type_jkind in + let layout = Option.get (Jkind.get_layout jkind) in + Contained (contained_parameters tyl layout), parents + with Not_found | Invalid_argument _ -> + (* Because [to_check path] is false, this decl has already been + typechecked, so it's already in [env] with a constant layout. *) + Misc.fatal_error "Typedecl.check_unboxed_recursion" + end + | _ -> Contained (Ctype.contained_without_boxing env ty), parents + in + let rec visit parents trace ty = + match step_once parents ty with + | Contained tys, parents -> + List.iter (fun ty' -> visit parents (Contains (ty, ty') :: trace) ty') tys + | Expanded_to ty', parents -> + visit parents (Expands_to(ty,ty') :: trace) ty' + | Is_cyclic, _ -> + raise (Error (loc, Unboxed_recursion (path0, abs_env, List.rev trace))) + in + Ctype.wrap_trace_gadt_instances env (visit Path.Set.empty []) ty0 + +let check_unboxed_recursion_decl ~abs_env env loc path decl to_check = + let decl = Ctype.generic_instance_declaration decl in + let ty = Btype.newgenty (Tconstr (path, decl.type_params, ref Mnil)) in + check_unboxed_recursion ~abs_env env loc (Path.name path) ty to_check + (* Check for non-regular abbreviations; an abbreviation [type 'a t = ...] is non-regular if the expansion of [...] contains instances [ty t] where [ty] is not equal to ['a]. @@ -2353,6 +2450,11 @@ let transl_type_decl env rec_flag sdecl_list = decls; List.iter (fun (tdecl, _shape) -> check_abbrev_regularity ~abs_env new_env id_loc_list to_check tdecl) tdecls; + List.iter (fun (id, decl) -> + check_unboxed_recursion_decl ~abs_env new_env (List.assoc id id_loc_list) + (Path.Pident id) + decl to_check) + decls; (* Now that we've ruled out ill-formed types, we can perform the delayed jkind checks *) List.iter (fun (checks,loc) -> @@ -3438,6 +3540,7 @@ let check_recmod_typedecl env loc recmod_ids path decl = (path, decl) is the type declaration to be checked. *) let to_check path = Path.exists_free recmod_ids path in check_well_founded_decl ~abs_env:env env loc path decl to_check; + check_unboxed_recursion_decl ~abs_env:env env loc path decl to_check; check_regularity ~abs_env:env env loc path decl to_check; (* additional coherence check, as one might build an incoherent signature, and use it to build an incoherent module, cf. #7851 *) @@ -3492,8 +3595,10 @@ module Reaching_path = struct (* Simplify a reaching path before showing it in error messages. *) let simplify path = + let is_tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false in let rec simplify : t -> t = function - | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + | Contains (ty1, _ty2) :: Contains (ty2', ty3) :: rest + when not (is_tconstr ty2') -> (* If t1 contains t2 and t2 contains t3, then t1 contains t3 and we don't need to show t2. *) simplify (Contains (ty1, ty3) :: rest) @@ -3581,6 +3686,14 @@ let report_error ppf = function fprintf ppf "@[The definition of %a contains a cycle%a@]" Style.inline_code s Reaching_path.pp_colon reaching_path + | Unboxed_recursion (s, env, reaching_path) -> + let reaching_path = Reaching_path.simplify reaching_path in + Printtyp.wrap_printing_env ~error:true env @@ fun () -> + Printtyp.reset (); + Reaching_path.add_to_preparation reaching_path; + fprintf ppf "@[The definition of %a is recursive without boxing%a@]" + Style.inline_code s + Reaching_path.pp_colon reaching_path | Definition_mismatch (ty, _env, None) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 13693ebd5a7..1a1555a9d1a 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -125,6 +125,7 @@ type error = | Unboxed_mutable_label | Recursive_abbrev of string * Env.t * reaching_type_path | Cycle_in_def of string * Env.t * reaching_type_path + | Unboxed_recursion of string * Env.t * reaching_type_path | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option | Constraint_failed of Env.t * Errortrace.unification_error | Inconsistent_constraint of Env.t * Errortrace.unification_error diff --git a/typing/typemod.ml b/typing/typemod.ml index 0674677a654..ff14ee00020 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1608,7 +1608,7 @@ let transl_modtype_longident loc env lid = Env.lookup_modtype_path ~loc lid env let transl_module_alias loc env lid = - let path, _ = Env.lookup_module_path ~lock:false ~load:false ~loc lid env in + let path, _ = Env.lookup_module_path ~load:false ~loc lid env in path let mkmty desc typ env loc attrs = @@ -2564,6 +2564,19 @@ let simplify_app_summary app_view = match app_view.arg with let maybe_infer_modalities ~loc ~env ~md_mode ~mode = if Language_extension.(is_at_least Mode Alpha) then begin + (* Values are packed into a structure at modes weaker than they actually + are. This is to allow our legacy zapping behavior. For example: + + module M = struct + let foo x = x + let bar = use_portable foo + end + module type S = module type of M + use_portable M.foo + + would type error at the last line. + *) + let mode, _ = Mode.Value.newvar_above mode in (* Upon construction, for comonadic (prescriptive) axes, module must be weaker than the values therein, for otherwise operations would be allowed to performed on the module (and extended to the @@ -2587,18 +2600,41 @@ let maybe_infer_modalities ~loc ~env ~md_mode ~mode = Mode.Modality.Value.id end +type alias = + | No : alias + (** The module is in a context that doesn't treat aliases specially. *) + | Yes_hold_locks : alias + (** The module is in a context that treat alias specially. If it is indeed an + alias, the caller will hold the locks in the alias, and walk them when + later the alias is used for its content. *) + | Yes_walk_locks : alias + (** The module is in a context that treat alias specially. However, the caller + doesn't want to hold the locks, and therefore the locks must be eagerly + walked. *) + +let is_alias = function + | No -> false + | Yes_walk_locks | Yes_hold_locks -> true + let rec type_module ?(alias=false) sttn funct_body anchor env smod = + let alias = if alias then Yes_walk_locks else No in + let md, shape, locks = + type_module_maybe_hold_locks ~alias sttn funct_body anchor env smod + in + assert (Env.locks_is_empty locks); + md, shape + +and type_module_maybe_hold_locks ~alias sttn funct_body anchor env smod = Builtin_attributes.warning_scope smod.pmod_attributes (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) and type_module_aux ~alias sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let path, mode = - Env.lookup_module_path ~load:(not alias) ~loc:smod.pmod_loc lid.txt env + let path, locks = + Env.lookup_module_path ~load:(not @@ is_alias alias) ~loc:smod.pmod_loc lid.txt env in - Mode.Value.submode_exn mode Mode.Value.legacy; - type_module_path_aux ~alias sttn env path lid smod + type_module_path_aux ~alias sttn env path locks lid smod | Pmod_structure sstr -> let (str, sg, names, shape, _finalenv) = type_structure funct_body anchor env sstr in @@ -2610,9 +2646,12 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_loc = smod.pmod_loc } in let sg' = Signature_names.simplify _finalenv names sg in - if List.length sg' = List.length sg then md, shape else - wrap_constraint_with_shape env false md - (Mty_signature sg') shape Tmodtype_implicit + let md, shape = + if List.length sg' = List.length sg then md, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit + in + md, shape, Env.locks_empty | Pmod_functor(arg_opt, sbody) -> let t_arg, ty_arg, newenv, funct_shape_param, funct_body = match arg_opt with @@ -2652,13 +2691,16 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc }, - Shape.abs funct_shape_param body_shape + Shape.abs funct_shape_param body_shape, Env.locks_empty | Pmod_apply _ | Pmod_apply_unit _ -> - type_application smod.pmod_loc sttn funct_body env smod + let md, shape = type_application smod.pmod_loc sttn funct_body env smod in + md, shape, Env.locks_empty | Pmod_constraint(sarg, smty, smode) -> check_no_modal_modules ~env smode; let smty = Option.get smty in - let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in + let arg, arg_shape, locks = + type_module_maybe_hold_locks ~alias true funct_body anchor env sarg + in let mty = transl_modtype env smty in let md, final_shape = wrap_constraint_with_shape env true arg mty.mty_type arg_shape @@ -2668,7 +2710,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_loc = smod.pmod_loc; mod_attributes = smod.pmod_attributes; }, - final_shape + final_shape, locks | Pmod_unpack sexp -> let exp = Ctype.with_local_level_if_principal @@ -2701,27 +2743,38 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc }, - Shape.leaf_for_unpack + Shape.leaf_for_unpack, Env.locks_empty | Pmod_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pmod_instance glob -> Language_extension.assert_enabled ~loc:smod.pmod_loc Instances (); let glob = instance_name ~loc:smod.pmod_loc env glob in - let path, mode = - Env.lookup_module_instance_path ~load:(not alias) ~loc:smod.pmod_loc + let path, locks = + Env.lookup_module_instance_path ~load:(not @@ is_alias alias) ~loc:smod.pmod_loc glob env in - Mode.Value.submode_exn mode Mode.Value.legacy; let lid = (* Only used by [untypeast] *) let name = Format.asprintf "*instance %a*" Global_module.Name.print glob in - Lident name |> Location.mknoloc + Location.(mkloc (Lident name) (ghostify smod.pmod_loc)) in - type_module_path_aux ~alias sttn env path lid smod - -and type_module_path_aux ~alias sttn env path lid smod = + type_module_path_aux ~alias sttn env path locks lid smod + +and type_module_path_aux ~alias sttn env path locks (lid : _ loc) smod = + let locks = + match alias with + | Yes_hold_locks -> locks + | No | Yes_walk_locks -> + let vmode = + Env.walk_locks ~loc:lid.loc ~env ~item:Module ~lid:lid.txt + Mode.Value.(legacy |> disallow_right) None locks + in + Mode.Value.submode_exn vmode.mode Mode.Value.legacy; + Env.locks_empty + in + let alias = is_alias alias in let md = { mod_desc = Tmod_ident (path, lid); mod_type = Mty_alias path; mod_env = env; @@ -2753,7 +2806,7 @@ and type_module_path_aux ~alias sttn env path lid smod = { md with mod_type = mty } end in - md, shape + md, shape, locks and type_application loc strengthen funct_body env smod = let rec extract_application funct_body env sargs smod = @@ -3449,7 +3502,8 @@ let type_toplevel_phrase env sig_acc s = Typecore.optimise_allocations (); (str, sg, to_remove_from_sg, shape, env) -let type_module_alias = type_module ~alias:true true false None +let type_module_alias = + type_module_maybe_hold_locks ~alias:Yes_hold_locks true false None let type_module = type_module true false None let type_structure = type_structure false None @@ -3627,18 +3681,6 @@ let () = type_module_type_of_fwd := type_module_type_of -(* File-level details *) - -let register_params params = - List.iter - (fun param_name -> - (* We don't (yet!) support parameterised parameters *) - let param = Global_module.Name.create_no_args param_name in - Env.register_parameter param - ) - params - - (* Typecheck an implementation file *) let gen_annot target annots = @@ -3725,7 +3767,6 @@ let type_implementation target modulename initial_env ast = ignore @@ Warnings.parse_options false "-32-34-37-38-60"; if !Clflags.as_parameter then error Cannot_compile_implementation_as_parameter; - register_params !Clflags.parameters; let (str, sg, names, shape, finalenv) = Profile.record_call "infer" (fun () -> type_structure initial_env ast) in @@ -3913,7 +3954,6 @@ let type_interface ~sourcefile modulename env ast = if !Clflags.as_parameter && !Clflags.parameters <> [] then begin error Compiling_as_parameterised_parameter end; - register_params !Clflags.parameters; if !Clflags.binary_annotations_cms then begin let uid = Shape.Uid.of_compilation_unit_id modulename in cms_register_toplevel_signature_attributes ~uid ~sourcefile ast diff --git a/typing/typemode.ml b/typing/typemode.ml index 8cbd18650c7..474f7e524df 100644 --- a/typing/typemode.ml +++ b/typing/typemode.ml @@ -51,6 +51,8 @@ module Axis_pair = struct | "external64" -> Any_axis_pair (Nonmodal Externality, Externality.External64) | "external_" -> Any_axis_pair (Nonmodal Externality, Externality.External) + | "yielding" -> Any_axis_pair (Modal Yielding, Yielding.Const.Yielding) + | "unyielding" -> Any_axis_pair (Modal Yielding, Yielding.Const.Unyielding) | _ -> raise Not_found end @@ -116,7 +118,8 @@ let transl_mode_annots annots : Alloc.Const.Option.t = linearity = modes.linearity; uniqueness = modes.uniqueness; portability = modes.portability; - contention = modes.contention + contention = modes.contention; + yielding = modes.yielding } let untransl_mode_annots ~loc (modes : Mode.Alloc.Const.Option.t) = @@ -134,9 +137,10 @@ let untransl_mode_annots ~loc (modes : Mode.Alloc.Const.Option.t) = let contention = print_to_string_opt Mode.Contention.Const.print modes.contention in + let yielding = print_to_string_opt Mode.Yielding.Const.print modes.yielding in List.filter_map (fun x -> Option.map (fun s -> { txt = Parsetree.Mode s; loc }) x) - [areality; uniqueness; linearity; portability; contention] + [areality; uniqueness; linearity; portability; contention; yielding] let transl_modality ~maturity { txt = Parsetree.Modality modality; loc } = let axis_pair = @@ -155,6 +159,8 @@ let transl_modality ~maturity { txt = Parsetree.Modality modality; loc } = Modality.Atom (Comonadic Portability, Meet_with mode) | Modal_axis_pair (Contention, mode) -> Modality.Atom (Monadic Contention, Join_with mode) + | Modal_axis_pair (Yielding, mode) -> + Modality.Atom (Comonadic Yielding, Meet_with mode) let untransl_modality (a : Modality.t) : Parsetree.modality loc = let s = @@ -174,6 +180,9 @@ let untransl_modality (a : Modality.t) : Parsetree.modality loc = | Atom (Monadic Contention, Join_with Contention.Const.Shared) -> "shared" | Atom (Monadic Contention, Join_with Contention.Const.Uncontended) -> "uncontended" + | Atom (Comonadic Yielding, Meet_with Yielding.Const.Yielding) -> "yielding" + | Atom (Comonadic Yielding, Meet_with Yielding.Const.Unyielding) -> + "unyielding" | _ -> failwith "BUG: impossible modality atom" in { txt = Modality s; loc = Location.none } @@ -188,7 +197,8 @@ let mutable_implied_modalities (mut : Types.mutability) attrs = let comonadic : Modality.t list = [ Atom (Comonadic Areality, Meet_with Regionality.Const.legacy); Atom (Comonadic Linearity, Meet_with Linearity.Const.legacy); - Atom (Comonadic Portability, Meet_with Portability.Const.legacy) ] + Atom (Comonadic Portability, Meet_with Portability.Const.legacy); + Atom (Comonadic Yielding, Meet_with Yielding.Const.legacy) ] in let monadic : Modality.t list = [ Atom (Monadic Uniqueness, Join_with Uniqueness.Const.legacy); diff --git a/typing/typeopt.ml b/typing/typeopt.ml index f76557ed36e..75389569b84 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -228,7 +228,7 @@ let array_kind_of_elt ~elt_sort env loc ty = (type_legacy_sort ~why:Array_element env loc ty) in let classify_product ty sorts = - if Language_extension.(is_at_least Layouts Alpha) then + if Language_extension.(is_at_least Layouts Beta) then if is_always_gc_ignorable env ty then Pgcignorableproductarray (ignorable_product_array_kind loc sorts) else diff --git a/utils/clflags.ml b/utils/clflags.ml index f872c4d3a17..7b4c20d4206 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -208,6 +208,7 @@ let pic_code = ref (match Config.architecture with (* -fPIC *) | _ -> false) let runtime_variant = ref "" +let ocamlrunparam = ref "" let with_runtime = ref true (* -with-runtime *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 4354fbeb9c0..363c80ea0e4 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -198,6 +198,7 @@ val shared : bool ref val dlcode : bool ref val pic_code : bool ref val runtime_variant : string ref +val ocamlrunparam : string ref val with_runtime : bool ref val force_slash : bool ref val keep_docs : bool ref diff --git a/utils/config.common.ml.in b/utils/config.common.ml.in index 451bf5bf4fe..d27caf1e53d 100644 --- a/utils/config.common.ml.in +++ b/utils/config.common.ml.in @@ -46,6 +46,7 @@ and cfg_magic_number = {magic|@CFG_MAGIC_NUMBER@|magic} let safe_string = true let default_safe_string = true +let naked_pointers = false let flambda_backend = true let interface_suffix = ref ".mli" diff --git a/utils/config.generated.ml.in b/utils/config.generated.ml.in index 8776576dfde..6bce93b3905 100644 --- a/utils/config.generated.ml.in +++ b/utils/config.generated.ml.in @@ -97,7 +97,6 @@ let flexdll_dirs = [@flexdll_dir@] let ar_supports_response_files = @ar_supports_response_files@ -let naked_pointers = "@naked_pointers@" = "true" let runtime5 = "@enable_runtime5@" = "yes" let reserved_header_bits = diff --git a/utils/doubly_linked_list.ml b/utils/doubly_linked_list.ml index b4a1f7c37ca..7f6efc2ebd7 100644 --- a/utils/doubly_linked_list.ml +++ b/utils/doubly_linked_list.ml @@ -333,12 +333,20 @@ let exists t ~f = aux t f t.first let for_all t ~f = - let rec aux t f curr = + let rec aux f curr = match curr with | Empty -> true - | Node node -> if f node.value then aux t f node.next else false + | Node node -> if f node.value then aux f node.next else false in - aux t f t.first + aux f t.first + +let for_alli t ~f = + let rec aux f i curr = + match curr with + | Empty -> true + | Node node -> if f i node.value then aux f (i + 1) node.next else false + in + aux f 0 t.first let to_list t = fold_right t ~f:(fun hd tl -> hd :: tl) ~init:[] diff --git a/utils/doubly_linked_list.mli b/utils/doubly_linked_list.mli index a2f406aff4b..32d572f7a73 100644 --- a/utils/doubly_linked_list.mli +++ b/utils/doubly_linked_list.mli @@ -78,6 +78,8 @@ val exists : 'a t -> f:('a -> bool) -> bool val for_all : 'a t -> f:('a -> bool) -> bool +val for_alli : 'a t -> f:(int -> 'a -> bool) -> bool + val to_list : 'a t -> 'a list (* Adds all of the elements of `from` to `to_`, and clears `from`. *) diff --git a/utils/runtimetags.ml b/utils/runtimetags.ml index 6199e684329..e04a889daad 100644 --- a/utils/runtimetags.ml +++ b/utils/runtimetags.ml @@ -33,3 +33,4 @@ let custom_tag = 255 let int_tag = 1000 let out_of_heap_tag = 1001 let unaligned_tag = 1002 +let null_tag = 1010 diff --git a/utils/runtimetags.mli b/utils/runtimetags.mli index 39baa09b975..5dd53b58510 100644 --- a/utils/runtimetags.mli +++ b/utils/runtimetags.mli @@ -30,3 +30,4 @@ val custom_tag : int val int_tag : int val out_of_heap_tag : int val unaligned_tag : int +val null_tag : int diff --git a/utils/symbol.ml b/utils/symbol.ml index 6eef6085b35..d68d14dcee2 100644 --- a/utils/symbol.ml +++ b/utils/symbol.ml @@ -69,7 +69,7 @@ let this_is_ocamlc () = this_is_ocamlc := true let force_runtime4_symbols () = force_runtime4_symbols := true let pack_separator = separator -let instance_separator = "___" +let instance_separator = "____" let instance_separator_depth_char = '_' let member_separator = separator