diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml index 93fdc4bdc83..87398c9785b 100644 --- a/asmcomp/cmm_helpers.ml +++ b/asmcomp/cmm_helpers.ml @@ -790,12 +790,22 @@ let int_array_ref arr ofs dbg = let unboxed_float_array_ref arr ofs dbg = Cop(Cload (Double, Mutable), [array_indexing log2_size_float arr ofs dbg], dbg) -let float_array_ref arr ofs dbg = - box_float dbg Lambda.alloc_heap (unboxed_float_array_ref arr ofs dbg) +let float_array_ref mode arr ofs dbg = + box_float dbg mode (unboxed_float_array_ref arr ofs dbg) -let addr_array_set arr ofs newval dbg = +let addr_array_set_heap arr ofs newval dbg = Cop(Cextcall("caml_modify", typ_void, [], false), [array_indexing log2_size_addr arr ofs dbg; newval], dbg) + +let addr_array_set_local arr ofs newval dbg = + Cop(Cextcall("caml_modify_local", typ_void, [], false), + [arr; untag_int ofs dbg; newval], dbg) + +let addr_array_set (mode : Lambda.modify_mode) arr ofs newval dbg = + match mode with + | Modify_heap -> addr_array_set_heap arr ofs newval dbg + | Modify_maybe_stack -> addr_array_set_local arr ofs newval dbg +(* int and float arrays can be written to uniformly regardless of their mode *) let int_array_set arr ofs newval dbg = Cop(Cstore (Word_int, Assignment), [array_indexing log2_size_addr arr ofs dbg; newval], dbg) @@ -803,10 +813,6 @@ let float_array_set arr ofs newval dbg = Cop(Cstore (Double, Assignment), [array_indexing log2_size_float arr ofs dbg; newval], dbg) -let addr_array_set_local arr ofs newval dbg = - Cop(Cextcall("caml_modify_local", typ_void, [], false), - [arr; untag_int ofs dbg; newval], dbg) - let addr_array_initialize arr ofs newval dbg = Cop(Cextcall("caml_initialize", typ_void, [], false), [array_indexing log2_size_addr arr ofs dbg; newval], dbg) @@ -2748,28 +2754,28 @@ let bigstring_load size unsafe mode arg1 arg2 dbg = idx (unaligned_load size ba_data idx dbg))))) -let arrayref_unsafe kind arg1 arg2 dbg = - match (kind : Lambda.array_kind) with - | Pgenarray -> +let arrayref_unsafe rkind arg1 arg2 dbg = + match (rkind : Lambda.array_ref_kind) with + | Pgenarray_ref mode -> bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> Cifthenelse(is_addr_array_ptr arr dbg, dbg, addr_array_ref arr idx dbg, dbg, - float_array_ref arr idx dbg, + float_array_ref mode arr idx dbg, dbg, Any))) - | Paddrarray -> + | Paddrarray_ref -> addr_array_ref arg1 arg2 dbg - | Pintarray -> + | Pintarray_ref -> (* CR mshinwell: for int/addr_array_ref move "dbg" to first arg *) int_array_ref arg1 arg2 dbg - | Pfloatarray -> - float_array_ref arg1 arg2 dbg + | Pfloatarray_ref mode -> + float_array_ref mode arg1 arg2 dbg -let arrayref_safe kind arg1 arg2 dbg = - match (kind : Lambda.array_kind) with - | Pgenarray -> +let arrayref_safe rkind arg1 arg2 dbg = + match (rkind : Lambda.array_ref_kind) with + | Pgenarray_ref mode -> bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> bind "header" (get_header_without_profinfo arr dbg) (fun hdr -> @@ -2780,7 +2786,7 @@ let arrayref_safe kind arg1 arg2 dbg = dbg, addr_array_ref arr idx dbg, dbg, - float_array_ref arr idx dbg, + float_array_ref mode arr idx dbg, dbg, Any)) else Cifthenelse(is_addr_array_hdr hdr dbg, @@ -2791,34 +2797,34 @@ let arrayref_safe kind arg1 arg2 dbg = dbg, Csequence( make_checkbound dbg [float_array_length_shifted hdr dbg; idx], - float_array_ref arr idx dbg), + float_array_ref mode arr idx dbg), dbg, Any)))) - | Paddrarray -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence( - make_checkbound dbg [ - addr_array_length_shifted - (get_header_without_profinfo arr dbg) dbg; idx], - addr_array_ref arr idx dbg))) - | Pintarray -> - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence( - make_checkbound dbg [ - addr_array_length_shifted - (get_header_without_profinfo arr dbg) dbg; idx], - int_array_ref arr idx dbg))) - | Pfloatarray -> - box_float dbg Lambda.alloc_heap ( - bind "index" arg2 (fun idx -> - bind "arr" arg1 (fun arr -> - Csequence( - make_checkbound dbg [ - float_array_length_shifted - (get_header_without_profinfo arr dbg) dbg; - idx], - unboxed_float_array_ref arr idx dbg)))) + | Paddrarray_ref -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + addr_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; idx], + addr_array_ref arr idx dbg))) + | Pintarray_ref -> + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + addr_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; idx], + int_array_ref arr idx dbg))) + | Pfloatarray_ref mode -> + box_float dbg mode ( + bind "index" arg2 (fun idx -> + bind "arr" arg1 (fun arr -> + Csequence( + make_checkbound dbg [ + float_array_length_shifted + (get_header_without_profinfo arr dbg) dbg; + idx], + unboxed_float_array_ref arr idx dbg)))) type ternary_primitive = expression -> expression -> expression -> Debuginfo.t -> expression @@ -2826,7 +2832,7 @@ type ternary_primitive = let setfield_computed ptr init arg1 arg2 arg3 dbg = match assignment_kind ptr init with | Caml_modify -> - return_unit dbg (addr_array_set arg1 arg2 arg3 dbg) + return_unit dbg (addr_array_set_heap arg1 arg2 arg3 dbg) | Caml_modify_local -> return_unit dbg (addr_array_set_local arg1 arg2 arg3 dbg) | Caml_initialize -> @@ -2850,30 +2856,30 @@ let bytesset_safe arg1 arg2 arg3 dbg = [add_int str idx dbg; newval], dbg)))))) -let arrayset_unsafe kind arg1 arg2 arg3 dbg = - return_unit dbg (match (kind: Lambda.array_kind) with - | Pgenarray -> +let arrayset_unsafe skind arg1 arg2 arg3 dbg = + return_unit dbg (match (skind: Lambda.array_set_kind) with + | Pgenarray_set mode -> bind "newval" arg3 (fun newval -> bind "index" arg2 (fun index -> bind "arr" arg1 (fun arr -> Cifthenelse(is_addr_array_ptr arr dbg, dbg, - addr_array_set arr index newval dbg, + addr_array_set mode arr index newval dbg, dbg, float_array_set arr index (unbox_float dbg newval) dbg, dbg, Any)))) - | Paddrarray -> - addr_array_set arg1 arg2 arg3 dbg - | Pintarray -> + | Paddrarray_set mode -> + addr_array_set mode arg1 arg2 arg3 dbg + | Pintarray_set -> int_array_set arg1 arg2 arg3 dbg - | Pfloatarray -> + | Pfloatarray_set -> float_array_set arg1 arg2 arg3 dbg ) -let arrayset_safe kind arg1 arg2 arg3 dbg = - return_unit dbg (match (kind: Lambda.array_kind) with - | Pgenarray -> +let arrayset_safe skind arg1 arg2 arg3 dbg = + return_unit dbg (match (skind: Lambda.array_set_kind) with + | Pgenarray_set mode -> bind "newval" arg3 (fun newval -> bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> @@ -2883,7 +2889,7 @@ let arrayset_safe kind arg1 arg2 arg3 dbg = make_checkbound dbg [addr_array_length_shifted hdr dbg; idx], Cifthenelse(is_addr_array_hdr hdr dbg, dbg, - addr_array_set arr idx newval dbg, + addr_array_set mode arr idx newval dbg, dbg, float_array_set arr idx (unbox_float dbg newval) @@ -2895,14 +2901,14 @@ let arrayset_safe kind arg1 arg2 arg3 dbg = dbg, Csequence( make_checkbound dbg [addr_array_length_shifted hdr dbg; idx], - addr_array_set arr idx newval dbg), + addr_array_set mode arr idx newval dbg), dbg, Csequence( make_checkbound dbg [float_array_length_shifted hdr dbg; idx], float_array_set arr idx (unbox_float dbg newval) dbg), dbg, Any))))) - | Paddrarray -> + | Paddrarray_set mode -> bind "newval" arg3 (fun newval -> bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> @@ -2911,8 +2917,8 @@ let arrayset_safe kind arg1 arg2 arg3 dbg = addr_array_length_shifted (get_header_without_profinfo arr dbg) dbg; idx], - addr_array_set arr idx newval dbg)))) - | Pintarray -> + addr_array_set mode arr idx newval dbg)))) + | Pintarray_set -> bind "newval" arg3 (fun newval -> bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> @@ -2922,7 +2928,7 @@ let arrayset_safe kind arg1 arg2 arg3 dbg = (get_header_without_profinfo arr dbg) dbg; idx], int_array_set arr idx newval dbg)))) - | Pfloatarray -> + | Pfloatarray_set -> bind_load "newval" arg3 (fun newval -> bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> diff --git a/asmcomp/cmm_helpers.mli b/asmcomp/cmm_helpers.mli index c96329ba47f..d3829e2ac9c 100644 --- a/asmcomp/cmm_helpers.mli +++ b/asmcomp/cmm_helpers.mli @@ -265,11 +265,15 @@ val addr_array_ref : expression -> expression -> Debuginfo.t -> expression val int_array_ref : expression -> expression -> Debuginfo.t -> expression val unboxed_float_array_ref : expression -> expression -> Debuginfo.t -> expression -val float_array_ref : expression -> expression -> Debuginfo.t -> expression -val addr_array_set : +val float_array_ref : + Lambda.alloc_mode -> expression -> expression -> Debuginfo.t -> expression +val addr_array_set_heap : expression -> expression -> expression -> Debuginfo.t -> expression val addr_array_set_local : expression -> expression -> expression -> Debuginfo.t -> expression +val addr_array_set : + Lambda.modify_mode -> expression -> expression -> expression -> Debuginfo.t -> + expression val int_array_set : expression -> expression -> expression -> Debuginfo.t -> expression val float_array_set : @@ -555,9 +559,9 @@ val bigstring_load : (** Arrays *) -(** Array access. Args: array, index *) -val arrayref_unsafe : Lambda.array_kind -> binary_primitive -val arrayref_safe : Lambda.array_kind -> binary_primitive +(** Array access. Args: array, index *) +val arrayref_unsafe : Lambda.array_ref_kind -> binary_primitive +val arrayref_safe : Lambda.array_ref_kind -> binary_primitive type ternary_primitive = expression -> expression -> expression -> Debuginfo.t -> expression @@ -578,8 +582,8 @@ val bytesset_safe : ternary_primitive _unboxed_ float. Otherwise, it is expected to be a regular caml value, including in the case where the array contains floats. Args: array, index, value *) -val arrayset_unsafe : Lambda.array_kind -> ternary_primitive -val arrayset_safe : Lambda.array_kind -> ternary_primitive +val arrayset_unsafe : Lambda.array_set_kind -> ternary_primitive +val arrayset_safe : Lambda.array_set_kind -> ternary_primitive (** Set a chunk of data in the given bytes or bigstring structure. See also [string_load] and [bigstring_load]. diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 03eb963d864..616d86a5152 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1067,10 +1067,10 @@ and transl_prim_2 env p arg1 arg2 dbg = bigstring_load size unsafe mode (transl env arg1) (transl env arg2) dbg (* Array operations *) - | Parrayrefu kind -> - arrayref_unsafe kind (transl env arg1) (transl env arg2) dbg - | Parrayrefs kind -> - arrayref_safe kind (transl env arg1) (transl env arg2) dbg + | Parrayrefu rkind -> + arrayref_unsafe rkind (transl env arg1) (transl env arg2) dbg + | Parrayrefs rkind -> + arrayref_safe rkind (transl env arg1) (transl env arg2) dbg (* Boxed integers *) | Paddbint (bi, mode) -> @@ -1155,20 +1155,20 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg = (transl env arg1) (transl env arg2) (transl env arg3) dbg (* Array operations *) - | Parraysetu kind -> + | Parraysetu skind -> let newval = - match kind with - | Pfloatarray -> transl_unbox_float dbg env arg3 + match skind with + | Pfloatarray_set -> transl_unbox_float dbg env arg3 | _ -> transl env arg3 in - arrayset_unsafe kind (transl env arg1) (transl env arg2) newval dbg - | Parraysets kind -> + arrayset_unsafe skind (transl env arg1) (transl env arg2) newval dbg + | Parraysets skind -> let newval = - match kind with - | Pfloatarray -> transl_unbox_float dbg env arg3 + match skind with + | Pfloatarray_set -> transl_unbox_float dbg env arg3 | _ -> transl env arg3 in - arrayset_safe kind (transl env arg1) (transl env arg2) newval dbg + arrayset_safe skind (transl env arg1) (transl env arg2) newval dbg | Pbytes_set(size, unsafe) -> bytes_set size unsafe (transl env arg1) (transl env arg2) diff --git a/boot/ocamlc b/boot/ocamlc index 42a2331afef..658409231c0 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index cb13b7e60c5..615aff5832e 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index d2268155244..c3130582a5f 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -454,18 +454,23 @@ let comp_primitive p args = | Pbytes_load_32(_) -> Kccall("caml_bytes_get32", 2) | Pbytes_load_64(_) -> Kccall("caml_bytes_get64", 2) | Parraylength _ -> Kvectlength - | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2) - | Parrayrefs Pfloatarray -> Kccall("caml_floatarray_get", 2) - | Parrayrefs _ -> Kccall("caml_array_get_addr", 2) - | Parraysets Pgenarray -> Kccall("caml_array_set", 3) - | Parraysets Pfloatarray -> Kccall("caml_floatarray_set", 3) - | Parraysets _ -> Kccall("caml_array_set_addr", 3) - | Parrayrefu Pgenarray -> Kccall("caml_array_unsafe_get", 2) - | Parrayrefu Pfloatarray -> Kccall("caml_floatarray_unsafe_get", 2) - | Parrayrefu _ -> Kgetvectitem - | Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3) - | Parraysetu Pfloatarray -> Kccall("caml_floatarray_unsafe_set", 3) - | Parraysetu _ -> Ksetvectitem + (* In bytecode, nothing is ever actually stack-allocated, so we ignore the + array modes (allocation for [Parrayref{s,u}], modification for + [Parrayset{s,u}]). *) + | Parrayrefs (Pgenarray_ref _) -> Kccall("caml_array_get", 2) + | Parrayrefs (Pfloatarray_ref _) -> Kccall("caml_floatarray_get", 2) + | Parrayrefs (Paddrarray_ref | Pintarray_ref) -> + Kccall("caml_array_get_addr", 2) + | Parraysets (Pgenarray_set _) -> Kccall("caml_array_set", 3) + | Parraysets Pfloatarray_set -> Kccall("caml_floatarray_set", 3) + | Parraysets (Paddrarray_set _ | Pintarray_set) -> + Kccall("caml_array_set_addr", 3) + | Parrayrefu (Pgenarray_ref _) -> Kccall("caml_array_unsafe_get", 2) + | Parrayrefu (Pfloatarray_ref _) -> Kccall("caml_floatarray_unsafe_get", 2) + | Parrayrefu (Paddrarray_ref | Pintarray_ref) -> Kgetvectitem + | Parraysetu (Pgenarray_set _) -> Kccall("caml_array_unsafe_set", 3) + | Parraysetu Pfloatarray_set -> Kccall("caml_floatarray_unsafe_set", 3) + | Parraysetu (Paddrarray_set _ | Pintarray_set) -> Ksetvectitem | Pctconst c -> let const_name = match c with | Big_endian -> "big_endian" diff --git a/lambda/lambda.ml b/lambda/lambda.ml index 09029793cbc..adc30eec738 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -176,10 +176,10 @@ type primitive = | Pmakearray of array_kind * mutable_flag * alloc_mode | Pduparray of array_kind * mutable_flag | Parraylength of array_kind - | Parrayrefu of array_kind - | Parraysetu of array_kind - | Parrayrefs of array_kind - | Parraysets of array_kind + | Parrayrefu of array_ref_kind + | Parraysetu of array_set_kind + | Parrayrefs of array_ref_kind + | Parraysets of array_set_kind (* Test if the argument is a block or an immediate integer *) | Pisint of { variant_only : bool } (* Test if the (integer) argument is outside an interval *) @@ -274,6 +274,18 @@ and block_shape = and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray +and array_ref_kind = + | Pgenarray_ref of alloc_mode + | Paddrarray_ref + | Pintarray_ref + | Pfloatarray_ref of alloc_mode + +and array_set_kind = + | Pgenarray_set of modify_mode + | Paddrarray_set of modify_mode + | Pintarray_set + | Pfloatarray_set + and boxed_integer = Primitive.boxed_integer = Pnativeint | Pint32 | Pint64 @@ -1355,12 +1367,10 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pduparray _ -> Some alloc_heap | Parraylength _ -> None | Parraysetu _ | Parraysets _ - | Parrayrefu (Paddrarray|Pintarray) - | Parrayrefs (Paddrarray|Pintarray) -> None - | Parrayrefu (Pgenarray|Pfloatarray) - | Parrayrefs (Pgenarray|Pfloatarray) -> - (* The float box from flat floatarray access is always Alloc_heap *) - Some alloc_heap + | Parrayrefu (Paddrarray_ref | Pintarray_ref) + | Parrayrefs (Paddrarray_ref | Pintarray_ref) -> None + | Parrayrefu (Pgenarray_ref m | Pfloatarray_ref m) + | Parrayrefs (Pgenarray_ref m | Pfloatarray_ref m) -> Some m | Pisint _ | Pisout -> None | Pintofbint _ -> None | Pbintofint (_,m) @@ -1449,11 +1459,11 @@ let primitive_result_layout (p : primitive) = | Pstring_load_16 _ | Pbytes_load_16 _ | Pbigstring_load_16 _ | Pprobe_is_enabled _ | Pbswap16 -> layout_int - | Parrayrefu array_kind | Parrayrefs array_kind -> - (match array_kind with - | Pintarray -> layout_int - | Pfloatarray -> layout_float - | Pgenarray | Paddrarray -> layout_field) + | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> + (match array_ref_kind with + | Pintarray_ref -> layout_int + | Pfloatarray_ref _ -> layout_float + | Pgenarray_ref _ | Paddrarray_ref -> layout_field) | Pbintofint (bi, _) | Pcvtbint (_,bi,_) | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _) | Pmulbint (bi, _) | Pdivbint {size = bi} | Pmodbint {size = bi} @@ -1528,3 +1538,15 @@ let compute_expr_layout free_vars_kind lam = | Lexclave e -> compute_expr_layout kinds e in compute_expr_layout Ident.Map.empty lam + +let array_ref_kind mode = function + | Pgenarray -> Pgenarray_ref mode + | Paddrarray -> Paddrarray_ref + | Pintarray -> Pintarray_ref + | Pfloatarray -> Pfloatarray_ref mode + +let array_set_kind mode = function + | Pgenarray -> Pgenarray_set mode + | Paddrarray -> Paddrarray_set mode + | Pintarray -> Pintarray_set + | Pfloatarray -> Pfloatarray_set diff --git a/lambda/lambda.mli b/lambda/lambda.mli index f368fae0720..cf4809d63fe 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -127,10 +127,10 @@ type primitive = The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) | Parraylength of array_kind - | Parrayrefu of array_kind - | Parraysetu of array_kind - | Parrayrefs of array_kind - | Parraysets of array_kind + | Parrayrefu of array_ref_kind + | Parraysetu of array_set_kind + | Parrayrefs of array_ref_kind + | Parraysets of array_set_kind (* Test if the argument is a block or an immediate integer *) | Pisint of { variant_only : bool } (* Test if the (integer) argument is outside an interval *) @@ -209,6 +209,22 @@ and float_comparison = and array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray +(** When accessing a flat float array, we need to know the mode which we should + box the resulting float at. *) +and array_ref_kind = + | Pgenarray_ref of alloc_mode (* This might be a flat float array *) + | Paddrarray_ref + | Pintarray_ref + | Pfloatarray_ref of alloc_mode + +(** When updating an array that might contain pointers, we need to know what + mode they're at; otherwise, access is uniform. *) +and array_set_kind = + | Pgenarray_set of modify_mode (* This might be an array of pointers *) + | Paddrarray_set of modify_mode + | Pintarray_set + | Pfloatarray_set + and value_kind = Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval | Pvariant of { @@ -670,3 +686,9 @@ val structured_constant_layout : structured_constant -> layout val primitive_result_layout : primitive -> layout val compute_expr_layout : (Ident.t -> layout option) -> lambda -> layout + +(** The mode will be discarded if unnecessary for the given [array_kind] *) +val array_ref_kind : alloc_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 diff --git a/lambda/matching.ml b/lambda/matching.ml index 13ef33d0fa3..ff0208bfc24 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -2174,7 +2174,11 @@ let get_expr_args_array ~scopes kind head (arg, _mut, _layout) rem = else (* CR ncourant: could do better than layout_field using kind *) ( Lprim - (Parrayrefu kind, [ arg; Lconst (Const_base (Const_int pos)) ], loc), + (* TODO: The resulting float should be allocated to at the mode of the + array pattern, once that's available *) + (Parrayrefu Lambda.(array_ref_kind alloc_heap kind), + [ arg; Lconst (Const_base (Const_int pos)) ], + loc), (match am with | Mutable -> StrictOpt | Immutable -> Alias), diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 3cb44d1579c..9f6b1aaac15 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -54,6 +54,28 @@ let array_kind = function | Pintarray -> "int" | Pfloatarray -> "float" +let array_ref_kind ppf k = + let pp_mode ppf = function + | Alloc_heap -> () + | Alloc_local -> fprintf ppf "(local)" + in + match k with + | Pgenarray_ref mode -> fprintf ppf "gen%a" pp_mode mode + | Paddrarray_ref -> fprintf ppf "addr" + | Pintarray_ref -> fprintf ppf "int" + | Pfloatarray_ref mode -> fprintf ppf "float%a" pp_mode mode + +let array_set_kind ppf k = + let pp_mode ppf = function + | Modify_heap -> () + | Modify_maybe_stack -> fprintf ppf "(local)" + in + match k with + | Pgenarray_set mode -> fprintf ppf "gen%a" pp_mode mode + | Paddrarray_set mode -> fprintf ppf "addr%a" pp_mode mode + | Pintarray_set -> fprintf ppf "int" + | Pfloatarray_set -> fprintf ppf "float" + let alloc_mode = function | Alloc_heap -> "" | Alloc_local -> "local" @@ -345,10 +367,10 @@ let primitive ppf = function | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) | Pduparray (k, Immutable_unique) -> fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) - | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) - | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) - | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) + | Parrayrefu rk -> fprintf ppf "array.unsafe_get[%a]" array_ref_kind rk + | Parraysetu sk -> fprintf ppf "array.unsafe_set[%a]" array_set_kind sk + | Parrayrefs rk -> fprintf ppf "array.get[%a]" array_ref_kind rk + | Parraysets sk -> fprintf ppf "array.set[%a]" array_set_kind sk | Pctconst c -> let const_name = match c with | Big_endian -> "big_endian" diff --git a/lambda/transl_array_comprehension.ml b/lambda/transl_array_comprehension.ml index dda421bd072..4277e8e4a46 100644 --- a/lambda/transl_array_comprehension.ml +++ b/lambda/transl_array_comprehension.ml @@ -495,7 +495,8 @@ let iterator ~transl_exp ~scopes ~loc Matching.for_let ~scopes pattern.pat_loc - (Lprim(Parrayrefu iter_arr_kind, + (Lprim(Parrayrefu + Lambda.(array_ref_kind alloc_heap iter_arr_kind), [iter_arr.var; Lvar iter_ix], loc)) pattern @@ -756,7 +757,9 @@ let body let open Let_binding in let set_element_raw elt = (* array.(index) <- elt *) - Lprim(Parraysetu array_kind, [array.var; index.var; elt], loc) + Lprim(Parraysetu Lambda.(array_set_kind modify_heap array_kind), + [array.var; index.var; elt], + loc) in let set_element_in_bounds elt = match array_sizing with | Fixed_size -> diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 195f2e9f832..c3a87af2a8c 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -114,6 +114,12 @@ let get_units_with_used_primitives () = let gen_array_kind = if Config.flat_float_array then Pgenarray else Paddrarray +let gen_array_ref_kind mode = + if Config.flat_float_array then Pgenarray_ref mode else Paddrarray_ref + +let gen_array_set_kind mode = + if Config.flat_float_array then Pgenarray_set mode else Paddrarray_set mode + let prim_sys_argv = Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true @@ -136,6 +142,13 @@ let to_modify_mode ~poly = function let lookup_primitive loc poly pos p = let mode = to_alloc_mode ~poly p.prim_native_repr_res in let arg_modes = List.map (to_modify_mode ~poly) p.prim_native_repr_args in + let get_first_arg_mode () = + match arg_modes with + | mode :: _ -> mode + | [] -> + Misc.fatal_errorf "Primitive \"%s\" unexpectedly had zero arguments" + p.prim_name + in let prim = match p.prim_name with | "%identity" -> Identity | "%bytes_to_string" -> Primitive (Pbytes_to_string, 1) @@ -154,12 +167,8 @@ let lookup_primitive loc poly pos p = | "%field0_immut" -> Primitive ((Pfield (0, Reads_agree)), 1) | "%field1_immut" -> Primitive ((Pfield (1, Reads_agree)), 1) | "%setfield0" -> - let mode = - match arg_modes with - | mode :: _ -> Assignment mode - | [] -> assert false - in - Primitive ((Psetfield(0, Pointer, mode)), 2) + let mode = get_first_arg_mode () in + Primitive ((Psetfield(0, Pointer, Assignment mode)), 2) | "%makeblock" -> Primitive ((Pmakeblock(0, Immutable, None, mode)), 1) | "%makemutable" -> Primitive ((Pmakeblock(0, Mutable, None, mode)), 1) | "%raise" -> Raise Raise_regular @@ -225,18 +234,23 @@ let lookup_primitive loc poly pos p = | "%bytes_unsafe_get" -> Primitive (Pbytesrefu, 2) | "%bytes_unsafe_set" -> Primitive (Pbytessetu, 3) | "%array_length" -> Primitive ((Parraylength gen_array_kind), 1) - | "%array_safe_get" -> Primitive ((Parrayrefs gen_array_kind), 2) - | "%array_safe_set" -> Primitive ((Parraysets gen_array_kind), 3) - | "%array_unsafe_get" -> Primitive ((Parrayrefu gen_array_kind), 2) - | "%array_unsafe_set" -> Primitive ((Parraysetu gen_array_kind), 3) - | "%obj_size" -> Primitive ((Parraylength gen_array_kind), 1) - | "%obj_field" -> Primitive ((Parrayrefu gen_array_kind), 2) - | "%obj_set_field" -> Primitive ((Parraysetu gen_array_kind), 3) + | "%array_safe_get" -> Primitive ((Parrayrefs (gen_array_ref_kind mode)), 2) + | "%array_safe_set" -> + Primitive (Parraysets (gen_array_set_kind (get_first_arg_mode ())), 3) + | "%array_unsafe_get" -> Primitive (Parrayrefu (gen_array_ref_kind mode), 2) + | "%array_unsafe_set" -> + Primitive ((Parraysetu (gen_array_set_kind (get_first_arg_mode ()))), 3) + | "%obj_size" -> Primitive ((Parraylength Pgenarray), 1) + | "%obj_field" -> Primitive ((Parrayrefu (Pgenarray_ref mode)), 2) + | "%obj_set_field" -> + Primitive ((Parraysetu (Pgenarray_set (get_first_arg_mode ()))), 3) | "%floatarray_length" -> Primitive ((Parraylength Pfloatarray), 1) - | "%floatarray_safe_get" -> Primitive ((Parrayrefs Pfloatarray), 2) - | "%floatarray_safe_set" -> Primitive ((Parraysets Pfloatarray), 3) - | "%floatarray_unsafe_get" -> Primitive ((Parrayrefu Pfloatarray), 2) - | "%floatarray_unsafe_set" -> Primitive ((Parraysetu Pfloatarray), 3) + | "%floatarray_safe_get" -> + Primitive ((Parrayrefs (Pfloatarray_ref mode)), 2) + | "%floatarray_safe_set" -> Primitive (Parraysets Pfloatarray_set, 3) + | "%floatarray_unsafe_get" -> + Primitive ((Parrayrefu (Pfloatarray_ref mode)), 2) + | "%floatarray_unsafe_set" -> Primitive ((Parraysetu Pfloatarray_set), 3) | "%obj_is_int" -> Primitive (Pisint { variant_only = false }, 1) | "%lazy_force" -> Lazy_force pos | "%nativeint_of_int" -> Primitive ((Pbintofint (Pnativeint, mode)), 1) @@ -435,14 +449,68 @@ let simplify_constant_constructor = function *) let glb_array_type t1 t2 = match t1, t2 with + (* No GLB; only used in the [Obj.magic] case *) | Pfloatarray, (Paddrarray | Pintarray) | (Paddrarray | Pintarray), Pfloatarray -> t1 + (* Compute the correct GLB *) | Pgenarray, x | x, Pgenarray -> x | Paddrarray, x | x, Paddrarray -> x | Pintarray, Pintarray -> Pintarray | Pfloatarray, Pfloatarray -> Pfloatarray +let glb_array_ref_type t1 t2 = + match t1, t2 with + (* No GLB; only used in the [Obj.magic] case *) + | Pfloatarray_ref _, (Paddrarray | Pintarray) + | (Paddrarray_ref | Pintarray_ref), Pfloatarray -> t1 + + (* Compute the correct GLB *) + + (* Pgenarray >= _ *) + | (Pgenarray_ref _ as x), Pgenarray -> x + | Pgenarray_ref _, Pintarray -> Pintarray_ref + | Pgenarray_ref _, Paddrarray -> Paddrarray_ref + | Pgenarray_ref mode, Pfloatarray -> Pfloatarray_ref mode + | (Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _ as x), Pgenarray -> x + + (* Paddrarray > Pintarray *) + | Paddrarray_ref, Paddrarray -> Paddrarray_ref + | Paddrarray_ref, Pintarray -> Pintarray_ref + | Pintarray_ref, Paddrarray -> Pintarray_ref + + (* Pintarray is a minimum *) + | Pintarray_ref, Pintarray -> Pintarray_ref + + (* Pfloatarray is a minimum *) + | (Pfloatarray_ref _ as x), Pfloatarray -> x + +let glb_array_set_type t1 t2 = + match t1, t2 with + (* No GLB; only used in the [Obj.magic] case *) + | Pfloatarray_set, (Paddrarray | Pintarray) + | (Paddrarray_set _ | Pintarray_set), Pfloatarray -> t1 + + (* Compute the correct GLB *) + + (* Pgenarray >= _ *) + | (Pgenarray_set _ as x), Pgenarray -> x + | Pgenarray_set _, Pintarray -> Pintarray_set + | Pgenarray_set mode, Paddrarray -> Paddrarray_set mode + | Pgenarray_set _, Pfloatarray -> Pfloatarray_set + | (Paddrarray_set _ | Pintarray_set | Pfloatarray_set as x), Pgenarray -> x + + (* Paddrarray > Pintarray *) + | (Paddrarray_set _ as x), Paddrarray -> x + | Paddrarray_set _, Pintarray -> Pintarray_set + | Pintarray_set, Paddrarray -> Pintarray_set + + (* Pintarray is a minimum *) + | Pintarray_set, Pintarray -> Pintarray_set + + (* Pfloatarray is a minimum *) + | Pfloatarray_set, Pfloatarray -> Pfloatarray_set + (* Specialize a primitive from available type information. *) (* CR layouts v2: This function had a loc argument added just to support the void check error message. Take it out when we remove that. *) @@ -466,25 +534,26 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = if t = array_type then None else Some (Primitive (Parraylength array_type, arity)) end - | Primitive (Parrayrefu t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parrayrefu array_type, arity)) + | Primitive (Parrayrefu rt, arity), p1 :: _ -> begin + let array_ref_type = glb_array_ref_type rt (array_type_kind env p1) + in + if rt = array_ref_type then None + else Some (Primitive (Parrayrefu array_ref_type, arity)) end - | Primitive (Parraysetu t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parraysetu array_type, arity)) + | Primitive (Parraysetu st, arity), p1 :: _ -> begin + let array_set_type = glb_array_set_type st (array_type_kind env p1) in + if st = array_set_type then None + else Some (Primitive (Parraysetu array_set_type, arity)) end - | Primitive (Parrayrefs t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parrayrefs array_type, arity)) + | Primitive (Parrayrefs rt, arity), p1 :: _ -> begin + let array_ref_type = glb_array_ref_type rt (array_type_kind env p1) in + if rt = array_ref_type then None + else Some (Primitive (Parrayrefs array_ref_type, arity)) end - | Primitive (Parraysets t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parraysets array_type, arity)) + | Primitive (Parraysets st, arity), p1 :: _ -> begin + let array_set_type = glb_array_set_type st (array_type_kind env p1) in + if st = array_set_type then None + else Some (Primitive (Parraysets array_set_type, arity)) end | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), arity), p1 :: _ -> begin @@ -866,7 +935,7 @@ let lambda_primitive_needs_event_after = function | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pstringrefs | Pbytesrefs | Pbox_float _ | Pbox_int _ | Pbytessets | Pmakearray (Pgenarray, _, _) | Pduparray _ - | Parrayrefu (Pgenarray | Pfloatarray) | Parraysetu (Pgenarray | Pfloatarray) + | Parrayrefu (Pgenarray_ref _ | Pfloatarray_ref _) | Parrayrefs _ | Parraysets _ | Pbintofint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint _ | Pmodbint _ | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ | Pbintcomp _ diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index 77e66745305..92725a7a771 100644 --- a/middle_end/clambda_primitives.ml +++ b/middle_end/clambda_primitives.ml @@ -32,6 +32,8 @@ type memory_access_size = type alloc_mode = Lambda.alloc_mode +type modify_mode = Lambda.modify_mode + type primitive = | Pread_symbol of string (* Operations on heap blocks *) @@ -74,10 +76,10 @@ type primitive = The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) | Parraylength of array_kind - | Parrayrefu of array_kind - | Parraysetu of array_kind - | Parrayrefs of array_kind - | Parraysets of array_kind + | Parrayrefu of array_ref_kind + | Parraysetu of array_set_kind + | Parrayrefs of array_ref_kind + | Parraysets of array_set_kind (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) @@ -136,6 +138,18 @@ and float_comparison = Lambda.float_comparison = and array_kind = Lambda.array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray +and array_ref_kind = Lambda.array_ref_kind = + | Pgenarray_ref of alloc_mode + | Paddrarray_ref + | Pintarray_ref + | Pfloatarray_ref of alloc_mode + +and array_set_kind = Lambda.array_set_kind = + | Pgenarray_set of modify_mode + | Paddrarray_set of modify_mode + | Pintarray_set + | Pfloatarray_set + and value_kind = Lambda.value_kind = (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli index e71b17c4c85..b65e674ee76 100644 --- a/middle_end/clambda_primitives.mli +++ b/middle_end/clambda_primitives.mli @@ -32,6 +32,8 @@ type memory_access_size = type alloc_mode = Lambda.alloc_mode +type modify_mode = Lambda.modify_mode + type primitive = | Pread_symbol of string (* Operations on heap blocks *) @@ -77,10 +79,10 @@ type primitive = The arguments of [Pduparray] give the kind and mutability of the array being *produced* by the duplication. *) | Parraylength of array_kind - | Parrayrefu of array_kind - | Parraysetu of array_kind - | Parrayrefs of array_kind - | Parraysets of array_kind + | Parrayrefu of array_ref_kind + | Parraysetu of array_set_kind + | Parrayrefs of array_ref_kind + | Parraysets of array_set_kind (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) @@ -139,6 +141,18 @@ and float_comparison = Lambda.float_comparison = and array_kind = Lambda.array_kind = Pgenarray | Paddrarray | Pintarray | Pfloatarray +and array_ref_kind = Lambda.array_ref_kind = + | Pgenarray_ref of alloc_mode + | Paddrarray_ref + | Pintarray_ref + | Pfloatarray_ref of alloc_mode + +and array_set_kind = Lambda.array_set_kind = + | Pgenarray_set of modify_mode + | Paddrarray_set of modify_mode + | Pintarray_set + | Pfloatarray_set + and value_kind = Lambda.value_kind = (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index a4c352d03fc..fd9b3615375 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -183,10 +183,10 @@ let prim_size prim args = | Pbytesrefs | Pbytessets -> 6 | Pmakearray _ -> 5 + List.length args | Parraylength kind -> if kind = Pgenarray then 6 else 2 - | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 - | Parraysetu kind -> if kind = Pgenarray then 16 else 4 - | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 - | Parraysets kind -> if kind = Pgenarray then 22 else 10 + | Parrayrefu kind -> (match kind with Pgenarray_ref _ -> 12 | _ -> 2) + | Parraysetu kind -> (match kind with Pgenarray_set _ -> 16 | _ -> 4) + | Parrayrefs kind -> (match kind with Pgenarray_ref _ -> 18 | _ -> 8) + | Parraysets kind -> (match kind with Pgenarray_set _ -> 22 | _ -> 10) | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 | Pprobe_is_enabled _ -> 4 (* Pgetglobal and a comparison *) diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 541af7ecf86..7cc2e8a324c 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -81,10 +81,10 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pmakearray (kind, mutability, mode) -> Pmakearray (kind, mutability, mode) | Pduparray (kind, mutability) -> Pduparray (kind, mutability) | Parraylength kind -> Parraylength kind - | Parrayrefu kind -> Parrayrefu kind - | Parraysetu kind -> Parraysetu kind - | Parrayrefs kind -> Parrayrefs kind - | Parraysets kind -> Parraysets kind + | Parrayrefu rkind -> Parrayrefu rkind + | Parraysetu skind -> Parraysetu skind + | Parrayrefs rkind -> Parrayrefs rkind + | Parraysets skind -> Parraysets skind | Pisint _ -> Pisint | Pisout -> Pisout | Pcvtbint (src, dest, m) -> Pcvtbint (src, dest, m) diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml index fde0b45f8a1..b33318cefbe 100644 --- a/middle_end/flambda/inline_and_simplify.ml +++ b/middle_end/flambda/inline_and_simplify.ml @@ -1102,34 +1102,34 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = end end | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" - | (Parraysetu kind | Parraysets kind), + | (Parraysetu skind | Parraysets skind), [_block; _field; _value], [block_approx; _field_approx; value_approx] -> if A.warn_on_mutation block_approx then begin Location.prerr_warning (Debuginfo.to_location dbg) Warnings.Flambda_assignment_to_non_mutable_value end; - let kind = + let skind = let check () = - match kind with - | Pfloatarray | Pgenarray -> () - | Paddrarray | Pintarray -> + match skind with + | Pfloatarray_set | Pgenarray_set _ -> () + | Paddrarray_set _ | Pintarray_set -> (* CR pchambart: Do a proper warning here *) Misc.fatal_errorf "Assignment of a float to a specialised \ non-float array: %a" Flambda.print_named tree in match A.descr block_approx, A.descr value_approx with - | (Value_float_array _, _) -> check (); Lambda.Pfloatarray + | (Value_float_array _, _) -> check (); Lambda.Pfloatarray_set | (_, Value_float _) when Config.flat_float_array -> - check (); Lambda.Pfloatarray + check (); Lambda.Pfloatarray_set (* CR pchambart: This should be accounted by the benefit *) | _ -> - kind + skind in let prim : Clambda_primitives.primitive = match prim with - | Parraysetu _ -> Parraysetu kind - | Parraysets _ -> Parraysets kind + | Parraysetu _ -> Parraysetu skind + | Parraysets _ -> Parraysets skind | _ -> assert false in Prim (prim, args, dbg), ret r (A.value_unknown Other) diff --git a/middle_end/flambda/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml index fdfe65b2284..7957aa41a0c 100644 --- a/middle_end/flambda/inlining_cost.ml +++ b/middle_end/flambda/inlining_cost.ml @@ -44,13 +44,13 @@ let prim_size (prim : Clambda_primitives.primitive) args = | Pmakearray _ -> 5 + List.length args | Parraylength Pgenarray -> 6 | Parraylength _ -> 2 - | Parrayrefu Pgenarray -> 12 + | Parrayrefu (Pgenarray_ref _) -> 12 | Parrayrefu _ -> 2 - | Parraysetu Pgenarray -> 16 + | Parraysetu (Pgenarray_set _) -> 16 | Parraysetu _ -> 4 - | Parrayrefs Pgenarray -> 18 + | Parrayrefs (Pgenarray_ref _) -> 18 | Parrayrefs _ -> 8 - | Parraysets Pgenarray -> 22 + | Parraysets (Pgenarray_set _) -> 22 | Parraysets _ -> 10 | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6 | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6 diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml index f8762b18c4f..b7e41451b17 100644 --- a/middle_end/printclambda_primitives.ml +++ b/middle_end/printclambda_primitives.ml @@ -41,6 +41,30 @@ let array_kind array_kind = | Pintarray -> "int" | Pfloatarray -> "float" +let pp_array_ref_kind ppf k = + let open Lambda in + let pp_mode ppf = function + | Alloc_heap -> () + | Alloc_local -> fprintf ppf "(local)" + in + match k with + | Pgenarray_ref mode -> fprintf ppf "gen%a" pp_mode mode + | Paddrarray_ref -> fprintf ppf "addr" + | Pintarray_ref -> fprintf ppf "int" + | Pfloatarray_ref mode -> fprintf ppf "float%a" pp_mode mode + +let pp_array_set_kind ppf k = + let open Lambda in + let pp_mode ppf = function + | Modify_heap -> () + | Modify_maybe_stack -> fprintf ppf "(local)" + in + match k with + | Pgenarray_set mode -> fprintf ppf "gen%a" pp_mode mode + | Paddrarray_set mode -> fprintf ppf "addr%a" pp_mode mode + | Pintarray_set -> fprintf ppf "int" + | Pfloatarray_set -> fprintf ppf "float" + let access_size size = let open Clambda_primitives in match size with @@ -171,10 +195,10 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) | Pduparray (k, Immutable_unique) -> fprintf ppf "duparray_unique[%s]" (array_kind k) - | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) - | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) - | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) - | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) + | Parrayrefu rk -> fprintf ppf "array.unsafe_get[%a]" pp_array_ref_kind rk + | Parraysetu sk -> fprintf ppf "array.unsafe_set[%a]" pp_array_set_kind sk + | Parrayrefs rk -> fprintf ppf "array.get[%a]" pp_array_ref_kind rk + | Parraysets sk -> fprintf ppf "array.set[%a]" pp_array_set_kind sk | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" | Pbintofint (bi,m) -> print_boxed_integer "of_int" ppf bi m diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml index c1763e7849b..b54819da50d 100644 --- a/middle_end/semantics_of_primitives.ml +++ b/middle_end/semantics_of_primitives.ml @@ -159,8 +159,8 @@ let return_type_of_primitive (prim:Clambda_primitives.primitive) = | Pmulfloat _ | Pdivfloat _ | Pfloatfield _ - | Parrayrefu Pfloatarray - | Parrayrefs Pfloatarray -> + | Parrayrefu (Pfloatarray_ref _) + | Parrayrefs (Pfloatarray_ref _) -> Float | _ -> Other diff --git a/runtime/array.c b/runtime/array.c index a011ebdb2a3..40e65f957b8 100644 --- a/runtime/array.c +++ b/runtime/array.c @@ -77,6 +77,22 @@ CAMLprim value caml_floatarray_get(value array, value index) return res; } +/* [ floatarray -> int -> local_ float ] */ +CAMLprim value caml_floatarray_get_local(value array, value index) +{ + intnat idx = Long_val(index); + double d; + value res; + + CAMLassert (Tag_val(array) == Double_array_tag); + if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) + caml_array_bound_error(); + d = Double_flat_field(array, idx); + res = caml_alloc_local(Double_wosize, Double_tag); + Store_double_val(res, d); + return res; +} + /* [ 'a array -> int -> 'a ] */ CAMLprim value caml_array_get(value array, value index) { @@ -89,6 +105,18 @@ CAMLprim value caml_array_get(value array, value index) return caml_array_get_addr(array, index); } +/* [ local_ 'a array -> int -> local_ 'a ] */ +CAMLprim value caml_array_get_local(value array, value index) +{ +#ifdef FLAT_FLOAT_ARRAY + if (Tag_val(array) == Double_array_tag) + return caml_floatarray_get_local(array, index); +#else + CAMLassert (Tag_val(array) != Double_array_tag); +#endif + return caml_array_get_addr(array, index); +} + /* [ 'a array -> int -> 'a -> unit ] where 'a != float */ CAMLprim value caml_array_set_addr(value array, value index, value newval) { @@ -98,7 +126,20 @@ CAMLprim value caml_array_set_addr(value array, value index, value newval) return Val_unit; } -/* [ floatarray -> int -> float -> unit ] */ +/* [ local_ 'a array -> int -> local_ 'a -> unit ] where 'a != float + + Must be used carefully, as it can violate the "no forward pointers" + restriction on the local stack. */ +CAMLprim value caml_array_set_addr_local(value array, value index, value newval) +{ + intnat idx = Long_val(index); + if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error(); + caml_modify_local(array, idx, newval); + return Val_unit; +} + +/* [ floatarray -> int -> float -> unit ] + [ local_ floatarray -> int -> local_ float -> unit ] */ CAMLprim value caml_floatarray_set(value array, value index, value newval) { intnat idx = Long_val(index); @@ -122,6 +163,22 @@ CAMLprim value caml_array_set(value array, value index, value newval) return caml_array_set_addr(array, index, newval); } +/* [ local_ 'a array -> int -> local_ 'a -> unit ] + + Must be used carefully, as it can violate the "no forward pointers" + restriction on the local stack if the array contains pointers (vs. [int]s or + unboxed floats). */ +CAMLprim value caml_array_set_local(value array, value index, value newval) +{ +#ifdef FLAT_FLOAT_ARRAY + if (Tag_val(array) == Double_array_tag) + return caml_floatarray_set(array, index, newval); +#else + CAMLassert (Tag_val(array) != Double_array_tag); +#endif + return caml_array_set_addr_local(array, index, newval); +} + /* [ floatarray -> int -> float ] */ CAMLprim value caml_floatarray_unsafe_get(value array, value index) { @@ -140,6 +197,20 @@ CAMLprim value caml_floatarray_unsafe_get(value array, value index) return res; } +/* [ floatarray -> int -> local_ float ] */ +CAMLprim value caml_floatarray_unsafe_get_local(value array, value index) +{ + intnat idx = Long_val(index); + double d; + value res; + + CAMLassert (Tag_val(array) == Double_array_tag); + d = Double_flat_field(array, idx); + res = caml_alloc_local(Double_wosize, Double_tag); + Store_double_val(res, d); + return res; +} + /* [ 'a array -> int -> 'a ] */ CAMLprim value caml_array_unsafe_get(value array, value index) { @@ -152,6 +223,18 @@ CAMLprim value caml_array_unsafe_get(value array, value index) return Field(array, Long_val(index)); } +/* [ local_ 'a array -> int -> local_ 'a ] */ +CAMLprim value caml_array_unsafe_get_local(value array, value index) +{ +#ifdef FLAT_FLOAT_ARRAY + if (Tag_val(array) == Double_array_tag) + return caml_floatarray_unsafe_get_local(array, index); +#else + CAMLassert (Tag_val(array) != Double_array_tag); +#endif + return Field(array, Long_val(index)); +} + /* [ 'a array -> int -> 'a -> unit ] where 'a != float */ static value caml_array_unsafe_set_addr(value array, value index,value newval) { @@ -160,7 +243,20 @@ static value caml_array_unsafe_set_addr(value array, value index,value newval) return Val_unit; } -/* [ floatarray -> int -> float -> unit ] */ +/* [ local_ 'a array -> int -> local_ 'a -> unit ] where 'a != float + + Must be used carefully, as it can violate the "no forward pointers" + restriction on the local stack. */ +static value caml_array_unsafe_set_addr_local(value array, value index, + value newval) +{ + intnat idx = Long_val(index); + caml_modify_local(array, idx, newval); + return Val_unit; +} + +/* [ floatarray -> int -> float -> unit ] + [ local_ floatarray -> int -> local_ float -> unit ] */ CAMLprim value caml_floatarray_unsafe_set(value array, value index,value newval) { intnat idx = Long_val(index); @@ -181,6 +277,23 @@ CAMLprim value caml_array_unsafe_set(value array, value index, value newval) return caml_array_unsafe_set_addr(array, index, newval); } +/* [ local_ 'a array -> int -> local_ 'a -> unit ] + + Must be used carefully, as it can violate the "no forward pointers" + restriction on the local stack if the array contains pointers (vs. [int]s or + unboxed floats). */ +CAMLprim value caml_array_unsafe_set_local(value array, value index, + value newval) +{ +#ifdef FLAT_FLOAT_ARRAY + if (Tag_val(array) == Double_array_tag) + return caml_floatarray_unsafe_set(array, index, newval); +#else + CAMLassert (Tag_val(array) != Double_array_tag); +#endif + return caml_array_unsafe_set_addr_local(array, index, newval); +} + /* [len] is a [value] representing number of floats. */ /* [ int -> floatarray ] */ CAMLprim value caml_floatarray_create(value len) @@ -621,3 +734,13 @@ CAMLprim value caml_array_fill(value array, } return Val_unit; } + +CAMLprim value caml_iarray_of_array(value a) +{ + return a; +} + +CAMLprim value caml_array_of_iarray(value a) +{ + return a; +} diff --git a/runtime/caml/memory.h b/runtime/caml/memory.h index 911dd566b05..800b768fa78 100644 --- a/runtime/caml/memory.h +++ b/runtime/caml/memory.h @@ -55,6 +55,7 @@ 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_modify (value *, value); +CAMLextern void caml_modify_local (value obj, intnat i, value val); CAMLextern void caml_initialize (value *, value); CAMLextern value caml_check_urgent_gc (value); CAMLextern color_t caml_allocation_color (void *hp); diff --git a/runtime/str.c b/runtime/str.c index 4bfac095474..aa5b650ccf3 100644 --- a/runtime/str.c +++ b/runtime/str.c @@ -480,13 +480,3 @@ CAMLprim value caml_bytes_of_string(value bv) { return bv; } - -CAMLprim value caml_iarray_of_array(value bv) -{ - return bv; -} - -CAMLprim value caml_array_of_iarray(value bv) -{ - return bv; -} diff --git a/stdlib/iarray.ml b/stdlib/iarray.ml index af0a7dfa80c..82d6299e7c4 100644 --- a/stdlib/iarray.ml +++ b/stdlib/iarray.ml @@ -17,6 +17,10 @@ open! Stdlib +(* NOTE: If you update this file, please also update iarrayLabels.ml; from the + declaration of [type +'a t = 'a iarray] on down, they're the same. This is a + temporary state of affairs, but for now, please copy things! *) + (* In this file, we use four different implementation strategies: 1. Reusing [external]s for mutable arrays. (E.g., [get].) @@ -51,93 +55,330 @@ open! Stdlib [@@@ocaml.flambda_o3] -(* If you update this file please also update iarrayLabels.ml *) - (* An alias for the type of immutable arrays. *) type +'a t = 'a iarray (* Array operations *) -external length : 'a iarray -> int = "%array_length" -external get : 'a iarray -> int -> 'a = "%array_safe_get" -external ( .:() ) : 'a iarray -> int -> 'a = "%array_safe_get" -external unsafe_get : 'a iarray -> int -> 'a = "%array_unsafe_get" +external length : local_ 'a iarray -> int = "%array_length" +external get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" +external ( .:() ) : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" +external unsafe_get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_unsafe_get" external concat : 'a iarray list -> 'a iarray = "caml_array_concat" +external concat_local : local_ 'a iarray list -> local_ 'a iarray = + "caml_array_concat_local" external append_prim : 'a iarray -> 'a iarray -> 'a iarray = "caml_array_append" +external append_prim_local : + local_ 'a iarray -> local_ 'a iarray -> local_ 'a iarray = + "caml_array_append_local" external unsafe_sub : 'a iarray -> int -> int -> 'a iarray = "caml_array_sub" +external unsafe_sub_local : local_ 'a iarray -> int -> int -> local_ 'a iarray = + "caml_array_sub_local" external unsafe_of_array : 'a array -> 'a iarray = "%array_to_iarray" external unsafe_to_array : 'a iarray -> 'a array = "%array_of_iarray" -let init l f = unsafe_of_array (Array.init l f) +(* Used only to reimplement [init] *) +external unsafe_set_mutable : 'a array -> int -> 'a -> unit = + "%array_unsafe_set" + +(* VERY UNSAFE: Any of these functions can be used to violate the "no forward + pointers" restriction for the local stack if not used carefully. Each of + these can either make a local mutable array or mutate its contents, and if + not careful, this can lead to an array's contents pointing forwards. The + latter two functions could be overloaded via [[@local_opt]], but we don't do + that in order to isolate the unsafety. *) +external make_mutable_local : int -> local_ 'a -> local_ 'a array = + "caml_make_local_vect" +external unsafe_of_local_array : local_ 'a array -> local_ 'a iarray = + "%array_to_iarray" +external unsafe_set_local : local_ 'a array -> int -> local_ 'a -> unit = + "%array_unsafe_set" + +(* We can't use immutable array literals in this file, since we don't want to + require the stdlib to be compiled with extensions, so instead of [[::]] we + use [unsafe_of_(local_)array [||]] below. *) + +(* Really trusting the inliner here; to get maximum performance, it has to + inline both [unsafe_init_local] *and* [f]. *) +(** Precondition: [l >= 0]. *) +let[@inline always] unsafe_init_local l (local_ f : int -> local_ 'a) = local_ + if l = 0 then + unsafe_of_local_array [||] + else + (* The design of this function is exceedingly delicate, and is the only way + we can correctly allocate a local array on the stack via mutation. We + are subject to the "no forward pointers" constraint on the local stack; + we're not allowed to make pointers to later-allocated objects even within + the same stack frame. Thus, in order to get this right, we consume O(n) + call-stack space: we allocate the values to put in the array, and only + *then* recurse, creating the array as the very last thing of all and + *returning* it. This is why the [f i] call is the first thing in the + function, and why it's not tail-recursive; if it were tail-recursive, + then we wouldn't have anywhere to put the array elements during the whole + process. *) + let rec go i = local_ begin + let x = f i in + if i = l - 1 then + make_mutable_local l x + else begin + let res = go (i+1) in + unsafe_set_local res i x; + res + end + end in + unsafe_of_local_array (go 0) + +(* The implementation is copied from [Array] so that [f] can be [local_] *) +let init l (local_ f) = + if l = 0 then unsafe_of_array [||] else + if l < 0 then invalid_arg "Iarray.init" + (* See #6575. We could also check for maximum array size, but this depends + on whether we create a float array or a regular one... *) + else + let res = Array.make l (f 0) in + for i = 1 to pred l do + unsafe_set_mutable res i (f i) + done; + unsafe_of_array res + +let init_local l f = local_ + if l < 0 then invalid_arg "Iarray.init_local" + (* See #6575. We could also check for maximum array size, but this depends + on whether we create a float array or a regular one... *) + else unsafe_init_local l f let append a1 a2 = if length a1 = 0 then a2 (* Safe because they're immutable *) else if length a2 = 0 then a1 else append_prim a1 a2 +let append_local a1 a2 = local_ + if length a1 = 0 then a2 (* Safe because they're immutable *) + else if length a2 = 0 then a1 + else append_prim_local a1 a2 + let sub a ofs len = if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Iarray.sub" else unsafe_sub a ofs len +let sub_local a ofs len = local_ + if ofs < 0 || len < 0 || ofs > length a - len + then invalid_arg "Iarray.sub" + else unsafe_sub_local a ofs len + let iter f a = for i = 0 to length a - 1 do f(unsafe_get a i) done +let iter_local f a = + for i = 0 to length a - 1 do f(unsafe_get a i) done + let iter2 f a b = if length a <> length b then invalid_arg "Iarray.iter2: arrays must have the same length" else for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done +let iter2_local f a b = + if length a <> length b then + invalid_arg "Iarray.iter2_local: arrays must have the same length" + else + for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done + +let iter2_local_first f a b = + if length a <> length b then + invalid_arg "Iarray.iter2_local_first: arrays must have the same length" + else + for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done + +let iter2_local_second f a b = + if length a <> length b then + invalid_arg "Iarray.iter2_local_second: arrays must have the same length" + else + for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done + let map f a = let l = length a in - let r = if l = 0 then [||] else begin + if l = 0 then unsafe_of_array [||] else begin let r = Array.make l (f(unsafe_get a 0)) in for i = 1 to l - 1 do Array.unsafe_set r i (f(unsafe_get a i)) done; - r - end in - unsafe_of_array r + unsafe_of_array r + end + +let map_local f a = local_ + unsafe_init_local (length a) (fun i -> local_ f (unsafe_get a i)) + +let map_local_input f a = + let l = length a in + if l = 0 then unsafe_of_array [||] else begin + let r = Array.make l (f(unsafe_get a 0)) in + for i = 1 to l - 1 do + Array.unsafe_set r i (f(unsafe_get a i)) + done; + unsafe_of_array r + end + +let map_local_output f a = local_ + unsafe_init_local (length a) (fun i -> local_ f (unsafe_get a i)) let map2 f a b = let la = length a in let lb = length b in if la <> lb then - invalid_arg "Array.map2: arrays must have the same length" + invalid_arg "Iarray.map2: arrays must have the same length" else begin - let r = if la = 0 then [||] else begin + if la = 0 then unsafe_of_array [||] else begin let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in for i = 1 to la - 1 do Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) done; - r - end in - unsafe_of_array r + unsafe_of_array r + end + end + +let map2_local f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + +let map2_local_inputs f a b = + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2: arrays must have the same length" + else begin + if la = 0 then unsafe_of_array [||] else begin + let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in + for i = 1 to la - 1 do + Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + unsafe_of_array r + end end +let map2_local_output f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + +let map2_local_first_input f a b = + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2: arrays must have the same length" + else begin + if la = 0 then unsafe_of_array [||] else begin + let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in + for i = 1 to la - 1 do + Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + unsafe_of_array r + end + end + +let map2_local_second_input f a b = + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2: arrays must have the same length" + else begin + if la = 0 then unsafe_of_array [||] else begin + let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in + for i = 1 to la - 1 do + Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + unsafe_of_array r + end + end + +let map2_local_first_input_and_output f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + +let map2_local_second_input_and_output f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + let iteri f a = for i = 0 to length a - 1 do f i (unsafe_get a i) done +let iteri_local f a = + for i = 0 to length a - 1 do f i (unsafe_get a i) done + let mapi f a = let l = length a in - let r = if l = 0 then [||] else begin + if l = 0 then unsafe_of_array [||] else begin let r = Array.make l (f 0 (unsafe_get a 0)) in for i = 1 to l - 1 do Array.unsafe_set r i (f i (unsafe_get a i)) done; - r - end in - unsafe_of_array r + unsafe_of_array r + end + +let mapi_local f a = local_ + unsafe_init_local (length a) (fun i -> local_ f i (unsafe_get a i)) + +let mapi_local_input f a = + let l = length a in + if l = 0 then unsafe_of_array [||] else begin + let r = Array.make l (f 0 (unsafe_get a 0)) in + for i = 1 to l - 1 do + Array.unsafe_set r i (f i (unsafe_get a i)) + done; + unsafe_of_array r + end + +let mapi_local_output f a = local_ + unsafe_init_local (length a) (fun i -> local_ f i (unsafe_get a i)) let to_list a = let rec tolist i res = if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in tolist (length a - 1) [] +let to_list_local a = local_ + let rec tolist i res = local_ + if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in + tolist (length a - 1) [] + let of_list l = unsafe_of_array (Array.of_list l) +(* Cannot use List.length here because the List module depends on Array. *) +let rec list_length accu = function + | [] -> accu + | _::t -> list_length (succ accu) t + +(* This shouldn't violate the forward-pointers restriction because the list + elements already exist *) +let of_list_local = function + | [] -> local_ unsafe_of_array [||] + | hd::tl as l -> local_ + let a = make_mutable_local (list_length 0 l) hd in + let rec fill i = function + | [] -> local_ a + | hd::tl -> local_ unsafe_set_local a i hd; fill (i+1) tl in + unsafe_of_local_array (fill 1 tl) + let to_array ia = Array.copy (unsafe_to_array ia) let of_array ma = unsafe_of_array (Array.copy ma) @@ -149,9 +390,34 @@ let fold_left f x a = done; !r +let fold_left_local f x a = local_ + let len = length a in + let rec go r i = local_ + if i = len + then r + else go (f r (unsafe_get a i)) (i+1) + in + go x 0 + +let fold_left_local_input f x a = + let r = ref x in + for i = 0 to length a - 1 do + r := f !r (unsafe_get a i) + done; + !r + +let fold_left_local_output f x a = local_ + let len = length a in + let rec go r i = local_ + if i = len + then r + else go (f r (unsafe_get a i)) (i+1) + in + go x 0 + let fold_left_map f acc input_array = let len = length input_array in - let acc, output_array = if len = 0 then (acc, [||]) else begin + if len = 0 then (acc, unsafe_of_array [||]) else begin let acc, elt = f acc (unsafe_get input_array 0) in let output_array = Array.make len elt in let acc = ref acc in @@ -160,9 +426,56 @@ let fold_left_map f acc input_array = acc := acc'; Array.unsafe_set output_array i elt; done; - !acc, output_array - end in - acc, unsafe_of_array output_array + !acc, unsafe_of_array output_array + end + +let fold_left_map_local f acc input_array = local_ + let len = length input_array in + if len = 0 then (acc, unsafe_of_local_array [||]) else begin + let rec go acc i = local_ + let acc', elt = f acc (unsafe_get input_array i) in + if i = len - 1 then + acc', make_mutable_local len elt + else begin + let (_, output_array) as res = go acc (i+1) in + unsafe_set_local output_array i elt; + res + end + in + let acc, output_array = go acc 0 in + acc, unsafe_of_local_array output_array + end + +let fold_left_map_local_input f acc input_array = + let len = length input_array in + if len = 0 then (acc, unsafe_of_array [||]) else begin + let acc, elt = f acc (unsafe_get input_array 0) in + let output_array = Array.make len elt in + let acc = ref acc in + for i = 1 to len - 1 do + let acc', elt = f !acc (unsafe_get input_array i) in + acc := acc'; + Array.unsafe_set output_array i elt; + done; + !acc, unsafe_of_array output_array + end + +let fold_left_map_local_output f acc input_array = local_ + let len = length input_array in + if len = 0 then (acc, unsafe_of_local_array [||]) else begin + let rec go acc i = local_ + let acc', elt = f acc (unsafe_get input_array i) in + if i = len - 1 then + acc', make_mutable_local len elt + else begin + let (_, output_array) as res = go acc (i+1) in + unsafe_set_local output_array i elt; + res + end + in + let acc, output_array = go acc 0 in + acc, unsafe_of_local_array output_array + end let fold_right f a x = let r = ref x in @@ -171,57 +484,160 @@ let fold_right f a x = done; !r +let fold_right_local f a x = local_ + let rec go r i = local_ + if i = -1 + then r + else go (f (unsafe_get a i) r) (i-1) + in + go x (length a - 1) + +let fold_right_local_input f a x = + let r = ref x in + for i = length a - 1 downto 0 do + r := f (unsafe_get a i) !r + done; + !r + +let fold_right_local_output f a x = local_ + let rec go r i = local_ + if i = -1 + then r + else go (f (unsafe_get a i) r) (i-1) + in + go x (length a - 1) + +(* CR aspectorzabusky: Why do I need this? Shouldn't mode-crossing handle doing + this? *) +let[@inline always] globalize_bool : local_ bool -> bool = fun b -> b + let exists p a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then false else if p (unsafe_get a i) then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) + +let exists_local p a = + let n = length a in + let rec loop i = local_ + if i = n then false + else if p (unsafe_get a i) then true + else loop (succ i) in + globalize_bool (loop 0) let for_all p a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then true else if p (unsafe_get a i) then loop (succ i) else false in - loop 0 + globalize_bool (loop 0) + +let for_all_local p a = + let n = length a in + let rec loop i = local_ + if i = n then true + else if p (unsafe_get a i) then loop (succ i) + else false in + globalize_bool (loop 0) let for_all2 p l1 l2 = let n1 = length l1 and n2 = length l2 in if n1 <> n2 then invalid_arg "Iarray.for_all2" - else let rec loop i = + else let rec loop i = local_ if i = n1 then true else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) else false in - loop 0 + globalize_bool (loop 0) + +let for_all2_local p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.for_all2_local" + else let rec loop i = local_ + if i = n1 then true + else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) + else false in + globalize_bool (loop 0) + +let for_all2_local_first p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.for_all2_local_first" + else let rec loop i = local_ + if i = n1 then true + else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) + else false in + globalize_bool (loop 0) + +let for_all2_local_second p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.for_all2_local_second" + else let rec loop i = local_ + if i = n1 then true + else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) + else false in + globalize_bool (loop 0) let exists2 p l1 l2 = let n1 = length l1 and n2 = length l2 in if n1 <> n2 then invalid_arg "Iarray.exists2" - else let rec loop i = + else let rec loop i = local_ if i = n1 then false else if p (unsafe_get l1 i) (unsafe_get l2 i) then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) + +let exists2_local p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.exists2_local" + else let rec loop i = local_ + if i = n1 then false + else if p (unsafe_get l1 i) (unsafe_get l2 i) then true + else loop (succ i) in + globalize_bool (loop 0) + +let exists2_local_first p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.exists2_local_first" + else let rec loop i = local_ + if i = n1 then false + else if p (unsafe_get l1 i) (unsafe_get l2 i) then true + else loop (succ i) in + globalize_bool (loop 0) + +let exists2_local_second p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.exists2_local_second" + else let rec loop i = local_ + if i = n1 then false + else if p (unsafe_get l1 i) (unsafe_get l2 i) then true + else loop (succ i) in + globalize_bool (loop 0) let mem x a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then false else if compare (unsafe_get a i) x = 0 then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) let memq x a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then false else if x == (unsafe_get a i) then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) let find_opt p a = let n = length a in @@ -232,6 +648,17 @@ let find_opt p a = if p x then Some x else loop (succ i) in + loop 0 [@nontail] + +let find_opt_local p a = local_ + let n = length a in + let rec loop i = local_ + if i = n then None + else + let x = unsafe_get a i in + if p x then Some x + else loop (succ i) + in loop 0 let find_map f a = @@ -243,12 +670,44 @@ let find_map f a = | None -> loop (succ i) | Some _ as r -> r in + loop 0 [@nontail] + +let find_map_local f a = local_ + let n = length a in + let rec loop i = local_ + if i = n then None + else + match f (unsafe_get a i) with + | None -> loop (succ i) + | Some _ as r -> r + in + loop 0 + +let find_map_local_input f a = + let n = length a in + let rec loop i = + if i = n then None + else + match f (unsafe_get a i) with + | None -> loop (succ i) + | Some _ as r -> r + in + loop 0 [@nontail] + +let find_map_local_output f a = local_ + let n = length a in + let rec loop i = local_ + if i = n then None + else + match f (unsafe_get a i) with + | None -> loop (succ i) + | Some _ as r -> r + in loop 0 let split x = - (* We can't use immutable array literals here, since we don't want to require - the stdlib to be compiled with extensions *) - let r1, r2 = if x = unsafe_of_array [||] then [||], [||] + if x = unsafe_of_array [||] + then unsafe_of_array [||], unsafe_of_array [||] else begin let a0, b0 = unsafe_get x 0 in let n = length x in @@ -259,14 +718,32 @@ let split x = Array.unsafe_set a i ai; Array.unsafe_set b i bi done; - a, b - end in - unsafe_of_array r1, unsafe_of_array r2 + unsafe_of_array a, unsafe_of_array b + end + +(* This shouldn't violate the forward-pointers restriction because the array + elements already exist. (This doesn't work for [combine], where we need to + create the tuples.) *) +let split_local x = local_ + if x = unsafe_of_array [||] + then unsafe_of_array [||], unsafe_of_array [||] + else begin + let a0, b0 = unsafe_get x 0 in + let n = length x in + let a = make_mutable_local n a0 in + let b = make_mutable_local n b0 in + for i = 1 to n - 1 do + let ai, bi = unsafe_get x i in + unsafe_set_local a i ai; + unsafe_set_local b i bi + done; + unsafe_of_local_array a, unsafe_of_local_array b + end let combine a b = let na = length a in let nb = length b in - if na <> nb then invalid_arg "Array.combine"; + if na <> nb then invalid_arg "Iarray.combine"; let r = if na = 0 then [||] else begin let x = Array.make na (unsafe_get a 0, unsafe_get b 0) in @@ -277,6 +754,12 @@ let combine a b = end in unsafe_of_array r +let combine_local a b = local_ + let na = length a in + let nb = length b in + if na <> nb then invalid_arg "Iarray.combine_local"; + unsafe_init_local na (fun i -> local_ unsafe_get a i, unsafe_get b i) + (* Must be fully applied due to the value restriction *) let lift_sort sorter cmp iarr = let arr = to_array iarr in diff --git a/stdlib/iarray.mli b/stdlib/iarray.mli index ff2b91b9f80..48eeecde784 100644 --- a/stdlib/iarray.mli +++ b/stdlib/iarray.mli @@ -26,17 +26,20 @@ open! Stdlib *) (** Operations on immutable arrays. This module mirrors the API of [Array], but - omits functions that assume mutability; in particular, it omits [copy] along - with the functions [make], [create_float], and [make_matrix] that produce - all-constant arrays. *) + omits functions that assume mutability; in addition to obviously mutating + functions, it omits [copy] along with the functions [make], [create_float], + and [make_matrix] that produce all-constant arrays. The exception is the + sorting functions, which are given a copying API to replace the in-place + one. *) type +'a t = 'a iarray (** An alias for the type of immutable arrays. *) -external length : 'a iarray -> int = "%array_length" +external length : local_ 'a iarray -> int = "%array_length" (** Return the length (number of elements) of the given immutable array. *) -external get : 'a iarray -> int -> 'a = "%array_safe_get" +external get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" (** [get a n] returns the element number [n] of immutable array [a]. The first element has number 0. The last element has number [length a - 1]. @@ -45,10 +48,11 @@ external get : 'a iarray -> int -> 'a = "%array_safe_get" @raise Invalid_argument if [n] is outside the range 0 to [(length a - 1)]. *) -external ( .:() ) : 'a iarray -> int -> 'a = "%array_safe_get" +external ( .:() ) : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" (** A synonym for [get]. *) -val init : int -> (int -> 'a) -> 'a iarray +val init : int -> local_ (int -> 'a) -> 'a iarray (** [init n f] returns a fresh immutable array of length [n], with element number [i] initialized to the result of [f i]. In other terms, [init n f] tabulates the results of [f] @@ -58,27 +62,43 @@ val init : int -> (int -> 'a) -> 'a iarray If the return type of [f] is [float], then the maximum size is only [Sys.max_array_length / 2]. *) +val init_local : int -> local_ (int -> local_ 'a) -> local_ 'a iarray +(** The locally-allocating version of [init]. *) + val append : 'a iarray -> 'a iarray -> 'a iarray (** [append v1 v2] returns a fresh immutable array containing the concatenation of the immutable arrays [v1] and [v2]. @raise Invalid_argument if [length v1 + length v2 > Sys.max_array_length]. *) +val append_local : local_ 'a iarray -> local_ 'a iarray -> local_ 'a iarray +(** The locally-allocating version of [append]. *) + val concat : 'a iarray list -> 'a iarray (** Same as {!append}, but concatenates a list of immutable arrays. *) +val concat_local : local_ 'a iarray list -> local_ 'a iarray +(** The locally-allocating version of [concat]. *) + val sub : 'a iarray -> int -> int -> 'a iarray (** [sub a pos len] returns a fresh immutable array of length [len], containing the elements number [pos] to [pos + len - 1] - of immutable array [a]. + of immutable array [a]. This creates a copy of the selected + portion of the immutable array. @raise Invalid_argument if [pos] and [len] do not designate a valid subarray of [a]; that is, if [pos < 0], or [len < 0], or [pos + len > length a]. *) +val sub_local : local_ 'a iarray -> int -> int -> local_ 'a iarray +(** The locally-allocating version of [sub]. *) + val to_list : 'a iarray -> 'a list (** [to_list a] returns the list of all the elements of [a]. *) +val to_list_local : local_ 'a iarray -> local_ 'a list +(** The locally-allocating version of []. *) + val of_list : 'a list -> 'a iarray (** [of_list l] returns a fresh immutable array containing the elements of [l]. @@ -86,6 +106,9 @@ val of_list : 'a list -> 'a iarray @raise Invalid_argument if the length of [l] is greater than [Sys.max_array_length]. *) +val of_list_local : local_ 'a list -> local_ 'a iarray +(** The locally-allocating version of [of_list]. *) + (** {1 Converting to and from mutable arrays} *) val to_array : 'a iarray -> 'a array @@ -98,111 +121,331 @@ val of_array : 'a array -> 'a iarray (** {1 Iterators} *) -val iter : ('a -> unit) -> 'a iarray -> unit +val iter : local_ ('a -> unit) -> 'a iarray -> unit (** [iter f a] applies function [f] in turn to all the elements of [a]. It is equivalent to [f a.:(0); f a.:(1); ...; f a.:(length a - 1); ()]. *) -val iteri : (int -> 'a -> unit) -> 'a iarray -> unit +val iter_local : local_ (local_ 'a -> unit) -> local_ 'a iarray -> unit +(** The locally-scoped version of [iter]. *) + +val iteri : local_ (int -> 'a -> unit) -> 'a iarray -> unit (** Same as {!iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) -val map : ('a -> 'b) -> 'a iarray -> 'b iarray +val iteri_local : local_ (int -> local_ 'a -> unit) -> local_ 'a iarray -> unit +(** The locally-scoped version of [iteri]. *) + +val map : local_ ('a -> 'b) -> 'a iarray -> 'b iarray (** [map f a] applies function [f] to all the elements of [a], and builds an immutable array with the results returned by [f]: [[| f a.:(0); f a.:(1); ...; f a.:(length a - 1) |]]. *) -val mapi : (int -> 'a -> 'b) -> 'a iarray -> 'b iarray +val map_local : + local_ (local_ 'a -> local_ 'b) -> local_ 'a iarray -> local_ 'b iarray +(** The locally-scoped and locally-allocating version of [map]. *) + +val map_local_input : local_ (local_ 'a -> 'b) -> local_ 'a iarray -> 'b iarray +(** The locally-constrained but globally-allocating version of [map]. *) + +val map_local_output : local_ ('a -> local_ 'b) -> 'a iarray -> local_ 'b iarray +(** The locally-allocating but global-input version of [map]. *) + +val mapi : local_ (int -> 'a -> 'b) -> 'a iarray -> 'b iarray (** Same as {!map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) -val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b iarray -> 'a +val mapi_local : + local_ (int -> local_ 'a -> local_ 'b) -> + local_ 'a iarray -> + local_ 'b iarray +(** The locally-scoped and locally-allocating version of [mapi]. *) + +val mapi_local_input : + local_ (int -> local_ 'a -> 'b) -> local_ 'a iarray -> 'b iarray +(** The locally-constrained but globally-allocating version of [mapi]. *) + +val mapi_local_output : + local_ (int -> 'a -> local_ 'b) -> 'a iarray -> local_ 'b iarray +(** The locally-allocating but global-input version of [mapi]. *) + +val fold_left : local_ ('a -> 'b -> 'a) -> 'a -> 'b iarray -> 'a (** [fold_left f init a] computes [f (... (f (f init a.:(0)) a.:(1)) ...) a.:(n-1)], where [n] is the length of the immutable array [a]. *) +val fold_left_local : + local_ (local_ 'a -> local_ 'b -> local_ 'a) -> + local_ 'a -> + local_ 'b iarray -> + local_ 'a +(** The locally-constrained and locally-allocating version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_left_local_input : + local_ ('a -> local_ 'b -> 'a) -> 'a -> local_ 'b iarray -> 'a +(** The locally-constrained but globally-allocating version of [fold_left]. *) + +val fold_left_local_output : + local_ (local_ 'a -> 'b -> local_ 'a) -> local_ 'a -> 'b iarray -> local_ 'a +(** The locally-allocating but global-input version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + val fold_left_map : - ('a -> 'b -> 'a * 'c) -> 'a -> 'b iarray -> 'a * 'c iarray + local_ ('a -> 'b -> 'a * 'c) -> 'a -> 'b iarray -> 'a * 'c iarray (** [fold_left_map] is a combination of {!fold_left} and {!map} that threads an accumulator through calls to [f]. *) -val fold_right : ('b -> 'a -> 'a) -> 'b iarray -> 'a -> 'a +val fold_left_map_local : + local_ (local_ 'a -> local_ 'b -> local_ 'a * 'c) -> + local_ 'a -> + local_ 'b iarray -> + local_ 'a * 'c iarray +(** The locally-constrained and locally-allocating version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_left_map_local_input : + local_ ('a -> local_ 'b -> 'a * 'c) -> + 'a -> + local_ 'b iarray -> + 'a * 'c iarray +(** The locally-constrained but globally-allocating version of [fold_left]. *) + +val fold_left_map_local_output : + local_ (local_ 'a -> 'b -> local_ 'a * 'c) -> + local_ 'a -> + 'b iarray -> + local_ 'a * 'c iarray +(** The locally-allocating but global-input version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_right : local_ ('b -> 'a -> 'a) -> 'b iarray -> 'a -> 'a (** [fold_right f a init] computes [f a.:(0) (f a.:(1) ( ... (f a.:(n-1) init) ...))], where [n] is the length of the immutable array [a]. *) +val fold_right_local : + local_ (local_ 'b -> local_ 'a -> local_ 'a) -> + local_ 'b iarray -> + local_ 'a -> + local_ 'a +(** The locally-constrained and locally-allocating version of [fold_right]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_right_local_input : + local_ (local_ 'b -> 'a -> 'a) -> local_ 'b iarray -> 'a -> 'a +(** The locally-constrained but globally-allocating version of [fold_right]. *) + +val fold_right_local_output : + local_ ('b -> local_ 'a -> local_ 'a) -> 'b iarray -> local_ 'a -> local_ 'a +(** The locally-allocating but global-input version of [fold_right]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + (** {1 Iterators on two arrays} *) -val iter2 : ('a -> 'b -> unit) -> 'a iarray -> 'b iarray -> unit +val iter2 : local_ ('a -> 'b -> unit) -> 'a iarray -> 'b iarray -> unit (** [iter2 f a b] applies function [f] to all the elements of [a] and [b]. @raise Invalid_argument if the immutable arrays are not the same size. *) -val map2 : ('a -> 'b -> 'c) -> 'a iarray -> 'b iarray -> 'c iarray +val iter2_local : + local_ (local_ 'a -> local_ 'b -> unit) -> + local_ 'a iarray -> + local_ 'b iarray -> + unit +(** The locally-scoped version of [iter2]. *) + +val iter2_local_first : + local_ (local_ 'a -> 'b -> unit) -> local_ 'a iarray -> 'b iarray -> unit +(** The first-biased partly-locally-scoped version of [iter2]. *) + +val iter2_local_second : + local_ ('a -> local_ 'b -> unit) -> 'a iarray -> local_ 'b iarray -> unit +(** The second-biased partly-locally-scoped version of [iter2]. *) + +val map2 : local_ ('a -> 'b -> 'c) -> 'a iarray -> 'b iarray -> 'c iarray (** [map2 f a b] applies function [f] to all the elements of [a] and [b], and builds an immutable array with the results returned by [f]: [[| f a.:(0) b.:(0); ...; f a.:(length a - 1) b.:(length b - 1)|]]. @raise Invalid_argument if the immutable arrays are not the same size. *) +val map2_local : + local_ (local_ 'a -> local_ 'b -> local_ 'c) -> + local_ 'a iarray -> + local_ 'b iarray -> + local_ 'c iarray +(** The locally-scoped and locally-allocating version of [map2]. *) + +val map2_local_inputs : + local_ (local_ 'a -> local_ 'b -> 'c) -> + local_ 'a iarray -> + local_ 'b iarray -> + 'c iarray +(** The locally-scoped but globally-allocating version of [map2]. *) + +val map2_local_output : + local_ ('a -> 'b -> local_ 'c) -> 'a iarray -> 'b iarray -> local_ 'c iarray +(** The locally-allocating but global-inputs version of [map2]. *) + +val map2_local_first_input : + local_ (local_ 'a -> 'b -> 'c) -> local_ 'a iarray -> 'b iarray -> 'c iarray +(** The first-biased partly-locally-scoped but globally-allocating version of + [map2]. *) + +val map2_local_second_input : + local_ ('a -> local_ 'b -> 'c) -> 'a iarray -> local_ 'b iarray -> 'c iarray +(** The second-biased partly-locally-scoped but globally-allocating version of + [map2]. *) + +val map2_local_first_input_and_output : + local_ (local_ 'a -> 'b -> local_ 'c) -> + local_ 'a iarray -> + 'b iarray -> + local_ 'c iarray +(** The locally-allocating and first-biased partly-locally-scoped version of + [map2]. *) + +val map2_local_second_input_and_output : + local_ ('a -> local_ 'b -> local_ 'c) -> + 'a iarray -> + local_ 'b iarray -> + local_ 'c iarray +(** The locally-allocating and second-biased partly-locally-scoped version of + [map2]. *) + (** {1 Array scanning} *) -val for_all : ('a -> bool) -> 'a iarray -> bool +val for_all : local_ ('a -> bool) -> 'a iarray -> bool (** [for_all f [|a1; ...; an|]] checks if all elements of the immutable array satisfy the predicate [f]. That is, it returns [(f a1) && (f a2) && ... && (f an)]. *) -val exists : ('a -> bool) -> 'a iarray -> bool +val for_all_local : local_ (local_ 'a -> bool) -> local_ 'a iarray -> bool +(** The locally-scoped version of [for_all]. *) + +val exists : local_ ('a -> bool) -> 'a iarray -> bool (** [exists f [|a1; ...; an|]] checks if at least one element of the immutable array satisfies the predicate [f]. That is, it returns [(f a1) || (f a2) || ... || (f an)]. *) -val for_all2 : ('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool +val exists_local : local_ (local_ 'a -> bool) -> local_ 'a iarray -> bool +(** The locally-scoped version of [exists]. *) + +val for_all2 : local_ ('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool (** Same as {!for_all}, but for a two-argument predicate. @raise Invalid_argument if the two immutable arrays have different lengths. *) -val exists2 : ('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool +val for_all2_local : + local_ (local_ 'a -> local_ 'b -> bool) -> + local_ 'a iarray -> + local_ 'b iarray -> + bool +(** The locally-scoped version of [for_all2]. *) + +val for_all2_local_first : + local_ (local_ 'a -> 'b -> bool) -> local_ 'a iarray -> 'b iarray -> bool +(** The first-biased partly-locally-scoped version of [for_all2]. *) + +val for_all2_local_second : + local_ ('a -> local_ 'b -> bool) -> 'a iarray -> local_ 'b iarray -> bool +(** The second-biased partly-locally-scoped version of [for_all2]. *) + +val exists2 : local_ ('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool (** Same as {!exists}, but for a two-argument predicate. @raise Invalid_argument if the two immutable arrays have different lengths. *) -val mem : 'a -> 'a iarray -> bool +val exists2_local : + local_ (local_ 'a -> local_ 'b -> bool) -> + local_ 'a iarray -> + local_ 'b iarray -> + bool +(** The locally-scoped version of [exists2]. *) + +val exists2_local_first : + local_ (local_ 'a -> 'b -> bool) -> local_ 'a iarray -> 'b iarray -> bool +(** The first-biased partly-locally-scoped version of [exists2]. *) + +val exists2_local_second : + local_ ('a -> local_ 'b -> bool) -> 'a iarray -> local_ 'b iarray -> bool +(** The second-biased partly-locally-scoped version of [exists2]. *) + +val mem : local_ 'a -> local_ 'a iarray -> bool (** [mem a set] is true if and only if [a] is structurally equal to an element of [l] (i.e. there is an [x] in [l] such that [compare a x = 0]). *) -val memq : 'a -> 'a iarray -> bool +val memq : local_ 'a -> local_ 'a iarray -> bool (** Same as {!mem}, but uses physical equality instead of structural equality to compare list elements. *) -val find_opt : ('a -> bool) -> 'a iarray -> 'a option +val find_opt : local_ ('a -> bool) -> 'a iarray -> 'a option (** [find_opt ~f a] returns the first element of the immutable array [a] that satisfies the predicate [f], or [None] if there is no value that satisfies [f] in the array [a]. *) -val find_map : ('a -> 'b option) -> 'a iarray -> 'b option +val find_opt_local : + local_ (local_ 'a -> bool) -> local_ 'a iarray -> local_ 'a option +(** The locally-constrained and locally-allocating version of []. *) + +val find_map : local_ ('a -> 'b option) -> 'a iarray -> 'b option (** [find_map ~f a] applies [f] to the elements of [a] in order, and returns the first result of the form [Some v], or [None] if none exist. *) +val find_map_local : + local_ (local_ 'a -> local_ 'b option) -> local_ 'a iarray -> local_ 'b option +(** The locally-constrained and locally-allocating version of [find_map]. *) + +val find_map_local_input : + local_ (local_ 'a -> 'b option) -> local_ 'a iarray -> 'b option +(** The locally-constrained but globally-allocating version of [find_map]. *) + +val find_map_local_output : + local_ ('a -> local_ 'b option) -> 'a iarray -> local_ 'b option +(** The locally-allocating but global-input version of [find_map]. *) + (** {1 Arrays of pairs} *) val split : ('a * 'b) iarray -> 'a iarray * 'b iarray (** [split [:(a1,b1); ...; (an,bn):]] is [([:a1; ...; an:], [:b1; ...; bn:])]. *) +val split_local : local_ ('a * 'b) iarray -> local_ 'a iarray * 'b iarray +(** The locally-allocating version of [split]. *) + val combine : 'a iarray -> 'b iarray -> ('a * 'b) iarray (** [combine [:a1; ...; an:] [:b1; ...; bn:]] is [[:(a1,b1); ...; (an,bn):]]. Raise [Invalid_argument] if the two immutable iarrays have different lengths. *) +val combine_local : + local_ 'a iarray -> local_ 'b iarray -> local_ ('a * 'b) iarray +(** The locally-allocating version of [combine]. *) + (** {1 Sorting} *) +(* CR-someday aspectorzabusky: The comparison functions could be [local_] if we + changed [Array] *) + val sort : ('a -> 'a -> int) -> 'a iarray -> 'a iarray (** Sort an immutable array in increasing order according to a comparison function. The comparison function must return 0 if its arguments @@ -229,6 +472,12 @@ val sort : ('a -> 'a -> int) -> 'a iarray -> 'a iarray - [cmp a'.:(i) a'.:(j)] >= 0 if and only if i >= j *) +(* MISSING: Requires rewriting the sorting algorithms +val sort_local : + (local_ 'a -> local_ 'a -> int) -> local_ 'a iarray -> local_ 'a iarray +(** The locally-constrained and locally-allocating version of [sort]. *) +*) + val stable_sort : ('a -> 'a -> int) -> 'a iarray -> 'a iarray (** Same as {!sort}, but the sorting algorithm is stable (i.e. elements that compare equal are kept in their original order) and @@ -239,26 +488,54 @@ val stable_sort : ('a -> 'a -> int) -> 'a iarray -> 'a iarray faster than the current implementation of {!sort}. *) +(* MISSING: Requires rewriting the sorting algorithms +val stable_sort_local : + (local_ 'a -> local_ 'a -> int) -> local_ 'a iarray -> local_ 'a iarray +(** The locally-constrained and locally-allocating version of [stable_sort]. *) +*) + val fast_sort : ('a -> 'a -> int) -> 'a iarray -> 'a iarray (** Same as {!sort} or {!stable_sort}, whichever is faster on typical input. *) +(* MISSING: Requires rewriting the sorting algorithms +val fast_sort_local : + (local_ 'a -> local_ 'a -> int) -> local_ 'a iarray -> local_ 'a iarray +(** The locally-constrained and locally-allocating version of [fast_sort]. *) +*) + (** {1 Iterators} *) val to_seq : 'a iarray -> 'a Seq.t (** Iterate on the immutable array, in increasing order. *) +(* MISSING: No meaningful local [Seq.t]s +val to_seq_local : local_ 'a iarray -> local_ 'a Seq.t +(** The locally-allocating version of [to_seq]. *) +*) + val to_seqi : 'a iarray -> (int * 'a) Seq.t (** Iterate on the immutable array, in increasing order, yielding indices along elements. *) +(* MISSING: No meaningful local [Seq.t]s +val to_seqi_local : local_ 'a iarray -> local_ (int * 'a) Seq.t +(** The locally-allocating version of [to_seqi]. *) +*) + val of_seq : 'a Seq.t -> 'a iarray (** Create an immutable array from the generator *) +(* MISSING: No meaningful local [Seq.t]s +val of_seq_local : local_ 'a Seq.t -> local_ 'a iarray +(** The locally-allocating version of [of_seq]. *) +*) + (**/**) (** {1 Undocumented functions} *) (* The following is for system use only. Do not call directly. *) -external unsafe_get : 'a iarray -> int -> 'a = "%array_unsafe_get" +external unsafe_get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_unsafe_get" diff --git a/stdlib/iarrayLabels.ml b/stdlib/iarrayLabels.ml index dc5a4439278..3983b085f6d 100644 --- a/stdlib/iarrayLabels.ml +++ b/stdlib/iarrayLabels.ml @@ -23,6 +23,10 @@ open! Stdlib [@@@ocaml.nolabels] +(* NOTE: Please work in iarray.ml and then copy the results here; for more + information, see the top of that file. This is a temporary state of affairs, + but for now, please copy things! *) + (* CR mshinwell: Change to "include Iarray"; we can't do this at present as it requires referencing Stdlib__Iarray which will work under the make build but not under dune. *) @@ -32,86 +36,324 @@ type +'a t = 'a iarray (* Array operations *) -external length : 'a iarray -> int = "%array_length" -external get : 'a iarray -> int -> 'a = "%array_safe_get" -external ( .:() ) : 'a iarray -> int -> 'a = "%array_safe_get" -external unsafe_get : 'a iarray -> int -> 'a = "%array_unsafe_get" +external length : local_ 'a iarray -> int = "%array_length" +external get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" +external ( .:() ) : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" +external unsafe_get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_unsafe_get" external concat : 'a iarray list -> 'a iarray = "caml_array_concat" +external concat_local : local_ 'a iarray list -> local_ 'a iarray = + "caml_array_concat_local" external append_prim : 'a iarray -> 'a iarray -> 'a iarray = "caml_array_append" +external append_prim_local : + local_ 'a iarray -> local_ 'a iarray -> local_ 'a iarray = + "caml_array_append_local" external unsafe_sub : 'a iarray -> int -> int -> 'a iarray = "caml_array_sub" +external unsafe_sub_local : local_ 'a iarray -> int -> int -> local_ 'a iarray = + "caml_array_sub_local" external unsafe_of_array : 'a array -> 'a iarray = "%array_to_iarray" external unsafe_to_array : 'a iarray -> 'a array = "%array_of_iarray" -let init l f = unsafe_of_array (Array.init l f) +(* Used only to reimplement [init] *) +external unsafe_set_mutable : 'a array -> int -> 'a -> unit = + "%array_unsafe_set" + +(* VERY UNSAFE: Any of these functions can be used to violate the "no forward + pointers" restriction for the local stack if not used carefully. Each of + these can either make a local mutable array or mutate its contents, and if + not careful, this can lead to an array's contents pointing forwards. *) +external make_mutable_local : int -> local_ 'a -> local_ 'a array = + "caml_make_local_vect" +external unsafe_of_local_array : local_ 'a array -> local_ 'a iarray = + "%array_to_iarray" +external unsafe_set_local : local_ 'a array -> int -> local_ 'a -> unit = + "%array_unsafe_set" + +(* We can't use immutable array literals in this file, since we don't want to + require the stdlib to be compiled with extensions, so instead of [[::]] we + use [unsafe_of_array [||]] below. Thankfully, we never need it in the + [local] case so we don't have to think about the details. *) + +(* Really trusting the inliner here; to get maximum performance, it has to + inline both [unsafe_init_local] *and* [f]. *) +(** Precondition: [l >= 0]. *) +let[@inline always] unsafe_init_local l (local_ f : int -> local_ 'a) = local_ + if l = 0 then + unsafe_of_local_array [||] + else + (* The design of this function is exceedingly delicate, and is the only way + we can correctly allocate a local array on the stack via mutation. We + are subject to the "no forward pointers" constraint on the local stack; + we're not allowed to make pointers to later-allocated objects even within + the same stack frame. Thus, in order to get this right, we consume O(n) + call-stack space: we allocate the values to put in the array, and only + *then* recurse, creating the array as the very last thing of all and + *returning* it. This is why the [f i] call is the first thing in the + function, and why it's not tail-recursive; if it were tail-recursive, + then we wouldn't have anywhere to put the array elements during the whole + process. *) + let rec go i = local_ begin + let x = f i in + if i = l - 1 then + make_mutable_local l x + else begin + let res = go (i+1) in + unsafe_set_local res i x; + res + end + end in + unsafe_of_local_array (go 0) + +(* The implementation is copied from [Array] so that [f] can be [local_] *) +let init l (local_ f) = + if l = 0 then unsafe_of_array [||] else + if l < 0 then invalid_arg "Iarray.init" + (* See #6575. We could also check for maximum array size, but this depends + on whether we create a float array or a regular one... *) + else + let res = Array.make l (f 0) in + for i = 1 to pred l do + unsafe_set_mutable res i (f i) + done; + unsafe_of_array res + +let init_local l f = local_ + if l < 0 then invalid_arg "Iarray.init_local" + (* See #6575. We could also check for maximum array size, but this depends + on whether we create a float array or a regular one... *) + else unsafe_init_local l f let append a1 a2 = if length a1 = 0 then a2 (* Safe because they're immutable *) else if length a2 = 0 then a1 else append_prim a1 a2 +let append_local a1 a2 = local_ + if length a1 = 0 then a2 (* Safe because they're immutable *) + else if length a2 = 0 then a1 + else append_prim_local a1 a2 + let sub a ofs len = if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Iarray.sub" else unsafe_sub a ofs len +let sub_local a ofs len = local_ + if ofs < 0 || len < 0 || ofs > length a - len + then invalid_arg "Iarray.sub" + else unsafe_sub_local a ofs len + let iter f a = for i = 0 to length a - 1 do f(unsafe_get a i) done +let iter_local f a = + for i = 0 to length a - 1 do f(unsafe_get a i) done + let iter2 f a b = if length a <> length b then invalid_arg "Iarray.iter2: arrays must have the same length" else for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done +let iter2_local f a b = + if length a <> length b then + invalid_arg "Iarray.iter2_local: arrays must have the same length" + else + for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done + +let iter2_local_first f a b = + if length a <> length b then + invalid_arg "Iarray.iter2_local_first: arrays must have the same length" + else + for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done + +let iter2_local_second f a b = + if length a <> length b then + invalid_arg "Iarray.iter2_local_second: arrays must have the same length" + else + for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done + let map f a = let l = length a in - let r = if l = 0 then [||] else begin + if l = 0 then unsafe_of_array [||] else begin let r = Array.make l (f(unsafe_get a 0)) in for i = 1 to l - 1 do Array.unsafe_set r i (f(unsafe_get a i)) done; - r - end in - unsafe_of_array r + unsafe_of_array r + end + +let map_local f a = local_ + unsafe_init_local (length a) (fun i -> local_ f (unsafe_get a i)) + +let map_local_input f a = + let l = length a in + if l = 0 then unsafe_of_array [||] else begin + let r = Array.make l (f(unsafe_get a 0)) in + for i = 1 to l - 1 do + Array.unsafe_set r i (f(unsafe_get a i)) + done; + unsafe_of_array r + end + +let map_local_output f a = local_ + unsafe_init_local (length a) (fun i -> local_ f (unsafe_get a i)) let map2 f a b = let la = length a in let lb = length b in if la <> lb then - invalid_arg "Array.map2: arrays must have the same length" + invalid_arg "Iarray.map2: arrays must have the same length" else begin - let r = if la = 0 then [||] else begin + if la = 0 then unsafe_of_array [||] else begin let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in for i = 1 to la - 1 do Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) done; - r - end in - unsafe_of_array r + unsafe_of_array r + end + end + +let map2_local f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + +let map2_local_inputs f a b = + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2: arrays must have the same length" + else begin + if la = 0 then unsafe_of_array [||] else begin + let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in + for i = 1 to la - 1 do + Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + unsafe_of_array r + end end +let map2_local_output f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + +let map2_local_first_input f a b = + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2: arrays must have the same length" + else begin + if la = 0 then unsafe_of_array [||] else begin + let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in + for i = 1 to la - 1 do + Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + unsafe_of_array r + end + end + +let map2_local_second_input f a b = + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2: arrays must have the same length" + else begin + if la = 0 then unsafe_of_array [||] else begin + let r = Array.make la (f (unsafe_get a 0) (unsafe_get b 0)) in + for i = 1 to la - 1 do + Array.unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + unsafe_of_array r + end + end + +let map2_local_first_input_and_output f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + +let map2_local_second_input_and_output f a b = local_ + let la = length a in + let lb = length b in + if la <> lb then + invalid_arg "Iarray.map2_local: arrays must have the same length" + else + unsafe_init_local la (fun i -> local_ f (unsafe_get a i) (unsafe_get b i)) + let iteri f a = for i = 0 to length a - 1 do f i (unsafe_get a i) done +let iteri_local f a = + for i = 0 to length a - 1 do f i (unsafe_get a i) done + let mapi f a = let l = length a in - let r = if l = 0 then [||] else begin + if l = 0 then unsafe_of_array [||] else begin let r = Array.make l (f 0 (unsafe_get a 0)) in for i = 1 to l - 1 do Array.unsafe_set r i (f i (unsafe_get a i)) done; - r - end in - unsafe_of_array r + unsafe_of_array r + end + +let mapi_local f a = local_ + unsafe_init_local (length a) (fun i -> local_ f i (unsafe_get a i)) + +let mapi_local_input f a = + let l = length a in + if l = 0 then unsafe_of_array [||] else begin + let r = Array.make l (f 0 (unsafe_get a 0)) in + for i = 1 to l - 1 do + Array.unsafe_set r i (f i (unsafe_get a i)) + done; + unsafe_of_array r + end + +let mapi_local_output f a = local_ + unsafe_init_local (length a) (fun i -> local_ f i (unsafe_get a i)) let to_list a = let rec tolist i res = if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in tolist (length a - 1) [] +let to_list_local a = local_ + let rec tolist i res = local_ + if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in + tolist (length a - 1) [] + let of_list l = unsafe_of_array (Array.of_list l) +(* Cannot use List.length here because the List module depends on Array. *) +let rec list_length accu = function + | [] -> accu + | _::t -> list_length (succ accu) t + +(* This shouldn't violate the forward-pointers restriction because the list + elements already exist *) +let of_list_local = function + | [] -> local_ unsafe_of_array [||] + | hd::tl as l -> local_ + let a = make_mutable_local (list_length 0 l) hd in + let rec fill i = function + | [] -> local_ a + | hd::tl -> local_ unsafe_set_local a i hd; fill (i+1) tl in + unsafe_of_local_array (fill 1 tl) + let to_array ia = Array.copy (unsafe_to_array ia) let of_array ma = unsafe_of_array (Array.copy ma) @@ -123,9 +365,34 @@ let fold_left f x a = done; !r +let fold_left_local f x a = local_ + let len = length a in + let rec go r i = local_ + if i = len + then r + else go (f r (unsafe_get a i)) (i+1) + in + go x 0 + +let fold_left_local_input f x a = + let r = ref x in + for i = 0 to length a - 1 do + r := f !r (unsafe_get a i) + done; + !r + +let fold_left_local_output f x a = local_ + let len = length a in + let rec go r i = local_ + if i = len + then r + else go (f r (unsafe_get a i)) (i+1) + in + go x 0 + let fold_left_map f acc input_array = let len = length input_array in - let acc, output_array = if len = 0 then (acc, [||]) else begin + if len = 0 then (acc, unsafe_of_array [||]) else begin let acc, elt = f acc (unsafe_get input_array 0) in let output_array = Array.make len elt in let acc = ref acc in @@ -134,9 +401,56 @@ let fold_left_map f acc input_array = acc := acc'; Array.unsafe_set output_array i elt; done; - !acc, output_array - end in - acc, unsafe_of_array output_array + !acc, unsafe_of_array output_array + end + +let fold_left_map_local f acc input_array = local_ + let len = length input_array in + if len = 0 then (acc, unsafe_of_local_array [||]) else begin + let rec go acc i = local_ + let acc', elt = f acc (unsafe_get input_array i) in + if i = len - 1 then + acc', make_mutable_local len elt + else begin + let (_, output_array) as res = go acc (i+1) in + unsafe_set_local output_array i elt; + res + end + in + let acc, output_array = go acc 0 in + acc, unsafe_of_local_array output_array + end + +let fold_left_map_local_input f acc input_array = + let len = length input_array in + if len = 0 then (acc, unsafe_of_array [||]) else begin + let acc, elt = f acc (unsafe_get input_array 0) in + let output_array = Array.make len elt in + let acc = ref acc in + for i = 1 to len - 1 do + let acc', elt = f !acc (unsafe_get input_array i) in + acc := acc'; + Array.unsafe_set output_array i elt; + done; + !acc, unsafe_of_array output_array + end + +let fold_left_map_local_output f acc input_array = local_ + let len = length input_array in + if len = 0 then (acc, unsafe_of_local_array [||]) else begin + let rec go acc i = local_ + let acc', elt = f acc (unsafe_get input_array i) in + if i = len - 1 then + acc', make_mutable_local len elt + else begin + let (_, output_array) as res = go acc (i+1) in + unsafe_set_local output_array i elt; + res + end + in + let acc, output_array = go acc 0 in + acc, unsafe_of_local_array output_array + end let fold_right f a x = let r = ref x in @@ -145,57 +459,160 @@ let fold_right f a x = done; !r +let fold_right_local f a x = local_ + let rec go r i = local_ + if i = -1 + then r + else go (f (unsafe_get a i) r) (i-1) + in + go x (length a - 1) + +let fold_right_local_input f a x = + let r = ref x in + for i = length a - 1 downto 0 do + r := f (unsafe_get a i) !r + done; + !r + +let fold_right_local_output f a x = local_ + let rec go r i = local_ + if i = -1 + then r + else go (f (unsafe_get a i) r) (i-1) + in + go x (length a - 1) + +(* CR aspectorzabusky: Why do I need this? Shouldn't mode-crossing handle doing + this? *) +let[@inline always] globalize_bool : local_ bool -> bool = fun b -> b + let exists p a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then false else if p (unsafe_get a i) then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) + +let exists_local p a = + let n = length a in + let rec loop i = local_ + if i = n then false + else if p (unsafe_get a i) then true + else loop (succ i) in + globalize_bool (loop 0) let for_all p a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then true else if p (unsafe_get a i) then loop (succ i) else false in - loop 0 + globalize_bool (loop 0) + +let for_all_local p a = + let n = length a in + let rec loop i = local_ + if i = n then true + else if p (unsafe_get a i) then loop (succ i) + else false in + globalize_bool (loop 0) let for_all2 p l1 l2 = let n1 = length l1 and n2 = length l2 in if n1 <> n2 then invalid_arg "Iarray.for_all2" - else let rec loop i = + else let rec loop i = local_ if i = n1 then true else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) else false in - loop 0 + globalize_bool (loop 0) + +let for_all2_local p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.for_all2_local" + else let rec loop i = local_ + if i = n1 then true + else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) + else false in + globalize_bool (loop 0) + +let for_all2_local_first p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.for_all2_local_first" + else let rec loop i = local_ + if i = n1 then true + else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) + else false in + globalize_bool (loop 0) + +let for_all2_local_second p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.for_all2_local_second" + else let rec loop i = local_ + if i = n1 then true + else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i) + else false in + globalize_bool (loop 0) let exists2 p l1 l2 = let n1 = length l1 and n2 = length l2 in if n1 <> n2 then invalid_arg "Iarray.exists2" - else let rec loop i = + else let rec loop i = local_ if i = n1 then false else if p (unsafe_get l1 i) (unsafe_get l2 i) then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) + +let exists2_local p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.exists2_local" + else let rec loop i = local_ + if i = n1 then false + else if p (unsafe_get l1 i) (unsafe_get l2 i) then true + else loop (succ i) in + globalize_bool (loop 0) + +let exists2_local_first p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.exists2_local_first" + else let rec loop i = local_ + if i = n1 then false + else if p (unsafe_get l1 i) (unsafe_get l2 i) then true + else loop (succ i) in + globalize_bool (loop 0) + +let exists2_local_second p l1 l2 = + let n1 = length l1 + and n2 = length l2 in + if n1 <> n2 then invalid_arg "Iarray.exists2_local_second" + else let rec loop i = local_ + if i = n1 then false + else if p (unsafe_get l1 i) (unsafe_get l2 i) then true + else loop (succ i) in + globalize_bool (loop 0) let mem x a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then false else if compare (unsafe_get a i) x = 0 then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) let memq x a = let n = length a in - let rec loop i = + let rec loop i = local_ if i = n then false else if x == (unsafe_get a i) then true else loop (succ i) in - loop 0 + globalize_bool (loop 0) let find_opt p a = let n = length a in @@ -206,6 +623,17 @@ let find_opt p a = if p x then Some x else loop (succ i) in + loop 0 [@nontail] + +let find_opt_local p a = local_ + let n = length a in + let rec loop i = local_ + if i = n then None + else + let x = unsafe_get a i in + if p x then Some x + else loop (succ i) + in loop 0 let find_map f a = @@ -217,12 +645,44 @@ let find_map f a = | None -> loop (succ i) | Some _ as r -> r in + loop 0 [@nontail] + +let find_map_local f a = local_ + let n = length a in + let rec loop i = local_ + if i = n then None + else + match f (unsafe_get a i) with + | None -> loop (succ i) + | Some _ as r -> r + in + loop 0 + +let find_map_local_input f a = + let n = length a in + let rec loop i = + if i = n then None + else + match f (unsafe_get a i) with + | None -> loop (succ i) + | Some _ as r -> r + in + loop 0 [@nontail] + +let find_map_local_output f a = local_ + let n = length a in + let rec loop i = local_ + if i = n then None + else + match f (unsafe_get a i) with + | None -> loop (succ i) + | Some _ as r -> r + in loop 0 let split x = - (* We can't use immutable array literals here, since we don't want to require - the stdlib to be compiled with extensions *) - let r1, r2 = if x = unsafe_of_array [||] then [||], [||] + if x = unsafe_of_array [||] + then unsafe_of_array [||], unsafe_of_array [||] else begin let a0, b0 = unsafe_get x 0 in let n = length x in @@ -233,14 +693,32 @@ let split x = Array.unsafe_set a i ai; Array.unsafe_set b i bi done; - a, b - end in - unsafe_of_array r1, unsafe_of_array r2 + unsafe_of_array a, unsafe_of_array b + end + +(* This shouldn't violate the forward-pointers restriction because the array + elements already exist. (This doesn't work for [combine], where we need to + create the tuples.) *) +let split_local x = local_ + if x = unsafe_of_array [||] + then unsafe_of_array [||], unsafe_of_array [||] + else begin + let a0, b0 = unsafe_get x 0 in + let n = length x in + let a = make_mutable_local n a0 in + let b = make_mutable_local n b0 in + for i = 1 to n - 1 do + let ai, bi = unsafe_get x i in + unsafe_set_local a i ai; + unsafe_set_local b i bi + done; + unsafe_of_local_array a, unsafe_of_local_array b + end let combine a b = let na = length a in let nb = length b in - if na <> nb then invalid_arg "Array.combine"; + if na <> nb then invalid_arg "Iarray.combine"; let r = if na = 0 then [||] else begin let x = Array.make na (unsafe_get a 0, unsafe_get b 0) in @@ -251,6 +729,12 @@ let combine a b = end in unsafe_of_array r +let combine_local a b = local_ + let na = length a in + let nb = length b in + if na <> nb then invalid_arg "Iarray.combine_local"; + unsafe_init_local na (fun i -> local_ unsafe_get a i, unsafe_get b i) + (* Must be fully applied due to the value restriction *) let lift_sort sorter cmp iarr = let arr = to_array iarr in diff --git a/stdlib/iarrayLabels.mli b/stdlib/iarrayLabels.mli index 7e9d0567dc1..b4f895b0750 100644 --- a/stdlib/iarrayLabels.mli +++ b/stdlib/iarrayLabels.mli @@ -25,9 +25,6 @@ open! Stdlib iarrayLabels.mli instead. *) -(* If you update any types in this module, you need to update iarray.ml as well; - it uses Obj.magic, so changes won't be detected. *) - (** Operations on immutable arrays. This module mirrors the API of [Array], but omits functions that assume mutability; in addition to obviously mutating functions, it omits [copy] along with the functions [make], [create_float], @@ -38,10 +35,11 @@ open! Stdlib type +'a t = 'a iarray (** An alias for the type of immutable arrays. *) -external length : 'a iarray -> int = "%array_length" +external length : local_ 'a iarray -> int = "%array_length" (** Return the length (number of elements) of the given immutable array. *) -external get : 'a iarray -> int -> 'a = "%array_safe_get" +external get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_safe_get" (** [get a n] returns the element number [n] of immutable array [a]. The first element has number 0. The last element has number [length a - 1]. @@ -50,10 +48,11 @@ external get : 'a iarray -> int -> 'a = "%array_safe_get" @raise Invalid_argument if [n] is outside the range 0 to [(length a - 1)]. *) -external ( .:() ) : 'a iarray -> int -> 'a = "%array_safe_get" +external ( .:() ) : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) + = "%array_safe_get" (** A synonym for [get]. *) -val init : int -> f:(int -> 'a) -> 'a iarray +val init : int -> f:local_ (int -> 'a) -> 'a iarray (** [init n ~f] returns a fresh immutable array of length [n], with element number [i] initialized to the result of [f i]. In other terms, [init n ~f] tabulates the results of [f] @@ -63,15 +62,24 @@ val init : int -> f:(int -> 'a) -> 'a iarray If the return type of [f] is [float], then the maximum size is only [Sys.max_array_length / 2]. *) +val init_local : int -> f:local_ (int -> local_ 'a) -> local_ 'a iarray +(** The locally-allocating version of [init]. *) + val append : 'a iarray -> 'a iarray -> 'a iarray (** [append v1 v2] returns a fresh immutable array containing the concatenation of the immutable arrays [v1] and [v2]. @raise Invalid_argument if [length v1 + length v2 > Sys.max_array_length]. *) +val append_local : local_ 'a iarray -> local_ 'a iarray -> local_ 'a iarray +(** The locally-allocating version of [append]. *) + val concat : 'a iarray list -> 'a iarray (** Same as {!append}, but concatenates a list of immutable arrays. *) +val concat_local : local_ 'a iarray list -> local_ 'a iarray +(** The locally-allocating version of [concat]. *) + val sub : 'a iarray -> pos:int -> len:int -> 'a iarray (** [sub a ~pos ~len] returns a fresh immutable array of length [len], containing the elements number [pos] to [pos + len - 1] @@ -82,9 +90,15 @@ val sub : 'a iarray -> pos:int -> len:int -> 'a iarray designate a valid subarray of [a]; that is, if [pos < 0], or [len < 0], or [pos + len > length a]. *) +val sub_local : local_ 'a iarray -> int -> int -> local_ 'a iarray +(** The locally-allocating version of [sub]. *) + val to_list : 'a iarray -> 'a list (** [to_list a] returns the list of all the elements of [a]. *) +val to_list_local : local_ 'a iarray -> local_ 'a list +(** The locally-allocating version of []. *) + val of_list : 'a list -> 'a iarray (** [of_list l] returns a fresh immutable array containing the elements of [l]. @@ -92,6 +106,9 @@ val of_list : 'a list -> 'a iarray @raise Invalid_argument if the length of [l] is greater than [Sys.max_array_length]. *) +val of_list_local : local_ 'a list -> local_ 'a iarray +(** The locally-allocating version of [of_list]. *) + (** {1 Converting to and from mutable arrays} *) val to_array : 'a iarray -> 'a array @@ -104,111 +121,342 @@ val of_array : 'a array -> 'a iarray (** {1 Iterators} *) -val iter : f:('a -> unit) -> 'a iarray -> unit +val iter : f:local_ ('a -> unit) -> 'a iarray -> unit (** [iter ~f a] applies function [f] in turn to all the elements of [a]. It is equivalent to [f a.:(0); f a.:(1); ...; f a.:(length a - 1); ()]. *) -val iteri : f:(int -> 'a -> unit) -> 'a iarray -> unit +val iter_local : f:local_ (local_ 'a -> unit) -> local_ 'a iarray -> unit +(** The locally-scoped version of [iter]. *) + +val iteri : f:local_ (int -> 'a -> unit) -> 'a iarray -> unit (** Same as {!iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) -val map : f:('a -> 'b) -> 'a iarray -> 'b iarray +val iteri_local : + f:local_ (int -> local_ 'a -> unit) -> local_ 'a iarray -> unit +(** The locally-scoped version of [iteri]. *) + +val map : f:local_ ('a -> 'b) -> 'a iarray -> 'b iarray (** [map ~f a] applies function [f] to all the elements of [a], and builds an immutable array with the results returned by [f]: [[| f a.:(0); f a.:(1); ...; f a.:(length a - 1) |]]. *) -val mapi : f:(int -> 'a -> 'b) -> 'a iarray -> 'b iarray +val map_local : + f:local_ (local_ 'a -> local_ 'b) -> local_ 'a iarray -> local_ 'b iarray +(** The locally-scoped and locally-allocating version of [map]. *) + +val map_local_input : + f:local_ (local_ 'a -> 'b) -> local_ 'a iarray -> 'b iarray +(** The locally-constrained but globally-allocating version of [map]. *) + +val map_local_output : + f:local_ ('a -> local_ 'b) -> 'a iarray -> local_ 'b iarray +(** The locally-allocating but global-input version of [map]. *) + +val mapi : f:local_ (int -> 'a -> 'b) -> 'a iarray -> 'b iarray (** Same as {!map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) -val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b iarray -> 'a +val mapi_local : + f:local_ (int -> local_ 'a -> local_ 'b) -> + local_ 'a iarray -> + local_ 'b iarray +(** The locally-scoped and locally-allocating version of [mapi]. *) + +val mapi_local_input : + f:local_ (int -> local_ 'a -> 'b) -> local_ 'a iarray -> 'b iarray +(** The locally-constrained but globally-allocating version of [mapi]. *) + +val mapi_local_output : + f:local_ (int -> 'a -> local_ 'b) -> 'a iarray -> local_ 'b iarray +(** The locally-allocating but global-input version of [mapi]. *) + +val fold_left : f:local_ ('a -> 'b -> 'a) -> init:'a -> 'b iarray -> 'a (** [fold_left ~f ~init a] computes [f (... (f (f init a.:(0)) a.:(1)) ...) a.:(n-1)], where [n] is the length of the immutable array [a]. *) +val fold_left_local : + f:local_ (local_ 'a -> local_ 'b -> local_ 'a) -> + init:local_ 'a -> + local_ 'b iarray -> + local_ 'a +(** The locally-constrained and locally-allocating version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_left_local_input : + f:local_ ('a -> local_ 'b -> 'a) -> init:'a -> local_ 'b iarray -> 'a +(** The locally-constrained but globally-allocating version of [fold_left]. *) + +val fold_left_local_output : + f:local_ (local_ 'a -> 'b -> local_ 'a) -> + init:local_ 'a -> + 'b iarray -> + local_ 'a +(** The locally-allocating but global-input version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + val fold_left_map : - f:('a -> 'b -> 'a * 'c) -> init:'a -> 'b iarray -> 'a * 'c iarray + f:local_ ('a -> 'b -> 'a * 'c) -> init:'a -> 'b iarray -> 'a * 'c iarray (** [fold_left_map] is a combination of {!fold_left} and {!map} that threads an accumulator through calls to [f]. *) -val fold_right : f:('b -> 'a -> 'a) -> 'b iarray -> init:'a -> 'a +val fold_left_map_local : + f:local_ (local_ 'a -> local_ 'b -> local_ 'a * 'c) -> + init:local_ 'a -> + local_ 'b iarray -> + local_ 'a * 'c iarray +(** The locally-constrained and locally-allocating version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_left_map_local_input : + f:local_ ('a -> local_ 'b -> 'a * 'c) -> + init:'a -> + local_ 'b iarray -> + 'a * 'c iarray +(** The locally-constrained but globally-allocating version of [fold_left]. *) + +val fold_left_map_local_output : + f:local_ (local_ 'a -> 'b -> local_ 'a * 'c) -> + init:local_ 'a -> + 'b iarray -> + local_ 'a * 'c iarray +(** The locally-allocating but global-input version of [fold_left]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_right : f:local_ ('b -> 'a -> 'a) -> 'b iarray -> init:'a -> 'a (** [fold_right ~f a ~init] computes [f a.:(0) (f a.:(1) ( ... (f a.:(n-1) init) ...))], where [n] is the length of the immutable array [a]. *) +val fold_right_local : + f:local_ (local_ 'b -> local_ 'a -> local_ 'a) -> + local_ 'b iarray -> + init:local_ 'a -> + local_ 'a +(** The locally-constrained and locally-allocating version of [fold_right]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + +val fold_right_local_input : + f:local_ (local_ 'b -> 'a -> 'a) -> local_ 'b iarray -> init:'a -> 'a +(** The locally-constrained but globally-allocating version of [fold_right]. *) + +val fold_right_local_output : + f:local_ ('b -> local_ 'a -> local_ 'a) -> + 'b iarray -> + init:local_ 'a -> + local_ 'a +(** The locally-allocating but global-input version of [fold_right]. + + WARNING: This function consumes O(n) extra stack space, as every intermediate + accumulator will be left on the local stack! *) + (** {1 Iterators on two arrays} *) -val iter2 : f:('a -> 'b -> unit) -> 'a iarray -> 'b iarray -> unit +val iter2 : f:local_ ('a -> 'b -> unit) -> 'a iarray -> 'b iarray -> unit (** [iter2 ~f a b] applies function [f] to all the elements of [a] and [b]. @raise Invalid_argument if the immutable arrays are not the same size. *) -val map2 : f:('a -> 'b -> 'c) -> 'a iarray -> 'b iarray -> 'c iarray +val iter2_local : + f:local_ (local_ 'a -> local_ 'b -> unit) -> + local_ 'a iarray -> + local_ 'b iarray -> + unit +(** The locally-scoped version of [iter2]. *) + +val iter2_local_first : + f:local_ (local_ 'a -> 'b -> unit) -> local_ 'a iarray -> 'b iarray -> unit +(** The first-biased partly-locally-scoped version of [iter2]. *) + +val iter2_local_second : + f:local_ ('a -> local_ 'b -> unit) -> 'a iarray -> local_ 'b iarray -> unit +(** The second-biased partly-locally-scoped version of [iter2]. *) + +val map2 : f:local_ ('a -> 'b -> 'c) -> 'a iarray -> 'b iarray -> 'c iarray (** [map2 ~f a b] applies function [f] to all the elements of [a] and [b], and builds an immutable array with the results returned by [f]: [[| f a.:(0) b.:(0); ...; f a.:(length a - 1) b.:(length b - 1)|]]. @raise Invalid_argument if the immutable arrays are not the same size. *) +val map2_local : + f:local_ (local_ 'a -> local_ 'b -> local_ 'c) -> + local_ 'a iarray -> + local_ 'b iarray -> + local_ 'c iarray +(** The locally-scoped and locally-allocating version of [map2]. *) + +val map2_local_inputs : + f:local_ (local_ 'a -> local_ 'b -> 'c) -> + local_ 'a iarray -> + local_ 'b iarray -> + 'c iarray +(** The locally-scoped but globally-allocating version of [map2]. *) + +val map2_local_output : + f:local_ ('a -> 'b -> local_ 'c) -> 'a iarray -> 'b iarray -> local_ 'c iarray +(** The locally-allocating but global-inputs version of [map2]. *) + +val map2_local_first_input : + f:local_ (local_ 'a -> 'b -> 'c) -> local_ 'a iarray -> 'b iarray -> 'c iarray +(** The first-biased partly-locally-scoped but globally-allocating version of + [map2]. *) + +val map2_local_second_input : + f:local_ ('a -> local_ 'b -> 'c) -> 'a iarray -> local_ 'b iarray -> 'c iarray +(** The second-biased partly-locally-scoped but globally-allocating version of + [map2]. *) + +val map2_local_first_input_and_output : + f:local_ (local_ 'a -> 'b -> local_ 'c) -> + local_ 'a iarray -> + 'b iarray -> + local_ 'c iarray +(** The locally-allocating and first-biased partly-locally-scoped version of + [map2]. *) + +val map2_local_second_input_and_output : + f:local_ ('a -> local_ 'b -> local_ 'c) -> + 'a iarray -> + local_ 'b iarray -> + local_ 'c iarray +(** The locally-allocating and second-biased partly-locally-scoped version of + [map2]. *) + (** {1 Array scanning} *) -val for_all : f:('a -> bool) -> 'a iarray -> bool +val for_all : f:local_ ('a -> bool) -> 'a iarray -> bool (** [for_all ~f [|a1; ...; an|]] checks if all elements of the immutable array satisfy the predicate [f]. That is, it returns [(f a1) && (f a2) && ... && (f an)]. *) -val exists : f:('a -> bool) -> 'a iarray -> bool +val for_all_local : f:local_ (local_ 'a -> bool) -> local_ 'a iarray -> bool +(** The locally-scoped version of [for_all]. *) + +val exists : f:local_ ('a -> bool) -> 'a iarray -> bool (** [exists ~f [|a1; ...; an|]] checks if at least one element of the immutable array satisfies the predicate [f]. That is, it returns [(f a1) || (f a2) || ... || (f an)]. *) -val for_all2 : f:('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool +val exists_local : f:local_ (local_ 'a -> bool) -> local_ 'a iarray -> bool +(** The locally-scoped version of [exists]. *) + +val for_all2 : f:local_ ('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool (** Same as {!for_all}, but for a two-argument predicate. @raise Invalid_argument if the two immutable arrays have different lengths. *) -val exists2 : f:('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool +val for_all2_local : + f:local_ (local_ 'a -> local_ 'b -> bool) -> + local_ 'a iarray -> + local_ 'b iarray -> + bool +(** The locally-scoped version of [for_all2]. *) + +val for_all2_local_first : + f:local_ (local_ 'a -> 'b -> bool) -> local_ 'a iarray -> 'b iarray -> bool +(** The first-biased partly-locally-scoped version of [for_all2]. *) + +val for_all2_local_second : + f:local_ ('a -> local_ 'b -> bool) -> 'a iarray -> local_ 'b iarray -> bool +(** The second-biased partly-locally-scoped version of [for_all2]. *) + +val exists2 : f:local_ ('a -> 'b -> bool) -> 'a iarray -> 'b iarray -> bool (** Same as {!exists}, but for a two-argument predicate. @raise Invalid_argument if the two immutable arrays have different lengths. *) -val mem : 'a -> set:'a iarray -> bool +val exists2_local : + f:local_ (local_ 'a -> local_ 'b -> bool) -> + local_ 'a iarray -> + local_ 'b iarray -> + bool +(** The locally-scoped version of [exists2]. *) + +val exists2_local_first : + f:local_ (local_ 'a -> 'b -> bool) -> local_ 'a iarray -> 'b iarray -> bool +(** The first-biased partly-locally-scoped version of [exists2]. *) + +val exists2_local_second : + f:local_ ('a -> local_ 'b -> bool) -> 'a iarray -> local_ 'b iarray -> bool +(** The second-biased partly-locally-scoped version of [exists2]. *) + +val mem : local_ 'a -> set:local_ 'a iarray -> bool (** [mem a ~set] is true if and only if [a] is structurally equal to an element of [l] (i.e. there is an [x] in [l] such that [compare a x = 0]). *) -val memq : 'a -> set:'a iarray -> bool +val memq : local_ 'a -> set:local_ 'a iarray -> bool (** Same as {!mem}, but uses physical equality instead of structural equality to compare list elements. *) -val find_opt : f:('a -> bool) -> 'a iarray -> 'a option +val find_opt : f:local_ ('a -> bool) -> 'a iarray -> 'a option (** [find_opt ~f a] returns the first element of the immutable array [a] that satisfies the predicate [f], or [None] if there is no value that satisfies [f] in the array [a]. *) -val find_map : f:('a -> 'b option) -> 'a iarray -> 'b option +val find_opt_local : + f:local_ (local_ 'a -> bool) -> local_ 'a iarray -> local_ 'a option +(** The locally-constrained and locally-allocating version of []. *) + +val find_map : f:local_ ('a -> 'b option) -> 'a iarray -> 'b option (** [find_map ~f a] applies [f] to the elements of [a] in order, and returns the first result of the form [Some v], or [None] if none exist. *) +val find_map_local : + f:local_ (local_ 'a -> local_ 'b option) -> + local_ 'a iarray -> + local_ 'b option +(** The locally-constrained and locally-allocating version of [find_map]. *) + +val find_map_local_input : + f:local_ (local_ 'a -> 'b option) -> local_ 'a iarray -> 'b option +(** The locally-constrained but globally-allocating version of [find_map]. *) + +val find_map_local_output : + f:local_ ('a -> local_ 'b option) -> 'a iarray -> local_ 'b option +(** The locally-allocating but global-input version of [find_map]. *) + (** {1 Arrays of pairs} *) val split : ('a * 'b) iarray -> 'a iarray * 'b iarray (** [split [:(a1,b1); ...; (an,bn):]] is [([:a1; ...; an:], [:b1; ...; bn:])]. *) +val split_local : local_ ('a * 'b) iarray -> local_ 'a iarray * 'b iarray +(** The locally-allocating version of [split]. *) + val combine : 'a iarray -> 'b iarray -> ('a * 'b) iarray (** [combine [:a1; ...; an:] [:b1; ...; bn:]] is [[:(a1,b1); ...; (an,bn):]]. Raise [Invalid_argument] if the two immutable iarrays have different lengths. *) +val combine_local : + local_ 'a iarray -> local_ 'b iarray -> local_ ('a * 'b) iarray +(** The locally-allocating version of [combine]. *) + (** {1 Sorting} *) +(* CR-someday aspectorzabusky: The comparison functions could be [local_] if we + changed [Array] *) + val sort : cmp:('a -> 'a -> int) -> 'a iarray -> 'a iarray (** Sort an immutable array in increasing order according to a comparison function. The comparison function must return 0 if its arguments @@ -235,6 +483,12 @@ val sort : cmp:('a -> 'a -> int) -> 'a iarray -> 'a iarray - [cmp a'.:(i) a'.:(j)] >= 0 if and only if i >= j *) +(* MISSING: Requires rewriting the sorting algorithms +val sort_local : + cmp:(local_ 'a -> local_ 'a -> int) -> local_ 'a iarray -> local_ 'a iarray +(** The locally-constrained and locally-allocating version of [sort]. *) +*) + val stable_sort : cmp:('a -> 'a -> int) -> 'a iarray -> 'a iarray (** Same as {!sort}, but the sorting algorithm is stable (i.e. elements that compare equal are kept in their original order) and @@ -245,26 +499,54 @@ val stable_sort : cmp:('a -> 'a -> int) -> 'a iarray -> 'a iarray faster than the current implementation of {!sort}. *) +(* MISSING: Requires rewriting the sorting algorithms +val stable_sort_local : + cmp:(local_ 'a -> local_ 'a -> int) -> local_ 'a iarray -> local_ 'a iarray +(** The locally-constrained and locally-allocating version of [stable_sort]. *) +*) + val fast_sort : cmp:('a -> 'a -> int) -> 'a iarray -> 'a iarray (** Same as {!sort} or {!stable_sort}, whichever is faster on typical input. *) +(* MISSING: Requires rewriting the sorting algorithms +val fast_sort_local : + cmp:(local_ 'a -> local_ 'a -> int) -> local_ 'a iarray -> local_ 'a iarray +(** The locally-constrained and locally-allocating version of [fast_sort]. *) +*) + (** {1 Iterators} *) val to_seq : 'a iarray -> 'a Seq.t (** Iterate on the immutable array, in increasing order. *) +(* MISSING: No meaningful local [Seq.t]s +val to_seq_local : local_ 'a iarray -> local_ 'a Seq.t +(** The locally-allocating version of [to_seq]. *) +*) + val to_seqi : 'a iarray -> (int * 'a) Seq.t (** Iterate on the immutable array, in increasing order, yielding indices along elements. *) +(* MISSING: No meaningful local [Seq.t]s +val to_seqi_local : local_ 'a iarray -> local_ (int * 'a) Seq.t +(** The locally-allocating version of [to_seqi]. *) +*) + val of_seq : 'a Seq.t -> 'a iarray (** Create an immutable array from the generator *) +(* MISSING: No meaningful local [Seq.t]s +val of_seq_local : local_ 'a Seq.t -> local_ 'a iarray +(** The locally-allocating version of [of_seq]. *) +*) + (**/**) (** {1 Undocumented functions} *) (* The following is for system use only. Do not call directly. *) -external unsafe_get : 'a iarray -> int -> 'a = "%array_unsafe_get" +external unsafe_get : ('a iarray[@local_opt]) -> int -> ('a[@local_opt]) = + "%array_unsafe_get" diff --git a/testsuite/tests/lib-array/iarrays_with_variables.ml b/testsuite/tests/lib-array/iarrays_with_variables.ml new file mode 100644 index 00000000000..60188ec4afe --- /dev/null +++ b/testsuite/tests/lib-array/iarrays_with_variables.ml @@ -0,0 +1,58 @@ +(* TEST + flags = "-extension immutable_arrays" + * expect +*) + +let one = Sys.opaque_identity 1;; +let two = Sys.opaque_identity 2;; +let three = Sys.opaque_identity 3;; + +let phi = Sys.opaque_identity 1.618;; +let e = Sys.opaque_identity 2.718281828459045;; +let pi = Sys.opaque_identity 3.14159265358;; + +let alpha = Sys.opaque_identity "alpha";; +let beta = Sys.opaque_identity "beta";; +let gamma = Sys.opaque_identity "gamma";; + +[%%expect{| +val one : int = 1 +val two : int = 2 +val three : int = 3 +val phi : float = 1.618 +val e : float = 2.71828182845904509 +val pi : float = 3.14159265358 +val alpha : string = "alpha" +val beta : string = "beta" +val gamma : string = "gamma" +|}];; + +[:one; two; three:];; +[%%expect{| +- : int iarray = [:1; 2; 3:] +|}];; + +[:0; one; two; three; 4:];; +[%%expect{| +- : int iarray = [:0; 1; 2; 3; 4:] +|}];; + +[:phi; e; pi:];; +[%%expect{| +- : float iarray = [:1.618; 2.71828182845904509; 3.14159265358:] +|}];; + +[:1.414; phi; e; pi; 6.28:];; +[%%expect{| +- : float iarray = [:1.414; 1.618; 2.71828182845904509; 3.14159265358; 6.28:] +|}];; + +[:alpha; beta; gamma:];; +[%%expect{| +- : string iarray = [:"alpha"; "beta"; "gamma":] +|}];; + +[:"Greek:"; alpha; beta; gamma; "delta":];; +[%%expect{| +- : string iarray = [:"Greek:"; "alpha"; "beta"; "gamma"; "delta":] +|}];; diff --git a/testsuite/tests/lib-array/test_iarray.ml b/testsuite/tests/lib-array/test_iarray.ml index 49dfa564991..d3855bf5979 100644 --- a/testsuite/tests/lib-array/test_iarray.ml +++ b/testsuite/tests/lib-array/test_iarray.ml @@ -430,7 +430,7 @@ Iarray.combine [::] [::];; Iarray.combine iarray [: "wrong length" :];; [%%expect{| -Exception: Invalid_argument "Array.combine". +Exception: Invalid_argument "Iarray.combine". |}];; Iarray.sort (Fun.flip Int.compare) iarray, diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml index 5f5976dd547..9cdbbd5308f 100644 --- a/testsuite/tests/typing-local/alloc.ml +++ b/testsuite/tests/typing-local/alloc.ml @@ -473,6 +473,6 @@ let () = run "optionalarg" optionalarg (fun_with_optional_arg, 10); run "optionaleta" optionaleta () - -(* In debug mode, Gc.minor () checks for minor heap->local pointers *) +(* In debug mode, Gc.minor () checks for minor heap->local pointers (and + backwards local pointers, which can't occur here) *) let () = Gc.minor () diff --git a/testsuite/tests/typing-local/float_iarray.heap.reference b/testsuite/tests/typing-local/float_iarray.heap.reference new file mode 100644 index 00000000000..97114426aa6 --- /dev/null +++ b/testsuite/tests/typing-local/float_iarray.heap.reference @@ -0,0 +1,4 @@ + access from literal: Allocation +access from Iarray.init: Allocation + match on literal: Allocation + match on Iarray.init: Allocation diff --git a/testsuite/tests/typing-local/float_iarray.ml b/testsuite/tests/typing-local/float_iarray.ml new file mode 100644 index 00000000000..59da73d9901 --- /dev/null +++ b/testsuite/tests/typing-local/float_iarray.ml @@ -0,0 +1,74 @@ +(* TEST + flags = "-extension immutable_arrays" + * bytecode + reference = "${test_source_directory}/float_iarray.heap.reference" + * stack-allocation + ** native + reference = "${test_source_directory}/float_iarray.stack.reference" + * no-stack-allocation + ** native + reference = "${test_source_directory}/float_iarray.heap.reference" + *) + +(* Testing that local [float iarray]s don't allocate on access. This is a + question because for flat float arrays, accesses have to box the float. *) + +module Iarray = Stdlib__Iarray + +let ( .:() ) = Iarray.( .:() ) + +external opaque_local : local_ 'a -> local_ 'a = "%opaque" + +let ignore_local : local_ 'a -> unit = fun x -> + let _ = local_ opaque_local x in + () + +let run name f x = local_ + let prebefore = Gc.allocated_bytes () in + let before = Gc.allocated_bytes () in + let r = Sys.opaque_identity f x in + let after = Gc.allocated_bytes () in + let delta = + int_of_float ((after -. before) -. (before -. prebefore)) + / (Sys.word_size/8) + in + let msg = + match delta with + | 0 -> "No Allocation" + | n -> "Allocation" + in + Printf.printf "%23s: %s\n" name msg; + r + +(* Testing functions *) + +let test_access : local_ float iarray -> local_ float = + fun iarr -> local_ iarr.:(0) + +let test_match : local_ float iarray -> local_ float = + fun iarr -> + match iarr with + | [: _; two; _ :] -> two + | _ -> assert false + +(* Run the test, keeping the values alive *) +let () = + let local_ r0 = run "access from literal" + test_access + [: 2.7; 3.1; 1.0 :] + in + let local_ r1 = run "access from Iarray.init" + test_access + (Iarray.init_local 10 (fun i -> Float.of_int i)) + in + (* TODO: Matching currently allocates, but that should be fixed eventually *) + let local_ r2 = run "match on literal" + test_match + [: 2.7; 3.1; 1.0 :] + in + let local_ r3 = run "match on Iarray.init" + test_match + (Iarray.init_local 3 (fun i -> Float.of_int i)) + in + ignore_local (r0, r1, r2, r3); + () diff --git a/testsuite/tests/typing-local/float_iarray.stack.reference b/testsuite/tests/typing-local/float_iarray.stack.reference new file mode 100644 index 00000000000..902aa0b97ff --- /dev/null +++ b/testsuite/tests/typing-local/float_iarray.stack.reference @@ -0,0 +1,4 @@ + access from literal: No Allocation +access from Iarray.init: No Allocation + match on literal: Allocation + match on Iarray.init: Allocation diff --git a/testsuite/tests/typing-local/iarray.heap.reference b/testsuite/tests/typing-local/iarray.heap.reference new file mode 100644 index 00000000000..4987b8e6a3e --- /dev/null +++ b/testsuite/tests/typing-local/iarray.heap.reference @@ -0,0 +1,14 @@ + init_local: Allocation + append_local: Allocation + concat_local: Allocation + sub_local: Allocation + to_list_local: Allocation + of_list_local: Allocation + map_local: Allocation + mapi_local: Allocation + fold_left_local: Allocation + fold_left_map_local: Allocation + fold_right_local: Allocation + map2_local: Allocation + split_local: Allocation + combine_local: Allocation diff --git a/testsuite/tests/typing-local/iarray.ml b/testsuite/tests/typing-local/iarray.ml new file mode 100644 index 00000000000..8e5d0b4615f --- /dev/null +++ b/testsuite/tests/typing-local/iarray.ml @@ -0,0 +1,144 @@ +(* TEST + flags = "-extension immutable_arrays" + * bytecode + reference = "${test_source_directory}/iarray.heap.reference" + * stack-allocation + ** native + reference = "${test_source_directory}/iarray.stack.reference" + * no-stack-allocation + ** native + reference = "${test_source_directory}/iarray.heap.reference" + *) + +(* Testing all the [iarray] functions that allocate [iarray]s locally (not + including multiple variants of the same function) for: + + 1. Safety: No forward pointers on the local stack. + + 2. Correctness: They actually create arrays on the stack (by testing that no + GCed allocation happens). *) + +module Iarray = Stdlib__Iarray + +external opaque_local : local_ 'a -> local_ 'a = "%opaque" + +let ignore_local : local_ 'a -> unit = fun x -> + let _ = local_ opaque_local x in + () + +let local_some : 'a -> local_ 'a option = fun x -> local_ Some x + +let run name f x = local_ + let prebefore = Gc.allocated_bytes () in + let before = Gc.allocated_bytes () in + let r = Sys.opaque_identity f x in + let after = Gc.allocated_bytes () in + let delta = + int_of_float ((after -. before) -. (before -. prebefore)) + / (Sys.word_size/8) + in + let msg = + match delta with + | 0 -> "No Allocation" + | n -> "Allocation" + in + Printf.printf "%20s: %s\n" name msg; + r + +(* Testing functions *) + +let test_init n = local_ Iarray.init_local n local_some + +let test_append (a1, a2) = local_ Iarray.append_local a1 a2 + +let test_concat = Iarray.concat_local + +let test_sub a = local_ Iarray.sub_local a 0 3 + +let test_to_list = Iarray.to_list_local + +let test_of_list = Iarray.of_list_local + +let test_map a = local_ + Iarray.map_local + (function Some x -> local_ Some (-x) | None -> local_ Some 0) + a + +let test_mapi a = local_ Iarray.mapi_local (fun i x -> local_ i, x) a + +let test_fold_left a = local_ + Iarray.fold_left_local (fun l x -> local_ x :: l) [] a + +let test_fold_left_map a = local_ + Iarray.fold_left_map_local (fun l x -> local_ x :: l, Some x) [] a + +let test_fold_right a = local_ + Iarray.fold_right_local (fun x l -> local_ x :: l) a [] + +let test_map2 (a1, a2) = local_ Iarray.map2_local (fun x y -> local_ x, y) a1 a2 + +let test_split = Iarray.split_local + +let test_combine (a1, a2) = local_ Iarray.combine_local a1 a2 + +(* Run the test, keeping the values alive *) +let () = + let local_ r0 = run "init_local" + test_init + 42 + in + let local_ r1 = run "append_local" + test_append + (Iarray.init_local 42 local_some, [:None; Some (-1); Some (-2):]) + in + let local_ r2 = run "concat_local" + test_concat + [Iarray.init_local 42 local_some; [:None; Some (-1); Some (-2):]] + in + let local_ r3 = run "sub_local" + test_sub + (Iarray.init_local 42 local_some) + in + let local_ r4 = run "to_list_local" + test_to_list (Iarray.init_local 42 local_some) + in + let local_ r5 = run "of_list_local" + test_of_list [Some 0; Some 1; Some 2; Some 3; Some 4; Some 5] + in + let local_ r6 = run "map_local" + test_map + (Iarray.init_local 42 local_some) + in + let local_ r7 = run "mapi_local" + test_mapi + (Iarray.init_local 42 local_some) + in + let local_ r8 = run "fold_left_local" + test_fold_left + (Iarray.init_local 42 local_some) + in + let local_ r9 = run "fold_left_map_local" + test_fold_left_map + (Iarray.init_local 42 local_some) + in + let local_ rA = run "fold_right_local" + test_fold_right + (Iarray.init_local 42 local_some) + in + let local_ rB = run "map2_local" + test_map2 + (Iarray.init_local 3 local_some, [:None; Some (-1); Some (-2):]) + in + let local_ rC = run "split_local" + test_split + (Iarray.init_local 42 (fun i -> local_ Some i, Some (-i))) + in + let local_ rD = run "combine_local" + test_combine + (Iarray.init_local 3 local_some, [:None; Some (-1); Some (-2):]) + in + (* In debug mode, Gc.minor () checks for backwards local pointers and minor + heap->local pointers (though we're more concerned about the former) *) + Gc.minor (); + ignore_local (r0, r1, r2, r3, r4, r5, r6, r7, r8, r9, rA, rB, rC, rD); + () diff --git a/testsuite/tests/typing-local/iarray.stack.reference b/testsuite/tests/typing-local/iarray.stack.reference new file mode 100644 index 00000000000..be3c2c3f360 --- /dev/null +++ b/testsuite/tests/typing-local/iarray.stack.reference @@ -0,0 +1,14 @@ + init_local: No Allocation + append_local: No Allocation + concat_local: No Allocation + sub_local: No Allocation + to_list_local: No Allocation + of_list_local: No Allocation + map_local: No Allocation + mapi_local: No Allocation + fold_left_local: No Allocation + fold_left_map_local: No Allocation + fold_right_local: No Allocation + map2_local: No Allocation + split_local: No Allocation + combine_local: No Allocation diff --git a/typing/typecore.ml b/typing/typecore.ml index 049597cbea0..a7751ef843b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4849,7 +4849,6 @@ and type_expect_ ~expected_mode ~ty_expected ~explanation - ~type_:Predef.type_array ~mutability:Mutable ~attributes:sexp.pexp_attributes sargl @@ -7284,19 +7283,21 @@ and type_generic_array ~expected_mode ~ty_expected ~explanation - ~type_ ~mutability ~attributes sargl = + let type_, base_argument_mode = match mutability with + | Mutable -> Predef.type_array, mode_default Value_mode.global + | Immutable -> Predef.type_iarray, mode_subcomponent expected_mode + in let alloc_mode = register_allocation expected_mode in (* CR layouts v4: non-values in arrays *) let ty = newgenvar (Layout.value ~why:Array_element) in let to_unify = type_ ty in with_explanation explanation (fun () -> unify_exp_types loc env to_unify (generic_instance ty_expected)); - let argument_mode = mode_default Value_mode.global in - let argument_mode = expect_mode_cross env ty argument_mode in + let argument_mode = expect_mode_cross env ty base_argument_mode in let argl = List.map (fun sarg -> type_expect env argument_mode sarg (mk_expected ty)) @@ -7575,7 +7576,6 @@ and type_immutable_array ~expected_mode ~ty_expected ~explanation - ~type_:Predef.type_iarray ~mutability:Immutable ~attributes elts