From 5acd3c111f44ded576b2c006b6d4580c806704d4 Mon Sep 17 00:00:00 2001 From: Leo White Date: Thu, 19 May 2022 21:00:28 +0100 Subject: [PATCH] Squashed 'ocaml/' changes from fe8a98b0c..ce8883357 ce8883357 Merge flambda-backend changes b7506bbc6 Revert "Cherry-pick of ocaml/ocaml 1eeb0e7fe595f5f9e1ea1edbdf785ff3b49feeeb (#12)" 183f68817 Add config option to enable/disable stack allocation (#22) ee7c849eb If both the type and mode of an ident are wrong, complain about the type. (#19) 44bade06c Allow submoding during module inclusion checks (#21) de3bec9ae Add subtyping between arrows of related modes (#20) 93d861556 Enable the local keywords even when the local extension is off (#18) 81dd85ee1 Documentation for local allocations b05519f16 Fix a GC bug in local stack scanning (#17) 9f879dea8 Fix __FUNCTION__ (#15) a78975eb5 Optimise "include struct ... end" in more cases (ocaml/ocaml#11134) b819c6615 Cherry-pick of ocaml/ocaml 1eeb0e7fe595f5f9e1ea1edbdf785ff3b49feeeb (#12) bb363d4e7 Optimise the allocation of optional arguments (#11) git-subtree-dir: ocaml git-subtree-split: ce8883357fa56b4dbbe058ace120fcf93a655be6 --- Makefile.config.in | 1 + asmcomp/afl_instrument.ml | 4 +- asmcomp/cmm_helpers.ml | 88 +-- asmcomp/cmmgen.ml | 32 +- asmcomp/comballoc.ml | 2 +- asmcomp/printcmm.ml | 4 +- asmcomp/selectgen.ml | 4 +- bytecomp/bytegen.ml | 2 +- configure | 74 ++ configure.ac | 10 + driver/main_args.ml | 24 +- driver/main_args.mli | 5 +- jane/doc/local-intro.md | 155 +++++ jane/doc/local-pitfalls.md | 78 +++ jane/doc/local-reference.md | 641 ++++++++++++++++++ lambda/lambda.ml | 99 ++- lambda/lambda.mli | 20 +- lambda/matching.ml | 10 +- lambda/printlambda.ml | 38 +- lambda/simplif.ml | 8 +- lambda/translclass.ml | 44 +- lambda/translcomprehension.ml | 10 +- lambda/translcore.ml | 130 ++-- lambda/translcore.mli | 3 +- lambda/translmod.ml | 75 +- lambda/translobj.ml | 2 +- lambda/translprim.ml | 35 +- middle_end/closure/closure.ml | 22 +- middle_end/convert_primitives.ml | 6 +- .../flambda/augment_specialised_args.ml | 2 +- middle_end/flambda/closure_conversion.ml | 10 +- middle_end/flambda/flambda_to_clambda.ml | 5 +- middle_end/flambda/inline_and_simplify.ml | 5 +- middle_end/flambda/inlining_cost.ml | 2 +- .../flambda/lift_let_to_initialize_symbol.ml | 3 +- middle_end/flambda/remove_unused_arguments.ml | 2 +- middle_end/printclambda_primitives.ml | 26 +- ocamltest/Makefile | 1 + ocamltest/ocaml_actions.ml | 14 + ocamltest/ocamltest_config.ml.in | 2 + ocamltest/ocamltest_config.mli | 3 + parsing/lexer.mll | 3 - runtime/caml/m.h.in | 2 + runtime/memory.c | 2 +- runtime/roots_nat.c | 2 +- .../array_spec.compilers.flat.reference | 4 +- testsuite/tests/translprim/array_spec.ml | 2 +- .../comparison_table.compilers.reference | 4 +- .../tests/translprim/comparison_table.ml | 2 +- testsuite/tests/translprim/locs.reference | 62 +- .../translprim/ref_spec.compilers.reference | 21 +- testsuite/tests/translprim/ref_spec.ml | 2 +- .../tests/typing-local/alloc.heap.reference | 34 + testsuite/tests/typing-local/alloc.ml | 26 +- testsuite/tests/typing-local/alloc.reference | 33 - .../tests/typing-local/alloc.stack.reference | 34 + testsuite/tests/typing-local/aritybug.ml | 3 +- testsuite/tests/typing-local/comballoc.ml | 3 +- ...ry.byte.reference => curry.heap.reference} | 0 testsuite/tests/typing-local/curry.ml | 13 +- ...ry.opt.reference => curry.stack.reference} | 0 testsuite/tests/typing-local/exceptions.ml | 1 - testsuite/tests/typing-local/lifetime.ml | 3 +- testsuite/tests/typing-local/local.ml | 275 +++++++- testsuite/tests/typing-local/localgcbug.ml | 19 + .../tests/typing-local/localgcbug.reference | 1 + testsuite/tests/typing-local/mutate.ml | 3 +- testsuite/tests/typing-local/nosyntax.ml | 19 +- testsuite/tests/typing-local/partial.ml | 2 +- testsuite/tests/typing-local/regions.ml | 1 - testsuite/tests/typing-local/tailcalls.ml | 5 +- .../struct_include_optimisation.ml | 49 ++ .../struct_include_optimisation.reference | 5 + testsuite/tests/typing-objects/Tests.ml | 2 +- testsuite/tools/parsecmm.mly | 10 +- typing/btype.ml | 11 +- typing/btype.mli | 4 +- typing/ctype.ml | 191 ++++-- typing/oprint.ml | 2 +- typing/typecore.ml | 46 +- utils/Makefile | 1 + utils/clflags.ml | 6 +- utils/config.mli | 2 + utils/config.mlp | 2 + 84 files changed, 2090 insertions(+), 523 deletions(-) create mode 100644 jane/doc/local-intro.md create mode 100644 jane/doc/local-pitfalls.md create mode 100644 jane/doc/local-reference.md create mode 100644 testsuite/tests/typing-local/alloc.heap.reference delete mode 100644 testsuite/tests/typing-local/alloc.reference create mode 100644 testsuite/tests/typing-local/alloc.stack.reference rename testsuite/tests/typing-local/{curry.byte.reference => curry.heap.reference} (100%) rename testsuite/tests/typing-local/{curry.opt.reference => curry.stack.reference} (100%) create mode 100644 testsuite/tests/typing-local/localgcbug.ml create mode 100644 testsuite/tests/typing-local/localgcbug.reference create mode 100644 testsuite/tests/typing-modules/struct_include_optimisation.ml create mode 100644 testsuite/tests/typing-modules/struct_include_optimisation.reference diff --git a/Makefile.config.in b/Makefile.config.in index 3972a6f4beb..5a10e7840a5 100644 --- a/Makefile.config.in +++ b/Makefile.config.in @@ -246,6 +246,7 @@ AWK=@AWK@ STDLIB_MANPAGES=@stdlib_manpages@ NAKED_POINTERS=@naked_pointers@ INTEL_JCC_BUG_CFLAGS=@intel_jcc_bug_cflags@ +STACK_ALLOCATION=@stack_allocation@ ### Native command to build ocamlrun.exe diff --git a/asmcomp/afl_instrument.ml b/asmcomp/afl_instrument.ml index 32c031647fb..13703966b0a 100644 --- a/asmcomp/afl_instrument.ml +++ b/asmcomp/afl_instrument.ml @@ -46,12 +46,12 @@ let rec with_afl_logging b dbg = Clet(VP.create cur_pos, op Cxor [op (Cload (Word_int, Asttypes.Mutable)) [afl_prev_loc dbg]; Cconst_int (cur_location, dbg)], Csequence( - op (Cstore(Byte_unsigned, Assignment)) + op (Cstore(Byte_unsigned, Assignment alloc_heap)) [op Cadda [Cvar afl_area; Cvar cur_pos]; op Cadda [op (Cload (Byte_unsigned, Asttypes.Mutable)) [op Cadda [Cvar afl_area; Cvar cur_pos]]; Cconst_int (1, dbg)]], - op (Cstore(Word_int, Assignment)) + op (Cstore(Word_int, Assignment alloc_heap)) [afl_prev_loc dbg; Cconst_int (cur_location lsr 1, dbg)]))) in Csequence(instrumentation, instrument b) diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml index bc035a977e7..efbc3fd0b2a 100644 --- a/asmcomp/cmm_helpers.ml +++ b/asmcomp/cmm_helpers.ml @@ -606,7 +606,8 @@ let unbox_float dbg = (* Complex *) let box_complex dbg c_re c_im = - Cop(Calloc Alloc_heap, [alloc_floatarray_header 2 dbg; c_re; c_im], dbg) + Cop(Calloc Lambda.alloc_heap, + [alloc_floatarray_header 2 dbg; c_re; c_im], dbg) let complex_re c dbg = Cop(Cload (Double, Immutable), [c], dbg) let complex_im c dbg = Cop(Cload (Double, Immutable), @@ -760,16 +761,16 @@ 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 Alloc_heap (unboxed_float_array_ref arr ofs dbg) + box_float dbg Lambda.alloc_heap (unboxed_float_array_ref arr ofs dbg) let addr_array_set arr ofs newval dbg = Cop(Cextcall("caml_modify", typ_void, [], false), [array_indexing log2_size_addr arr ofs dbg; newval], dbg) let int_array_set arr ofs newval dbg = - Cop(Cstore (Word_int, Lambda.Assignment), + Cop(Cstore (Word_int, Lambda.Assignment Lambda.alloc_heap), [array_indexing log2_size_addr arr ofs dbg; newval], dbg) let float_array_set arr ofs newval dbg = - Cop(Cstore (Double, Lambda.Assignment), + Cop(Cstore (Double, Lambda.Assignment Lambda.alloc_heap), [array_indexing log2_size_float arr ofs dbg; newval], dbg) let addr_array_set_local arr ofs newval dbg = @@ -828,7 +829,7 @@ let call_cached_method obj tag cache pos args (apos,mode) dbg = (* Allocation *) let make_alloc_generic ~mode set_fn dbg tag wordsize args = - if mode = Lambda.Alloc_local || wordsize <= Config.max_young_wosize then + if Lambda.is_local_mode mode || wordsize <= Config.max_young_wosize then let hdr = match mode with | Lambda.Alloc_local -> local_block_header tag wordsize @@ -1003,13 +1004,14 @@ let bigarray_set unsafe elt_kind layout b args newval dbg = bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> Csequence( - Cop(Cstore (kind, Assignment), [addr; complex_re newv dbg], dbg), - Cop(Cstore (kind, Assignment), + Cop(Cstore (kind, Assignment Lambda.alloc_heap), + [addr; complex_re newv dbg], dbg), + Cop(Cstore (kind, Assignment Lambda.alloc_heap), [Cop(Cadda, [addr; Cconst_int (sz, dbg)], dbg); complex_im newv dbg], dbg)))) | _ -> - Cop(Cstore (bigarray_word_kind elt_kind, Assignment), + Cop(Cstore (bigarray_word_kind elt_kind, Assignment Lambda.alloc_heap), [bigarray_indexing unsafe elt_kind layout b args dbg; newval], dbg)) @@ -1162,7 +1164,7 @@ let unaligned_load_16 ptr idx dbg = let unaligned_set_16 ptr idx newval dbg = if Arch.allow_unaligned_access then - Cop(Cstore (Sixteen_unsigned, Assignment), + Cop(Cstore (Sixteen_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; newval], dbg) else let cconst_int i = Cconst_int (i, dbg) in @@ -1173,8 +1175,8 @@ let unaligned_set_16 ptr idx newval dbg = let v2 = Cop(Cand, [newval; cconst_int 0xFF], dbg) in let b1, b2 = if Arch.big_endian then v1, v2 else v2, v1 in Csequence( - Cop(Cstore (Byte_unsigned, Assignment), [add_int ptr idx dbg; b1], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; b1], dbg), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)) let unaligned_load_32 ptr idx dbg = @@ -1205,7 +1207,7 @@ let unaligned_load_32 ptr idx dbg = let unaligned_set_32 ptr idx newval dbg = if Arch.allow_unaligned_access then - Cop(Cstore (Thirtytwo_unsigned, Assignment), [add_int ptr idx dbg; newval], + Cop(Cstore (Thirtytwo_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; newval], dbg) else let cconst_int i = Cconst_int (i, dbg) in @@ -1225,16 +1227,16 @@ let unaligned_set_32 ptr idx newval dbg = else v4, v3, v2, v1 in Csequence( Csequence( - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; b1], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)), Csequence( - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], dbg))) @@ -1280,7 +1282,7 @@ let unaligned_load_64 ptr idx dbg = let unaligned_set_64 ptr idx newval dbg = assert(size_int = 8); if Arch.allow_unaligned_access - then Cop(Cstore (Word_int, Assignment), [add_int ptr idx dbg; newval], dbg) + then Cop(Cstore (Word_int, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; newval], dbg) else let cconst_int i = Cconst_int (i, dbg) in let v1 = @@ -1319,32 +1321,32 @@ let unaligned_set_64 ptr idx newval dbg = Csequence( Csequence( Csequence( - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int ptr idx dbg; b1], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 1) dbg; b2], dbg)), Csequence( - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 2) dbg; b3], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 3) dbg; b4], dbg))), Csequence( Csequence( - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 4) dbg; b5], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 5) dbg; b6], dbg)), Csequence( - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 6) dbg; b7], dbg), - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int (add_int ptr idx dbg) (cconst_int 7) dbg; b8], dbg)))) @@ -1824,7 +1826,7 @@ let cache_public_method meths tag cache dbg = VP.create tagged, Cop(Caddi, [lsl_const (Cvar li) log2_size_addr dbg; cconst_int(1 - 3 * size_addr)], dbg), - Csequence(Cop (Cstore (Word_int, Assignment), [cache; Cvar tagged], dbg), + Csequence(Cop (Cstore (Word_int, Assignment Lambda.alloc_heap), [cache; Cvar tagged], dbg), Cvar tagged))))) let has_local_allocs e = @@ -1896,9 +1898,12 @@ let apply_function_body (arity, (mode : Lambda.alloc_mode)) = (* In the slowpath, a region is necessary in case the initial applications do local allocations *) let region = - match mode with - | Alloc_heap -> Some (V.create_local "region") - | Alloc_local -> None + if not Config.stack_allocation then None + else begin + match mode with + | Alloc_heap -> Some (V.create_local "region") + | Alloc_local -> None + end in let rec app_fun clos n = if n = arity-1 then begin @@ -2130,8 +2135,9 @@ let rec intermediate_curry_functions ~nlocal ~arity num = let name2 = if num = 0 then name1 else name1 ^ "_" ^ Int.to_string num in let arg = V.create_local "arg" and clos = V.create_local "clos" in let fun_dbg = placeholder_fun_dbg ~human_name:name2 in - let mode : Lambda.alloc_mode = - if num >= arity - nlocal then Alloc_local else Alloc_heap in + let mode = + if num >= arity - nlocal then Lambda.alloc_local else Lambda.alloc_heap + in let curried n : Clambda.arity = (Curried {nlocal=min nlocal n}, n) in Cfunction {fun_name = name2; @@ -2214,7 +2220,7 @@ module ApplyFnSet = module AritySet = Set.Make (struct type t = Clambda.arity let compare = compare end) -let default_apply = ApplyFnSet.of_list [2,Alloc_heap; 3,Alloc_heap] +let default_apply = ApplyFnSet.of_list [2,Lambda.alloc_heap; 3,Lambda.alloc_heap] (* These apply funs are always present in the main program because the run-time system needs them (cf. runtime/.S) . *) @@ -2260,7 +2266,7 @@ let negint arg dbg = let offsetref n arg dbg = return_unit dbg (bind "ref" arg (fun arg -> - Cop(Cstore (Word_int, Assignment), + Cop(Cstore (Word_int, Assignment Lambda.alloc_heap), [arg; add_const (Cop(Cload (Word_int, Mutable), [arg], dbg)) (n lsl 1) dbg], @@ -2318,11 +2324,13 @@ let assignment_kind (ptr: Lambda.immediate_or_pointer) (init: Lambda.initialization_or_assignment) = match init, ptr with - | Assignment, Pointer -> Caml_modify - | Local_assignment, Pointer -> Caml_modify_local + | Assignment Alloc_heap, Pointer -> Caml_modify + | Assignment Alloc_local, Pointer -> + assert Config.stack_allocation; + Caml_modify_local | Heap_initialization, _ -> Misc.fatal_error "Cmm_helpers: Lambda.Heap_initialization unsupported" - | (Assignment | Local_assignment), Immediate + | (Assignment _), Immediate | Root_initialization, (Immediate | Pointer) -> Simple let setfield n ptr init arg1 arg2 dbg = @@ -2505,7 +2513,7 @@ let arrayref_safe kind arg1 arg2 dbg = (get_header_without_profinfo arr dbg) dbg; idx], int_array_ref arr idx dbg))) | Pfloatarray -> - box_float dbg Alloc_heap ( + box_float dbg Lambda.alloc_heap ( bind "index" arg2 (fun idx -> bind "arr" arg1 (fun arr -> Csequence( @@ -2528,7 +2536,7 @@ let setfield_computed ptr init arg1 arg2 arg3 dbg = return_unit dbg (int_array_set arg1 arg2 arg3 dbg) let bytesset_unsafe arg1 arg2 arg3 dbg = - return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment), + return_unit dbg (Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int arg1 (untag_int arg2 dbg) dbg; ignore_high_bit_int (untag_int arg3 dbg)], dbg)) @@ -2539,7 +2547,7 @@ let bytesset_safe arg1 arg2 arg3 dbg = bind "str" arg1 (fun str -> Csequence( make_checkbound dbg [string_length str dbg; idx], - Cop(Cstore (Byte_unsigned, Assignment), + Cop(Cstore (Byte_unsigned, Assignment Lambda.alloc_heap), [add_int str idx dbg; ignore_high_bit_int newval], dbg)))))) @@ -2716,7 +2724,7 @@ let entry_point namelist = let cconst_int i = Cconst_int (i, dbg ()) in let cconst_symbol sym = Cconst_symbol (sym, dbg ()) in let incr_global_inited () = - Cop(Cstore (Word_int, Assignment), + Cop(Cstore (Word_int, Assignment Lambda.alloc_heap), [cconst_symbol "caml_globals_inited"; Cop(Caddi, [Cop(Cload (Word_int, Mutable), [cconst_symbol "caml_globals_inited"], dbg ()); diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index a129cf2e12d..f4b43340c51 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -341,13 +341,13 @@ let is_unboxed_number_cmm ~strict cmm = | Cconst_symbol (s, _) -> begin match Cmmgen_state.structured_constant_of_sym s with | Some (Uconst_float _) -> - notify (Boxed (Boxed_float (Alloc_heap, Debuginfo.none), true)) + notify (Boxed (Boxed_float (alloc_heap, Debuginfo.none), true)) | Some (Uconst_nativeint _) -> - notify (Boxed (Boxed_integer (Pnativeint, Alloc_heap, Debuginfo.none), true)) + notify (Boxed (Boxed_integer (Pnativeint, alloc_heap, Debuginfo.none), true)) | Some (Uconst_int32 _) -> - notify (Boxed (Boxed_integer (Pint32, Alloc_heap, Debuginfo.none), true)) + notify (Boxed (Boxed_integer (Pint32, alloc_heap, Debuginfo.none), true)) | Some (Uconst_int64 _) -> - notify (Boxed (Boxed_integer (Pint64, Alloc_heap, Debuginfo.none), true)) + notify (Boxed (Boxed_integer (Pint64, alloc_heap, Debuginfo.none), true)) | _ -> notify No_unboxing end @@ -494,7 +494,7 @@ let rec transl env e = state of [Translcore], we will in fact only get here with [Pfloatarray]s. *) assert (kind = kind'); - transl_make_array dbg env kind Alloc_heap args + transl_make_array dbg env kind alloc_heap args | (Pduparray _, [arg]) -> let prim_obj_dup = Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true @@ -510,11 +510,11 @@ let rec transl env e = (transl env arg1) (List.map (transl env) argl) dbg in begin match elt_kind with (* TODO: local allocation of bigarray elements *) - Pbigarray_float32 | Pbigarray_float64 -> box_float dbg Alloc_heap elt + Pbigarray_float32 | Pbigarray_float64 -> box_float dbg alloc_heap elt | Pbigarray_complex32 | Pbigarray_complex64 -> elt - | Pbigarray_int32 -> box_int dbg Pint32 Alloc_heap elt - | Pbigarray_int64 -> box_int dbg Pint64 Alloc_heap elt - | Pbigarray_native_int -> box_int dbg Pnativeint Alloc_heap elt + | Pbigarray_int32 -> box_int dbg Pint32 alloc_heap elt + | Pbigarray_int64 -> box_int dbg Pint64 alloc_heap elt + | Pbigarray_native_int -> box_int dbg Pnativeint alloc_heap elt | Pbigarray_caml_int -> tag_int elt dbg | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 -> tag_int elt dbg @@ -760,7 +760,9 @@ and transl_make_array dbg env kind mode args = let prim = match (mode : Lambda.alloc_mode) with | Alloc_heap -> "caml_make_array" - | Alloc_local -> "caml_make_array_local" + | Alloc_local -> + assert Config.stack_allocation; + "caml_make_array_local" in Cop(Cextcall(prim, typ_val, [], true), [make_alloc ~mode dbg 0 (List.map (transl env) args)], dbg) @@ -804,10 +806,10 @@ and transl_ccall env prim args dbg = match prim.prim_native_repr_res with | _, Same_as_ocaml_repr -> (typ_val, fun x -> x) (* TODO: Allow Alloc_local on suitably typed C stubs *) - | _, Unboxed_float -> (typ_float, box_float dbg Alloc_heap) + | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap) | _, Unboxed_integer Pint64 when size_int = 4 -> - ([|Int; Int|], box_int dbg Pint64 Alloc_heap) - | _, Unboxed_integer bi -> (typ_int, box_int dbg bi Alloc_heap) + ([|Int; Int|], box_int dbg Pint64 alloc_heap) + | _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap) | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg)) in let typ_args, args = transl_args prim.prim_native_repr_args args in @@ -1169,9 +1171,9 @@ and transl_let env str kind id exp transl_body = of allocation mode it may be possible to mark some Alloc_local *) match str, kind with | Mutable, Pfloatval -> - Boxed (Boxed_float (Alloc_heap, dbg), false) + Boxed (Boxed_float (alloc_heap, dbg), false) | Mutable, Pboxedintval bi -> - Boxed (Boxed_integer (bi, Alloc_heap, dbg), false) + Boxed (Boxed_integer (bi, alloc_heap, dbg), false) | _, (Pfloatval | Pboxedintval _) -> (* It would be safe to always unbox in this case, but we do it only if this indeed allows us to get rid of diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 1d1a6585295..bba9ff73c1d 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -37,7 +37,7 @@ let rec combine i allocstate = | Pending_alloc {reg; dbginfos; totalsz; mode = prev_mode} when (mode = prev_mode) && ((totalsz + sz <= (Config.max_young_wosize + 1) * Arch.size_addr) - || mode = Lambda.Alloc_local) -> + || Lambda.is_local_mode mode) -> let (next, state) = combine i.next (Pending_alloc { reg = i.res.(0); diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index f70952b02b0..5608ca5f1d7 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -126,8 +126,8 @@ let operation d = function match init with | Lambda.Heap_initialization -> "(heap-init)" | Lambda.Root_initialization -> "(root-init)" - | Lambda.Assignment -> "" - | Local_assignment -> "(local)" + | Lambda.Assignment Alloc_heap -> "" + | Lambda.Assignment Alloc_local -> "(local)" in Printf.sprintf "store %s%s" (chunk c) init | Caddi -> "+" diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index bcb7244b229..96da34fde1d 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -487,7 +487,7 @@ method select_operation op args _dbg = match init with | Lambda.Root_initialization -> false | Lambda.Heap_initialization -> false - | Lambda.Assignment | Lambda.Local_assignment -> true + | Lambda.Assignment _ -> true in if chunk = Word_int || chunk = Word_val then begin let (op, newarg2) = self#select_store is_assign addr arg2 in @@ -889,6 +889,7 @@ method emit_expr (env:environment) exp = [||] [||]; r | Cregion e -> + assert (Config.stack_allocation); let reg = self#regs_for typ_int in self#insert env (Iop Ibeginregion) [| |] reg; let env = { env with regions = reg::env.regions; region_tail = true } in @@ -1239,6 +1240,7 @@ method emit_tail (env:environment) exp = [||] [||]; self#insert_return env opt_r1 | Cregion e -> + assert (Config.stack_allocation); if env.region_tail then self#emit_return env exp else begin diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index d6e64d921e9..b595d3d423c 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -686,7 +686,7 @@ let rec comp_expr env exp sz cont = ap_func=func; ap_args=[arg]; ap_region_close=pos; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; diff --git a/configure b/configure index 628adf7fdc0..7258216883e 100755 --- a/configure +++ b/configure @@ -1,4 +1,60 @@ #! /bin/sh + +if test -e '.git' ; then : + if test -z "$ac_read_git_config" ; then : + extra_args=$(git config ocaml.configure 2>/dev/null) + extended_cache=$(git config ocaml.configure-cache 2>/dev/null) + cache_file= + + # If ocaml.configure-cache is set, parse the command-line for the --host + # option, in order to determine the name of the cache file. + if test -n "$extended_cache" ; then : + echo "Detected Git configuration option ocaml.configure-cache set to \ +\"$extended_cache\"" + dashdash= + prev= + host=default + # The logic here is pretty borrowed from autoconf's + for option in $extra_args "$@" + do + if test -n "$prev" ; then : + host=$option + continue + fi + + case $dashdash$option in + --) + dashdash=yes ;; + -host | --host | --hos | --ho) + prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + case $option in + *=?*) host=$(expr "X$option" : '[^=]*=\(.*\)') ;; + *=) host= ;; + esac ;; + esac + done + cache_file="`dirname "$0"`/$extended_cache/ocaml-$host.cache" + fi + + # If either option has a value, re-invoke configure + if test -n "$extra_args$cache_file" ; then : + echo "Detected Git configuration option ocaml.configure set to \ +\"$extra_args\"" + # Too much effort to get the echo to show appropriate quoting - the + # invocation itself intentionally quotes $0 and passes $@ exactly as given + # but allows a single expansion of ocaml.configure + if test -n "$cache_file" ; then : + echo "Re-running $0 $extra_args --cache-file \"$cache_file\" $@" + ac_read_git_config=true exec "$0" $extra_args \ + --cache-file "$cache_file" "$@" + else + echo "Re-running $0 $extra_args $@" + ac_read_git_config=true exec "$0" $extra_args "$@" + fi + fi + fi +fi # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for OCaml 4.12.0. # @@ -691,6 +747,7 @@ build_os build_vendor build_cpu build +stack_allocation intel_jcc_bug_cflags naked_pointers_checker naked_pointers @@ -860,6 +917,7 @@ enable_force_safe_string enable_flat_float_array enable_function_sections with_afl +enable_stack_allocation enable_shared enable_static with_pic @@ -1542,6 +1600,8 @@ Optional Features: do not use flat float arrays --disable-function-sections do not emit each function in a separate section + --enable-stack-allocation + enable stack allocation of local values --enable-shared[=PKGS] build shared libraries [default=yes] --enable-static[=PKGS] build static libraries [default=yes] --enable-fast-install[=PKGS] @@ -3294,6 +3354,12 @@ if test "${with_afl+set}" = set; then : fi +# Check whether --enable-stack-allocation was given. +if test "${enable_stack_allocation+set}" = set; then : + enableval=$enable_stack_allocation; +fi + + if test x"$enable_unix_lib" = "xno"; then : if test x"$enable_debugger" = "xyes"; then : as_fn_error $? "replay debugger requires the unix library" "$LINENO" 5 @@ -17103,6 +17169,14 @@ else default_safe_string=true fi +if test x"$enable_stack_allocation" = "xyes"; then : + $as_echo "#define STACK_ALLOCATION 1" >>confdefs.h + + stack_allocation=true +else + stack_allocation=false +fi + oc_cflags="$common_cflags $internal_cflags" oc_cppflags="$common_cppflags $internal_cppflags" ocamlc_cflags="$common_cflags $sharedlib_cflags \$(CFLAGS)" diff --git a/configure.ac b/configure.ac index 0cebbc8a26f..21ba6291f2b 100644 --- a/configure.ac +++ b/configure.ac @@ -172,6 +172,7 @@ AC_SUBST([compute_deps]) AC_SUBST([naked_pointers]) AC_SUBST([naked_pointers_checker]) AC_SUBST([intel_jcc_bug_cflags]) +AC_SUBST([stack_allocation]) ## Generated files @@ -399,6 +400,10 @@ AC_ARG_WITH([afl], [AS_HELP_STRING([--with-afl], [use the AFL fuzzer])]) +AC_ARG_ENABLE([stack-allocation], + [AS_HELP_STRING([--enable-stack-allocation], + [enable stack allocation of local values])]) + AS_IF([test x"$enable_unix_lib" = "xno"], [AS_IF([test x"$enable_debugger" = "xyes"], [AC_MSG_ERROR([replay debugger requires the unix library])], @@ -1878,6 +1883,11 @@ AS_IF([test x"$DEFAULT_STRING" = "xunsafe"], [default_safe_string=false], [default_safe_string=true]) +AS_IF([test x"$enable_stack_allocation" = "xyes"], + [AC_DEFINE([STACK_ALLOCATION]) + stack_allocation=true], + [stack_allocation=false]) + oc_cflags="$common_cflags $internal_cflags" oc_cppflags="$common_cppflags $internal_cppflags" ocamlc_cflags="$common_cflags $sharedlib_cflags \$(CFLAGS)" diff --git a/driver/main_args.ml b/driver/main_args.ml index 56ab5146a32..7979259de27 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -944,6 +944,8 @@ module type Common_options = sig val _no_alias_deps : unit -> unit val _app_funct : unit -> unit val _no_app_funct : unit -> unit + val _disable_all_extensions : unit -> unit + val _extension : string -> unit val _noassert : unit -> unit val _nolabels : unit -> unit val _nostdlib : unit -> unit @@ -987,7 +989,6 @@ module type Core_options = sig val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit - val _extension : string -> unit end @@ -1039,7 +1040,6 @@ module type Compiler_options = sig val _match_context_rows : int -> unit val _dtimings : unit -> unit val _dprofile : unit -> unit - val _disable_all_extensions : unit -> unit val _dump_into_file : unit -> unit val _args: string -> string array @@ -1203,9 +1203,11 @@ struct mk_config F._config; mk_config_var F._config_var; mk_custom F._custom; + mk_disable_all_extensions F._disable_all_extensions; mk_dllib F._dllib; mk_dllpath F._dllpath; mk_dtypes F._annot; + mk_extension F._extension; mk_for_pack_byt F._for_pack; mk_g_byt F._g; mk_stop_after ~native:false F._stop_after; @@ -1291,9 +1293,7 @@ struct mk_dcamlprimc F._dcamlprimc; mk_dtimings F._dtimings; mk_dprofile F._dprofile; - mk_disable_all_extensions F._disable_all_extensions; mk_dump_into_file F._dump_into_file; - mk_extension F._extension; mk_args F._args; mk_args0 F._args0; @@ -1312,6 +1312,8 @@ struct mk_no_alias_deps F._no_alias_deps; mk_app_funct F._app_funct; mk_no_app_funct F._no_app_funct; + mk_disable_all_extensions F._disable_all_extensions; + mk_extension F._extension; mk_noassert F._noassert; mk_noinit F._noinit; mk_nolabels F._nolabels; @@ -1357,7 +1359,6 @@ struct mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; - mk_extension F._extension; mk_args F._args; mk_args0 F._args0; @@ -1387,6 +1388,8 @@ struct mk_config F._config; mk_config_var F._config_var; mk_dtypes F._annot; + mk_disable_all_extensions F._disable_all_extensions; + mk_extension F._extension; mk_for_pack_opt F._for_pack; mk_g_opt F._g; mk_function_sections F._function_sections; @@ -1518,10 +1521,8 @@ struct mk_dstartup F._dstartup; mk_dtimings F._dtimings; mk_dprofile F._dprofile; - mk_disable_all_extensions F._disable_all_extensions; mk_dump_into_file F._dump_into_file; mk_dump_pass F._dump_pass; - mk_extension F._extension; mk_args F._args; mk_args0 F._args0; @@ -1554,6 +1555,8 @@ module Make_opttop_options (F : Opttop_options) = struct mk_linscan F._linscan; mk_app_funct F._app_funct; mk_no_app_funct F._no_app_funct; + mk_disable_all_extensions F._disable_all_extensions; + mk_extension F._extension; mk_no_float_const_prop F._no_float_const_prop; mk_noassert F._noassert; mk_noinit F._noinit; @@ -1627,7 +1630,6 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dinterval F._dinterval; mk_dstartup F._dstartup; mk_dump_pass F._dump_pass; - mk_extension F._extension; ] end;; @@ -1647,6 +1649,8 @@ struct mk_no_alias_deps F._no_alias_deps; mk_app_funct F._app_funct; mk_no_app_funct F._no_app_funct; + mk_disable_all_extensions F._disable_all_extensions; + mk_extension F._extension; mk_noassert F._noassert; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; @@ -1741,6 +1745,8 @@ module Default = struct let _no_strict_formats = clear strict_formats let _no_strict_sequence = clear strict_sequence let _no_unboxed_types = clear unboxed_types + let _disable_all_extensions = Extension.disable_all + let _extension s = Extension.enable s let _noassert = set noassert let _nolabels = set classic let _nostdlib = set no_std_include @@ -1779,7 +1785,6 @@ module Default = struct let _unsafe = set unsafe let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings - let _extension s = Extension.enable s end module Native = struct @@ -1894,7 +1899,6 @@ module Default = struct let _config_var = Misc.show_config_variable_and_exit let _dprofile () = profile_columns := Profile.all_columns let _dtimings () = profile_columns := [`Time] - let _disable_all_extensions = Extension.disable_all let _dump_into_file = set dump_into_file let _for_pack s = for_package := (Some s) let _g = set debug diff --git a/driver/main_args.mli b/driver/main_args.mli index b689a6a4847..be03e93c233 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -25,6 +25,8 @@ module type Common_options = sig val _no_alias_deps : unit -> unit val _app_funct : unit -> unit val _no_app_funct : unit -> unit + val _disable_all_extensions : unit -> unit + val _extension : string -> unit val _noassert : unit -> unit val _nolabels : unit -> unit val _nostdlib : unit -> unit @@ -47,6 +49,7 @@ module type Common_options = sig val _vnum : unit -> unit val _w : string -> unit + val anonymous : string -> unit end @@ -67,7 +70,6 @@ module type Core_options = sig val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit - val _extension : string -> unit end @@ -119,7 +121,6 @@ module type Compiler_options = sig val _match_context_rows : int -> unit val _dtimings : unit -> unit val _dprofile : unit -> unit - val _disable_all_extensions : unit -> unit val _dump_into_file : unit -> unit val _args: string -> string array diff --git a/jane/doc/local-intro.md b/jane/doc/local-intro.md new file mode 100644 index 00000000000..b2fb8d4fe2c --- /dev/null +++ b/jane/doc/local-intro.md @@ -0,0 +1,155 @@ +# Introduction to Local Allocations + + +Instead of allocating values normally on the GC heap, local +allocations allow you to stack-allocate values using the new `local_` +keyword: + + let local_ x = { foo; bar } in + ... + +or equivalently, by putting the keyword on the expression itself: + + let x = local_ { foo; bar } in + ... + +To enable this feature, you need to pass the `-extension local` flag +to the compiler. Without this flag, `local_` is not recognized as a +keyword, and no local allocations will be performed. + +These values live on a separate stack, and are popped off at the end +of the _region_. Generally, the region ends when the surrounding +function returns, although read [the reference](local-reference.md) for more +details. + +This helps performance in a couple of ways: first, the same few hot +cachelines are constantly reused, so the cache footprint is lower than +usual. More importantly, local allocations will never trigger a GC, +and so they're safe to use in low-latency code that must currently be +zero-alloc. + +However, for this to be safe, local allocations must genuinely be +local. Since the memory they occupy is reused quickly, we must ensure +that no dangling references to them escape. This is checked by the +typechecker, and you'll see new error messages if local values leak: + + # let local_ thing = { foo; bar } in + some_global := thing;; + ^^^^^ + Error: This value escapes its region + + +Most of the types of allocation that OCaml does can be locally +allocated: tuples, records, variants, closures, boxed numbers, +etc. Local allocations are also possible from C stubs, although this +requires code changes to use the new `caml_alloc_local` instead of +`caml_alloc`. A few types of allocation cannot be locally allocated, +though, including first-class modules, classes and objects, and +exceptions. The contents of mutable fields (inside `ref`s, `array`s +and mutable record fields) also cannot be locally allocated. + + +## Local parameters + +Generally, OCaml functions can do whatever they like with their +arguments: use them, return them, capture them in closures or store +them in globals, etc. This is a problem when trying to pass around +locally-allocated values, since we need to guarantee they do not +escape. + +The remedy is that we allow the `local_` keyword to also appear on function parameters: + + let f (local_ x) = ... + +A local parameter is a promise by a function not to let a particular +argument escape its region. In the body of f, you'll get a type error +if x escapes, but when calling f you can freely pass local values as +the argument. This promise is visible in the type of f: + + val f : local_ 'a -> ... + +The function f may be equally be called with locally-allocated or +GC-heap values: the `local_` annotation places obligations only on the +definition of f, not its uses. + +Even if you're not interested in performance benefits, local +parameters are a useful new tool for structuring APIs. For instance, +consider a function that accepts a callback, to which it passes some +mutable value: + + let uses_callback ~f = + let tbl = Foo.Table.create () in + fill_table tbl; + let result = f tbl in + add_table_to_global_registry tbl; + result + +Part of the contract of `uses_callback` is that it expects `f` not to +capture its argument: unexpected results could ensue if `f` stored a +reference to this table somewhere, and it was later used and modified +after it was added to the global registry. Using `local_` +annotations allows this constraint to be made explicit and checked at +compile time, by giving `uses_callback` the signature: + + val uses_callback : f:(local_ int Foo.Table.t -> 'a) -> 'a + + +## Inference + +The examples above use the local_ keyword to mark local +allocations. In fact, this is not necessary, and the compiler will +use local allocations by default where possible, as long as the +`-extension local` flag is enabled. + +The only effect of the keyword on e.g. a let binding is to change the +behavior for escaping values: if the bound value looks like it escapes +and therefore cannot be locally allocated, then without the keyword +the compiler will allocate this value on the GC heap as usual, while +with the keyword it will instead report an error. + +Inference can even determine whether parameters are local, which is +useful for helper functions. It's less useful for toplevel functions, +though, as whether their parameters are local is generally forced by +their signature in the mli file, where no inference is performed. + +Inference does not work across files: if you want e.g. to pass a local +argument to a function in another module, you'll need to explicitly +mark the local parameter in the other module's mli. + + + + +## More control + +There are a number of other features that allow more precise control +over which values are locally allocated, including: + + - **Local closures**: + + ``` + let local_ f a b c = ... + ``` + + defines a function `f` whose closure is itself locally allocated. + + - **Local-returning functions** + + ``` + let f a b c = local_ + ... + ``` + + defines a function `f` which returns local allocations into its + caller's region. + + - **Global fields** + + ``` + type 'a t = { global_ g : 'a } + ``` + + defines a record type `t` whose `g` field is always known to be on + the GC heap (and may therfore freely escape regions), even though + the record itself may be locally allocated. + +For more details, read [the reference](./local-reference.md). diff --git a/jane/doc/local-pitfalls.md b/jane/doc/local-pitfalls.md new file mode 100644 index 00000000000..b51bbc1f989 --- /dev/null +++ b/jane/doc/local-pitfalls.md @@ -0,0 +1,78 @@ +# Some Pitfalls of Local Allocations + +This document outlines some common pitfalls that may come up when +trying out local allocations in a new codebase, as well as some +suggested workarounds. Over time, this list may grow (as experience +discovers new things that go wrong) or shrink (as we deploy new +compiler versions that ameliorate some issues). + + +## Tail calls + +Many OCaml functions just happen to end in a tail call, even those +that are not intentionally tail-recursive. To preserve the +constant-space property of tail calls, the compiler applies special +rules around local allocations in tail calls (see [the +reference](./local-reference.md)). + +If this causes a problem for calls that just happen to be in tail +position, the easiest workaround is to prevent them from being +treated as tail calls by moving them, replacing: + + func arg1 arg2 + +with + + let res = func arg1 arg2 in res + +With this version, local values used in `fun arg1 arg2` will be freed +after `func` returns. + +## Partial applications with local parameters + +To enable the use of local allocations with higher-order functions, a +necessary step is to add local annotations to function types, +particularly those of higher-order functions. For instance, an `iter` +function may become: + + val iter : 'a list -> f:local_ ('a -> unit) -> unit + +thus allowing locally-allocated closures `f` to be used. + +However, this is unfortunately not an entirely backwards-compatible +change. The problem is that partial applications of `iter` functions +with the new type are themselves locally allocated, because they close +over the possibly-local `f`. This means in particular that partial +applications will no longer be accepted as module-level definitions: + + let print_each_foo = iter ~f:(print_foo) + +The fix in these cases is to expand the partial application to a full +application by introducing extra arguments: + + let print_each_foo x = iter ~f:(print_foo) x + +## Typing of (@@) and (|>) + +The typechecking of (@@) and (|>) changed slightly with the local +allocations typechecker, in order to allow them to work with both +local and nonlocal arguments. The major difference is that: + + f x @@ y + y |> f x + f x y + +are now all typechecked in exactly the same way. Previously, the +first two were typechecked differently, as an application of an +operator to the expressions `f x` and `y`, rather than a single +application with two arguments. + +This affects which expressions are in "argument position", which can +have a subtle effect on when optional arguments are given their +default values. If this affects you (which is extremely rare), you +will see type errors involving optional parameters, and you can +restore the old behaviour by removing the use of `(@@)` or `(|>)` and +parenthesizing their subexpressions. That is, the old typing behaviour +of `f x @@ y` is available as: + + (f x) y diff --git a/jane/doc/local-reference.md b/jane/doc/local-reference.md new file mode 100644 index 00000000000..e8f85155331 --- /dev/null +++ b/jane/doc/local-reference.md @@ -0,0 +1,641 @@ +# Local Allocations Reference + +The goal of this document is to be a reasonably complete reference to local +allocations in OCaml. For a gentler introduction, see [the +introduction](local-intro.md). + +When local allocations are enabled with the `-extension local` flag, the +compiler may locally allocate some values, placing them on a stack rather than +the garbage collected heap. Instead of waiting for the next GC, the memory used +by locally allocated values is reclaimed when their _region_ (see below) ends, and +can be immediately reused. Whether the compiler locally allocates certain values +is controlled using a new keyword currently spelled `local_`, whose effects in +expressions, patterns and types are explained below. + + +## Local expressions and allocation + +The `local_` keyword may be placed on an expression to indicate that +allocations in that expression should be locally allocated: + + let abc = local_ [a; b; c] in + ... + +Here, the three cons cells of the list `[a; b; c]` will all be locally +allocated. + +Equivalently, the keyword `local_` may precede the pattern in a `let`: + + let local_ abc = [a; b; c] in + ... + +Locally allocated values may reference global (that is, GC-allocated or +constant) values, but global values may not reference local ones. In the +example above, any or all of `a`, `b` and `c` may themselves be locally +allocated. + +It is valid for an expression annotated `local_` to still yield a global value. +For instance, if there is a global `x : int list` in scope, then this is +allowed: + + let l = local_ if n > 0 then n :: x else x in + ... + +Here, if `n > 0`, then `l` will be a locally-allocated cons cell. However, if +`n <= 0`, then `l` will be `x`, which is global. In other words, the `local_` +keyword on an expression permits but does not oblige that expression to locally +allocate its result. + +Most OCaml types can be locally allocated, including records, variants, +polymorphic variants, closures, boxed numbers and strings. However, certain +values cannot be locally allocated, and will always be on the GC heap, +including: + + - Modules (including first-class modules) + + - Exceptions + (Technically, values of type `exn` can be locally allocated, but only global ones may be raised) + + - Classes and objects + +In addition, any value that is to be put into a mutable field (for example +inside a `ref`, an `array` or a mutable record) cannot be locally allocated. + + +## Inference + +In fact, the allocations of the examples above will be locally +allocated even without the `local_` keyword, if it is safe to do so +(and the `-extension local` flag is enabled). The presence of the +keyword on an expression only affects what happens if the value +escapes (e.g. is stored into a global hashtable) and therefore cannot +be locally allocated. With the keyword, an error will be reported, +while without the keyword the allocations will occur on the GC heap as +usual. + +Inference does not cross file boundaries. If local annotations subject to +inference appear in the type of a module (e.g. since they can appear in +function types, see below) then inference will resolve them according to what +appears in the `.mli`. If there is no `.mli` file, then inference will always +choose `global` for anything that can be accessed from another file. + +## Regions + +Every local allocation takes places inside a _region_, which is a block of code +(usually a function body, but see below). At the end of a region, all of its +local allocations are freed. + +Regions may nest, for instance when one function calls another. Local +allocations always occur in the innermost (most recent) region. + +We say that a value _escapes_ a region if it is still referenced beyond the end +of that region. The job of the typechecker is to ensure that locally allocated +values do not escape the region they were allocated in. + +"Region" is a wider concept than "scope", and locally-allocated variables can +outlive their scope. For example: + + let f () = + let local_ counter = + let local_ r = ref 42 in + incr r; + r + in + ... + +The locally-allocated reference `r` is allocated inside the definition of +`counter`. This value outlives the scope of `r` (it is bound to the variable +`counter` and may later be used in the code marked `...`). However, the +typechecker ensures that it does not outlive the region in which it is +allocated, which is the entire body of `f`. + +As well as function bodies, a region is also placed around: + + - Loop bodies (`while` and `for`) + - Lazy expressions (`lazy ...`) + - Module bindings (`let x = ...` at module level, including in submodules) + +Module bindings are wrapped in regions to enforce the rule (as mentioned above) +that modules never contain locally-allocated values. + +Additionally, it is possible to write functions that do *not* have +a region around their body, which is useful to write functions that +return locally-allocated values. See "Local-returning functions" below. + +### Runtime behaviour + +At runtime, local allocations do not allocate on the C stack, but on a +separately-allocated stack that follows the same layout as the OCaml +minor heap. In particular, this allows local-returning functions +without the need to copy returned values. + +The beginning of a region records the stack pointer of this local +stack, and the end of the region resets the stack pointer to this +value. + + +### Variables and regions + +To spot escaping local allocations, the type checker internally tracks whether +each variable is: + + - **Global**: must be a global value. These variables are allowed to freely + cross region boundaries, as normal OCaml values. + + - **Local**: may be a locally-allocated value. These variables are restricted + from crossing region boundaries. + +As described above, whether a given variable is global or local is inferred by +the typechecker, although the `local_` keyword may be used to specify it. + +Additionally, local variables are further subdivided into two cases: + + - **Outer-region local**: may be a locally-allocated value, but only from an outer + region and not from the current one. + + - **Any-region local**: may be a locally-allocated value, even one allocated + during the current region. + +For instance: + + let f () = + let local_ outer = ref 42 in + let g () = + let local_ inner = ref 42 in + ?? + in + ... + +At the point marked `??` inside `g`, both `outer` and `inner` are +locally-allocated values. However, only `inner` is any-region local, having been +allocated in `g`'s region. The value `outer` is instead outer-region local: it +is locally allocated but from a region other than `g`'s own. + +So, if we replace `??` with `inner`, we see an error: + + Error: This local value escapes its region + +However, if we replace `??` with `outer`, the compiler will accept it: the +value `outer`, while locally allocated, was definitely not locally allocated +_during g_, and there is therefore no problem allowing it to escape `g`'s +region. + +(This is quite subtle, and there is an additional wrinkle: how does the +compiler know that it is safe to still refer to `outer` from within the closure +`g`? See "Closures" below for more details) + + +## Function types and local arguments + +Function types now accept the `local_` keyword in both argument and return +positions, leading to four distinct types of function: + + a -> b + local_ a -> b + a -> local_ b + local_ a -> local_ b + +In argument positions, `local_` indicates that the function may be passed +locally-allocated values. As always, the local_ keyword does not *require* +a locally-allocated value, and you may pass global values to such functions. In +effect, a function of type `local_ a -> b` is a function accepting `a` +and returning `b` that promises not to capture any reference to its argument. + +In return positions, `local_` indicates that the function may return +locally-allocated values. A function of type `local_ a -> local_ b` promises +not to capture any reference to its argument except possibly in its return +value. + +A function with a local argument can be defined by annotating the argument as +`local_`: + + let f (local_ x) = ... + +Inside the definition of `f`, the argument `x` is outer-region local: that is, +while it may be locally allocated, it is known not to have been allocated during +`f` itself, and thus may safely be returned from `f`. For example: + + # let f1 (local_ x : int list) = [1; 2; 3] + val f1 : local_ int list -> int list + + # let f2 (local_ x : int list) = x + val f2 : local_ int list -> local_ int list + + # let f3 (local_ x : int list) = (42 :: x) + ^ + Error: This value escapes its region + +In the above, `f1` returns a global `int list`, while `f2` returns a local one. +`f2` is allowed to return the local value `x` despite the ending of the +function's region, because the value `x` is known to come from outside that +region. + +In contrast, `f3` is an error. The value `42 :: x` must be locally allocated (as +it refers to a local value `x`), and it is locally allocated from within the +region of `f3`. When this region ends, the any-region local value `42 :: x` is +not allowed to escape it. + +It is possible to write functions like `f3` that return +locally-allocated values, but this requires explicit annotation, as it +would otherwise be easy to do by mistake. See "Local-returning +functions" below. + +Like local variables, inference can determine whether function arguments are +local. However, note that for arguments of exported functions to be local, the +`local_` keyword must appear in their declarations in the corresponding `.mli` +file. + + +## Closures + +Like most other values, closures can be locally allocated. In particular, this +happens when a closure closes over local values from an outer scope: since +global values cannot refer to local values, all such closures _must_ be locally +allocated. + +Consider again the example from "Variables and regions" above: + + let f () = + let local_ outer = ref 42 in + let g () = + let local_ inner = ref 42 in + outer + in + ... + +Here, since `g` refers to the local value `outer`, the closure `g` must itself +be locally allocated. (As always, this is deduced by inference, and an explicit +`local_` annotation on `g` is not needed). + +This then means that `g` is not allowed to escape its region, i.e. the body of +`f`. `f` may call `g` but may not return the closure. This guarantees that `g` +will only run before `f` has ended, which is what makes it safe to refer to +`outer` from within `g`. + +Higher-order functions should usually mark their function arguments as +`local_`, to allow local closures to be passed in. For instance, consider the +following function for computing the length of a list: + + let length xs = + let local_ count = ref 0 in + List.iter xs ~f:(fun () -> incr count); + !count + +With the standard type of `List.iter`, this results in a type error: + + List.iter xs ~f:(fun () -> incr count); + ^^^^^ + Error: The value count is local, so cannot be used inside a closure that might escape + +The standard type of `List.iter` is as follows: + + val iter : 'a list -> f:('a -> unit) -> unit + +This type places no restrictions on the use of `f`, allowing `iter` to capture +or otherwise leak its argument `f`. It is therefore not safe to pass a local +closure to such a function, hence the error. + +Instead, `List.iter` and similar functions should be given the following type: + + val iter : 'a list -> f:local_ ('a -> unit) -> unit + +This type carries the additional promise that `iter` does not capture its `f` +argument, allowing local closures to be passed. With this type, the above +`length` function is accepted. + +Note that the function `f` here _is_ allowed to capture its argument, +and there are no restrictions on what may be done with the list +elements themselves. To specify that `f` may _not_ capture its +argument, the type of iter would have to be: + + val iter : 'a list -> f:local_ (local_ 'a -> unit) -> unit + +The two occurrences of `local_` are independent: the first is a promise +by `iter` not to capture `f`, while the second is a requirement by +`iter` to be given an `f` that does not itself capture. + + + +## Tail calls + +Usually, a function's region lasts for the entire body of that function, +cleaning up local allocations at the very end. This story gets more complicated +if the function ends in a tail call, however, as such functions need to clean +up their stack frame before the tail call in order to ensure that +tail-recursive loops use only constant space. + +Therefore, when a function ends in a tail call, that function's region ends: + + - after the arguments to the tail call have been evaluated + + - but before control is transferred to the callee. + +This early ending of the region introduces some restrictions, as values used in +tail calls then count as escaping the region. In particular, any-region local values +may not be passed to tail calls: + + let f1 () = + let local_ r = ref 42 in + some_func r + ^ + Error: This local value escapes its region + Hint: This argument cannot be local, because this is a tail call + +and any-region local closures may not be tail-called: + + let f2 () = + let local_ g () = 42 in + g () + ^ + Error: This local value escapes its region + Hint: This function cannot be local, because this is a tail call + +In both cases, if tail recursion is not necessary, then the issue can be +resolved by moving the call so that it is not syntactically a tail call: + + let f1 () = + let local_ r = ref 42 in + let res = some_func r in + res + + let f2 () = + let local_ g () = 42 in + let res = g () in + res + +This change means that the locally allocated values (`r` and `g`) +will not be freed until after the call has returned. + +Note that values which are outer-region local rather than any-region local (that +is, local values that were passed into this region from outside) may be used in +tail calls, as the early closing of the region does not affect them: + + let f3 (local_ x) = + some_func x + +Here, even though the region of `f3` ends before the call to `some_func`, the +value `x` remains available. + + + +## Local-returning functions + +The region around the body of a function prevents local allocations inside that +function from escaping. Occasionally, it is useful to write a function that +allows local allocations to escape, which can be done by explicitly marking +such functions. + +This is useful particularly for constructor functions of abstract types. For +instance, consider this code that uses an `int ref` as a counter: + + let f () = + let counter = ref 0 in + ... + let n = !counter in + incr counter; + ... + +Here, inference will detect that `counter` does not escape and will allocate +the reference locally. However, this changes if we try to abstract out +`counter` to its own module: + + module Counter = struct + type t = int ref + + let make () = + ref 0 + + let next c = + let x = !c in + incr c; + x + end + + let f () = + let counter = Counter.make () in + ... + let n = Counter.next counter in + ... + +In this code, the counter will *not* be allocated locally. The reason is the +`Counter.make` function: the allocation of `ref 0` escapes the region of +`Counter.make`, and the compiler will therefore not allow it to be locally +allocated. This remains the case no matter how many local_ annotations we write +inside `f`: the issue is the definition of `make`, not its uses. + +To allow the counter to be locally allocated, we need to specify that +`Counter.make` may return local allocations. This can be done by wrapping the +entire body of `make` with the `local_` keyword: + + let make () = local_ + ref 0 + +The `local_` keyword around a function body like this specifies not only that +the allocation of the `ref` should be local, but more importantly that the +function `make` *should not have its own region*. + +Instead, local allocations during `make` are considered part of `f`s region, +and will only be cleaned up when that region ends. Local allocations are +allocated as always in the nearest enclosing region. However if the current +function is a local-returning function, then the nearest enclosing region will +be the caller's (or that of the caller's caller, etc., if the caller is also +local-returning). + + +## Records and mutability + +For any given variable, the typechecker checks only whether that variable is +local or global, and generally does not separately track parts of the variable. +For instance, the following code yields an error, even though `x` and `y` are +both global: + + let f () = + let local_ packed = (x, y) in + let x', y' = packed in + x' + +Here, the `packed` values is treated as local, and the typechecker then +conservatively assumes that `x'` and `y'` may also be local (since they are +extracted from `packed`), and so cannot safely be returned. + +Similarly, a variable `local_ x` of type `string list` means a local +list of local strings, and none of these strings can be safely +returned from a function like `f`. + +This can be overriden for record types, by annotating some fields with +`global_`: + + type ('a, 'b) t = { global_ foo : 'a; bar: 'b } + + let f () = + let local_ packed = {foo=x; bar=y} in + let {foo; bar} = packed in + foo + +Here, the `foo` field of any value of type `_ t` is always known to be global, +and so can be returned from a function. When constructing such a record, the +`foo` field must therefore be a global value, so trying to fill it with a local +value will result in an escape error, even if the record being constructed is +itself local. + +In particular, by defining: + + type 'a glob = { global_ contents: 'a } [@@unboxed] + +then a variable `local_ x` of type `string glob list` is a local list +of global strings, and while the list itself cannot be returned out of +a region, the `contents` field of any of its elements can. + +### Mutability + +Mutable fields are always `global_`, including array elements. That is, while +you may create local `ref`s or arrays, their contents must always be global. + +This restriction may be lifted somewhat in future: the tricky part is that +naively permitting mutability might allow an older local mutable value to be +mutated to point to a younger one, creating a dangling reference to an escaping +value when the younger one's region ends. + + +## Curried functions + +The function type constructor in OCaml is right-associative, so that these are +equal types: + + string -> string -> string + string -> (string -> string) + +These both describe a two-argument function which is curried, and therefore may +be partially applied to the first argument, yielding a closure that accepts the +second. + +The situation is more complicated when `local_` is involved. The following two +types are *not* equivalent: + + local_ string -> string -> string + local_ string -> (string -> string) + +The former is a two-argument function which accepts as its first argument +a local string. Like all two-argument functions, it may be partially applied to +a single argument yielding a closure that accepts the second. However, since +this closure closes over the first local argument, it must necessarily be local +itself. Thus, if applied to a single argument, this function in fact returns +a _local_ closure, making its type equal to the following: + + local_ string -> local_ (string -> string) + +By constrast, the type `local_ string -> (string -> string)` means a function +that accepts a local string but returns a global function. Necessarily, this +global function cannot refer to the local string that was passed, so this +cannot be an ordinary two-argument function. (It could be something like `fun +s -> print s; fun x -> x`, however) + +In general, in a curried function type `... -> ... -> ...` (without +parentheses), then after the first use of `local_`, all arrow types except the +last will implictly be given `local_` return types, enabling the expected +partial application behaviour. + +Finally, this transformation applies also to types marked with the `local_` +keyword. For instance, the following type: + + local_ (a -> b -> c -> d) -> e -> f -> g + +is read as: + + local_ (a -> local_ (b -> local_ (c -> d))) -> local_ (e -> local_ (f -> g)) + +Note the implicit `local_` both in the returned `e -> f` closure (as described +above), and also in the type of the `b -> c` argument. + + +### Currying of local closures + +Suppose we are inside the definition of a function, and there is in scope +a local value `counter` of type `int ref`. Then of the following two +seemingly-identical definitions, the first is accepted and the second is +rejected: + + + let local_ f : int -> int -> int = fun a b -> a + b + !counter in + ... + + let f : int -> int -> int = local_ fun a b -> a + b + !counter in + ... + +Both define a closure which accepts two integers and returns an integer. The +closure must be local, since it refers to the local value `counter`. In the +former definition, the type of the function appears under the `local_` keyword, +as as described above is interpreted as: + + int -> local_ (int -> int) + +This is the correct type for this function: if we partially apply it to +a single argument, the resulting closure will still be local, as it refers to +the original function which refers to `counter`. By contrast, in the latter +definition the type of the function is outside the `local_` keyword as is +interpreted as normal as: + + int -> (int -> int) + +This is not the correct type for this function: it states that partially +applying it to a single argument will yield a global closure, which is not the +case here. For this reason, this version is rejected. It would be accepted if +written as follows: + + let f : int -> local_ (int -> int) = local_ fun a b -> a + b + !counter in + ... + + +## Special case typing of tuple matching + +As mentioned above, the typechecker generally does not separately track +the local or global status of parts of a value, but rather tracks this +only once per variable or expression. There is one exception to this +rule, as follows. + +In OCaml, it is possible to simultaneously match on multiple values: + +``` + match x, y, z with + | p, q, r -> ... +``` + +There is in fact no special syntax for this: as parentheses are +optional in tuples, the above is actually a match on a single value, +the tuple `(x, y, z)`, against a single pattern, the pattern `(p, q, +r)`. + +Applying the usual rule that an expression is either treated as +entirely local or entirely global would mean that `p`, `q` and `r` +would all be local if any of `x`, `y` and `z` are. This is +counterintuitive, as the syntax above is usually thought of as a +multiple-value match, rather than a match on a single tuple value. For +this reason, the typechecker indendently tracks whether the parts of +this tuple are local or global. + +The same logic applies to simultaneous binding of multiple values: + +``` + let a, b, c = + ... + x, y, z +``` + +Again, there is no actual syntax for this in OCaml: that's a binding +of the single value `(x, y, z)` against the single pattern `(a, b, +c)`. Since it's usually thought of as the simultaneous binding of +several variables, the typechecker treats it as such rather than +making all of `a`,`b` and `c` local if any of `x`, `y` and `z` are. + + +## Primitive definitions + +Allocations in OCaml functions must either be local or global, as these are +compiled separately. A different option is available for `%`-primitives exported +by the stdlib, however, as these are guaranteed to be inlined at every use +site. Unlike ordinary functions, these primitives may be used to make both +local and global allocations, which is why `ref` worked for both local and +global in various examples above. + +In the interface for the stdlib (and as re-exported by Base), this feature is +enabled by use of the `[@local_opt]` annotation on `external` declarations. diff --git a/lambda/lambda.ml b/lambda/lambda.ml index eda7afa6bac..dc235a3f9e7 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -32,12 +32,6 @@ type immediate_or_pointer = | Immediate | Pointer -type initialization_or_assignment = - | Assignment - | Local_assignment - | Heap_initialization - | Root_initialization - type is_safe = | Safe | Unsafe @@ -46,9 +40,62 @@ type field_read_semantics = | Reads_agree | Reads_vary -type alloc_mode = - | Alloc_heap - | Alloc_local +include (struct + + type alloc_mode = + | Alloc_heap + | Alloc_local + + let alloc_heap = Alloc_heap + + let alloc_local : alloc_mode = + if Config.stack_allocation then Alloc_local + else Alloc_heap + + let join_mode a b = + match a, b with + | Alloc_local, _ | _, Alloc_local -> Alloc_local + | Alloc_heap, Alloc_heap -> Alloc_heap + +end : sig + + type alloc_mode = private + | Alloc_heap + | Alloc_local + + val alloc_heap : alloc_mode + + val alloc_local : alloc_mode + + val join_mode : alloc_mode -> alloc_mode -> alloc_mode + +end) + +let is_local_mode = function + | Alloc_heap -> false + | Alloc_local -> true + +let is_heap_mode = function + | Alloc_heap -> true + | Alloc_local -> false + +let sub_mode a b = + match a, b with + | Alloc_heap, _ -> true + | _, Alloc_local -> true + | Alloc_local, Alloc_heap -> false + +let eq_mode a b = + match a, b with + | Alloc_heap, Alloc_heap -> true + | Alloc_local, Alloc_local -> true + | Alloc_heap, Alloc_local -> false + | Alloc_local, Alloc_heap -> false + +type initialization_or_assignment = + | Assignment of alloc_mode + | Heap_initialization + | Root_initialization type region_close = | Rc_normal @@ -435,7 +482,7 @@ let check_lfunction fn = assert (0 <= nlocal); assert (nlocal <= nparams); if not fn.region then assert (nlocal >= 1); - if mode = Alloc_local then assert (nlocal = nparams) + if is_local_mode mode then assert (nlocal = nparams) end let default_function_attribute = { @@ -1060,39 +1107,21 @@ let mod_field ?(read_semantics=Reads_agree) pos = let mod_setfield pos = Psetfield (pos, Pointer, Root_initialization) -let join_mode a b = - match a, b with - | Alloc_local, _ | _, Alloc_local -> Alloc_local - | Alloc_heap, Alloc_heap -> Alloc_heap - -let sub_mode a b = - match a, b with - | Alloc_heap, _ -> true - | _, Alloc_local -> true - | Alloc_local, Alloc_heap -> false - -let eq_mode a b = - match a, b with - | Alloc_heap, Alloc_heap -> true - | Alloc_local, Alloc_local -> true - | Alloc_heap, Alloc_local -> false - | Alloc_local, Alloc_heap -> false - let primitive_may_allocate : primitive -> alloc_mode option = function | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore -> None - | Prevapply _ | Pdirapply _ -> Some Alloc_local + | Prevapply _ | Pdirapply _ -> Some alloc_local | Pgetglobal _ | Psetglobal _ -> None | Pmakeblock (_, _, _, m) -> Some m | Pmakefloatblock (_, m) -> Some m | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ -> None | Pfloatfield (_, _, m) -> Some m | Psetfloatfield _ -> None - | Pduprecord _ -> Some Alloc_heap + | Pduprecord _ -> Some alloc_heap | Pccall p -> if not p.prim_alloc then None else begin match p.prim_native_repr_res with - | (Prim_local|Prim_poly), _ -> Some Alloc_local - | Prim_global, _ -> Some Alloc_heap + | (Prim_local|Prim_poly), _ -> Some alloc_local + | Prim_global, _ -> Some alloc_heap end | Praise _ -> None | Psequor | Psequand | Pnot @@ -1113,7 +1142,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None | Pmakearray (_, _, m) -> Some m - | Pduparray _ -> Some Alloc_heap + | Pduparray _ -> Some alloc_heap | Parraylength _ -> None | Parraysetu _ | Parraysets _ | Parrayrefu (Paddrarray|Pintarray) @@ -1121,7 +1150,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Parrayrefu (Pgenarray|Pfloatarray) | Parrayrefs (Pgenarray|Pfloatarray) -> (* The float box from flat floatarray access is always Alloc_heap *) - Some Alloc_heap + Some alloc_heap | Pisint | Pisout -> None | Pintofbint _ -> None | Pbintofint (_,m) @@ -1142,7 +1171,7 @@ let primitive_may_allocate : primitive -> alloc_mode option = function | Pbigarrayset _ | Pbigarraydim _ -> None | Pbigarrayref (_, _, _, _) -> (* Boxes arising from Bigarray access are always Alloc_heap *) - Some Alloc_heap + Some alloc_heap | Pstring_load_16 _ | Pbytes_load_16 _ -> None | Pstring_load_32 (_, m) | Pbytes_load_32 (_, m) | Pstring_load_64 (_, m) | Pbytes_load_64 (_, m) -> Some m diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 66bd986c0b0..203b98d5fc6 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -34,9 +34,19 @@ type immediate_or_pointer = | Immediate | Pointer +type alloc_mode = private + | Alloc_heap + | Alloc_local + +val alloc_heap : alloc_mode + +(* Actually [Alloc_heap] if [Config.stack_allocation] is [false] *) +val alloc_local : alloc_mode + type initialization_or_assignment = - | Assignment - | Local_assignment (* mutations of blocks that may be locally allocated *) + (* [Assignment Alloc_local] is a mutation of a block that may be heap or local. + [Assignment Alloc_heap] is a mutation of a block that's definitely heap. *) + | Assignment of alloc_mode (* Initialization of in heap values, like [caml_initialize] C primitive. The field should not have been read before and initialization should happen only once. *) @@ -53,10 +63,6 @@ type field_read_semantics = | Reads_agree | Reads_vary -type alloc_mode = - | Alloc_heap - | Alloc_local - (* Tail calls can close their enclosing region early *) type region_close = | Rc_normal @@ -489,6 +495,8 @@ val max_arity : unit -> int val join_mode : alloc_mode -> alloc_mode -> alloc_mode val sub_mode : alloc_mode -> alloc_mode -> bool val eq_mode : alloc_mode -> alloc_mode -> bool +val is_local_mode : alloc_mode -> bool +val is_heap_mode : alloc_mode -> bool val primitive_may_allocate : primitive -> alloc_mode option (** Whether and where a primitive may allocate. diff --git a/lambda/matching.ml b/lambda/matching.ml index 9fc2017bcce..52ccc6d5b3e 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1847,7 +1847,7 @@ let inline_lazy_force_cond arg pos loc = ap_func = force_fun; ap_args = [ varg ]; ap_region_close = pos; - ap_mode = Alloc_heap; + ap_mode = alloc_heap; ap_inlined = Default_inlined; ap_specialised = Default_specialise; ap_probe=None @@ -1883,7 +1883,7 @@ let inline_lazy_force_switch arg pos loc = ap_func = force_fun; ap_args = [ varg ]; ap_region_close = pos; - ap_mode = Alloc_heap; + ap_mode = alloc_heap; ap_inlined = Default_inlined; ap_specialised = Default_specialise; ap_probe=None; @@ -1905,7 +1905,7 @@ let inline_lazy_force arg pos loc = ap_func = Lazy.force code_force_lazy; ap_args = [ arg ]; ap_region_close = pos; - ap_mode = Alloc_heap; + ap_mode = alloc_heap; ap_inlined = Default_inlined; ap_specialised = Default_specialise; ap_probe=None; @@ -1999,7 +1999,7 @@ let get_expr_args_record ~scopes head (arg, _mut) rem = | Record_unboxed _ -> arg | Record_float -> (* TODO: could optimise to Alloc_local sometimes *) - Lprim (Pfloatfield (lbl.lbl_pos, sem, Alloc_heap), [ arg ], loc) + Lprim (Pfloatfield (lbl.lbl_pos, sem, alloc_heap), [ arg ], loc) | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1, sem), [ arg ], loc) in @@ -3402,7 +3402,7 @@ let failure_handler ~scopes loc ~failer () = Lprim ( Praise Raise_regular, [ Lprim - ( Pmakeblock (0, Immutable, None, Alloc_heap), + ( Pmakeblock (0, Immutable, None, alloc_heap), [ slot; Lconst (Const_block diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 4e3ad423e2b..4ac5e0b3c94 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -88,7 +88,7 @@ and value_kind' ppf = function let return_kind ppf (mode, kind) = let smode = alloc_mode mode in match kind with - | Pgenval when mode = Alloc_heap -> () + | Pgenval when is_heap_mode mode -> () | Pgenval -> fprintf ppf ": %s@ " smode | Pintval -> fprintf ppf ": int@ " | Pfloatval -> fprintf ppf ": %sfloat@ " smode @@ -238,8 +238,8 @@ let primitive ppf = function match init with | Heap_initialization -> "(heap-init)" | Root_initialization -> "(root-init)" - | Assignment -> "" - | Local_assignment -> "(local)" + | Assignment Alloc_heap -> "" + | Assignment Alloc_local -> "(local)" in fprintf ppf "setfield_%s%s %i" instr init n | Psetfield_computed (ptr, init) -> @@ -252,8 +252,8 @@ let primitive ppf = function match init with | Heap_initialization -> "(heap-init)" | Root_initialization -> "(root-init)" - | Assignment -> "" - | Local_assignment -> "(local)" + | Assignment Alloc_heap -> "" + | Assignment Alloc_local -> "(local)" in fprintf ppf "setfield_%s%s_computed" instr init | Pfloatfield (n, sem, mode) -> @@ -264,8 +264,8 @@ let primitive ppf = function match init with | Heap_initialization -> "(heap-init)" | Root_initialization -> "(root-init)" - | Assignment -> "" - | Local_assignment -> "(local)" + | Assignment Alloc_heap -> "" + | Assignment Alloc_local -> "(local)" in fprintf ppf "setfloatfield%s %i" init n | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size @@ -341,7 +341,7 @@ let primitive ppf = function | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" | Pbintofint (bi,m) -> print_boxed_integer "of_int" ppf bi m - | Pintofbint bi -> print_boxed_integer "to_int" ppf bi Alloc_heap + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi alloc_heap | Pcvtbint (bi1, bi2, m) -> print_boxed_integer_conversion ppf bi1 bi2 m | Pnegbint (bi,m) -> print_boxed_integer "neg" ppf bi m | Paddbint (bi,m) -> print_boxed_integer "add" ppf bi m @@ -361,12 +361,12 @@ let primitive ppf = function | Plslbint (bi,m) -> print_boxed_integer "lsl" ppf bi m | Plsrbint (bi,m) -> print_boxed_integer "lsr" ppf bi m | Pasrbint (bi,m) -> print_boxed_integer "asr" ppf bi m - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi Alloc_heap - | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi Alloc_heap - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi Alloc_heap - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi Alloc_heap - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi Alloc_heap - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi Alloc_heap + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi alloc_heap + | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi alloc_heap + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi alloc_heap + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi alloc_heap + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi alloc_heap + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi alloc_heap | Pbigarrayref(unsafe, _n, kind, layout) -> print_bigarray "get" unsafe kind ppf layout | Pbigarrayset(unsafe, _n, kind, layout) -> @@ -603,11 +603,9 @@ let rec lam ppf = function | Lfunction{kind; params; return; body; attr; mode; region} -> let pr_params ppf params = match kind with - | Curried {nlocal} -> - let first_local = List.length params - nlocal in - List.iteri (fun i (param, k) -> - fprintf ppf "@ %a%a%s" Ident.print param value_kind k - (if first_local <= i then "[->L]" else "")) params + | Curried _ -> + List.iter (fun (param, k) -> + fprintf ppf "@ %a%a" Ident.print param value_kind k) params | Tupled -> fprintf ppf " ("; let first = ref true in @@ -618,7 +616,7 @@ let rec lam ppf = function value_kind ppf k) params; fprintf ppf ")" in - let rmode = if region then Alloc_heap else Alloc_local in + let rmode = if region then alloc_heap else alloc_local in fprintf ppf "@[<2>(function%s%a@ %a%a%a)@]" (alloc_kind mode) pr_params params function_attribute attr return_kind (rmode, return) lam body diff --git a/lambda/simplif.ml b/lambda/simplif.ml index 836bfac14aa..d8b70c381b5 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -231,7 +231,7 @@ let simplify_exits lam = ap_func=f; ap_args=[x]; ap_region_close=pos; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -248,7 +248,7 @@ let simplify_exits lam = ap_func=f; ap_args=[x]; ap_region_close=pos; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -541,7 +541,7 @@ let simplify_lets lam = when optimize && List.length params + List.length params' <= Lambda.max_arity() -> (* The returned function's mode should match the outer return mode *) - assert (inner_mode = Alloc_heap); + assert (is_heap_mode inner_mode); (* The return type is the type of the value returned after applying all the parameters to the function. The return type of the merged function taking [params @ params'] as @@ -768,7 +768,7 @@ let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ap_args = args; ap_loc = Loc_unknown; ap_region_close = Rc_normal; - ap_mode = Alloc_heap; + ap_mode = alloc_heap; ap_tailcall = Default_tailcall; ap_inlined = Default_inlined; ap_specialised = Default_specialise; diff --git a/lambda/translclass.ml b/lambda/translclass.ml index f55c31ea6ac..641cb11eb65 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -37,12 +37,12 @@ let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) params body = Lfunction {kind; params = params @ params'; return = Pgenval; body = body'; attr; - loc; mode = Alloc_heap; region} + loc; mode = alloc_heap; region} | _ -> Lfunction {kind; params; return = Pgenval; body; attr = default_function_attribute; - loc = Loc_unknown; mode = Alloc_heap; region} + loc = Loc_unknown; mode = alloc_heap; region} let lapply ap = match ap.ap_func with @@ -59,7 +59,7 @@ let mkappl (func, args) = ap_func=func; ap_args=args; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -81,7 +81,7 @@ let transl_meth_list lst = (0, List.map (fun lab -> Const_immstring lab) lst)) let set_inst_var ~scopes obj id expr = - Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment), + Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment alloc_heap), [Lvar obj; Lvar id; transl_exp ~scopes expr], Loc_unknown) let transl_val tbl create name = @@ -195,7 +195,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = loc = of_location ~scopes pat.pat_loc; body = Matching.for_function ~scopes Pgenval pat.pat_loc None (Lvar param) [pat, rem] partial; - mode = Alloc_heap; + mode = alloc_heap; region = true } in begin match obj_init with @@ -268,7 +268,7 @@ let output_methods tbl methods lam = lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam | _ -> let methods = - Lprim(Pmakeblock(0,Immutable,None,Alloc_heap), methods, Loc_unknown) + Lprim(Pmakeblock(0,Immutable,None,alloc_heap), methods, Loc_unknown) in lsequence (mkappl(oo_prim "set_methods", [Lvar tbl; Lprim (Popaque, [methods], Loc_unknown)])) @@ -465,7 +465,7 @@ let rec transl_class_rebind ~scopes obj_init cl vf = loc = of_location ~scopes pat.pat_loc; body = Matching.for_function ~scopes Pgenval pat.pat_loc None (Lvar param) [pat, rem] partial; - mode = Alloc_heap; + mode = alloc_heap; region = true } in (path, path_lam, @@ -518,7 +518,7 @@ let transl_class_rebind ~scopes cl vf = ap_func=Lvar obj_init; ap_args=[Lvar self]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -539,7 +539,7 @@ let transl_class_rebind ~scopes cl vf = Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init', Llet( Alias, Pgenval, cla, path_lam, - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table, Pgenval] (Llet(Strict, Pgenval, env_init, @@ -771,7 +771,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in let copy_env self = if top then lambda_unit else - Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment), + Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment alloc_heap), [Lvar self; Lvar env2; Lvar env1'], Loc_unknown)) and subst_env envs l lam = @@ -825,7 +825,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = attr = default_function_attribute; loc = Loc_unknown; return = Pgenval; - mode = Alloc_heap; + mode = alloc_heap; region = true; params = [cla, Pgenval]; body = cl_init}) in Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) @@ -839,17 +839,17 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), Lsequence( mkappl (oo_prim "init_class", [Lvar table]), - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [mkappl (Lvar env_init, [lambda_unit]); Lvar class_init; Lvar env_init; lambda_unit], Loc_unknown)))) and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [lambda_unit; Lfunction{kind = Curried {nlocal=0}; attr = default_function_attribute; loc = Loc_unknown; return = Pgenval; - mode = Alloc_heap; + mode = alloc_heap; region = true; params = [cla, Pgenval]; body = cl_init}; lambda_unit; lenvs], @@ -869,11 +869,11 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let lenv = let menv = if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map (fun id -> Lvar id) !new_ids_meths, Loc_unknown) in if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), menv :: List.map (fun id -> Lvar id) !new_ids_init, Loc_unknown) and linh_envs = @@ -884,7 +884,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let make_envs lam = Llet(StrictOpt, Pgenval, envs, (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), lenv :: linh_envs, Loc_unknown)), lam) and def_ids cla lam = @@ -908,18 +908,18 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = return = Pgenval; attr = default_function_attribute; loc = Loc_unknown; - mode = Alloc_heap; + mode = alloc_heap; region = true; body = def_ids cla cl_init}, lam) and lcache lam = if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else Llet(Strict, Pgenval, cached, mkappl (oo_prim "lookup_tables", - [Lvar tables; Lprim(Pmakearray(Paddrarray, Immutable, Alloc_heap), + [Lvar tables; Lprim(Pmakearray(Paddrarray, Immutable, alloc_heap), inh_keys, Loc_unknown)]), lam) and lset cached i lam = - Lprim(Psetfield(i, Pointer, Assignment), + Lprim(Psetfield(i, Pointer, Assignment alloc_heap), [Lvar cached; lam], Loc_unknown) in let ldirect () = @@ -934,7 +934,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = kind = Curried {nlocal=0}; attr = default_function_attribute; loc = Loc_unknown; - mode = Alloc_heap; + mode = alloc_heap; region = true; return = Pgenval; params = [cla, Pgenval]; @@ -961,7 +961,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Lsequence(lcheck_cache, make_envs ( if ids = [] then mkappl (lfield cached 0, [lenvs]) else - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), (if concrete then [mkappl (lfield cached 0, [lenvs]); lfield cached 1; diff --git a/lambda/translcomprehension.ml b/lambda/translcomprehension.ml index c3ab1a18986..dbe369f6046 100644 --- a/lambda/translcomprehension.ml +++ b/lambda/translcomprehension.ml @@ -135,7 +135,7 @@ let make_array ~loc ~kind ~size ~array = (* This array can be Immutable since it is empty and will later be replaced when an example value (to create the array) is known. That is also why the biding is a Variable. *) - let init = Lprim(Pmakearray(Pgenarray, Immutable, Alloc_heap), [], loc) in + let init = Lprim(Pmakearray(Pgenarray, Immutable, alloc_heap), [], loc) in binding Variable Pgenval array init | Pintarray | Paddrarray -> let init = make_array_prim ~loc size (int 0) in @@ -453,13 +453,13 @@ let transl_list_comp type_comp body acc_var mats ~transl_exp ~scopes ~loc = attr = default_function_attribute; loc = loc; body = body; - mode = Alloc_heap; + mode = alloc_heap; region = true} in Lapply{ ap_loc=loc; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_func=func; ap_args= fn::args; ap_tailcall=Default_tailcall; @@ -473,7 +473,7 @@ let transl_list_comprehension ~transl_exp ~loc ~scopes body blocks = let value_kind = Typeopt.value_kind body.exp_env body.exp_type in let bdy = Lprim( - Pmakeblock(0, Immutable, None, Alloc_heap), + Pmakeblock(0, Immutable, None, alloc_heap), [(transl_exp ~scopes body); Lvar(acc_var)], loc) in let res_list, res_var = List.fold_left @@ -503,7 +503,7 @@ let transl_list_comprehension ~transl_exp ~loc ~scopes body blocks = ap_func=comp_rev (); ap_args=[res_list]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 8c2672cae54..99680d817d0 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -28,7 +28,6 @@ open Debuginfo.Scoped_location type error = Free_super_var | Unreachable_reached - | Local_allocs_not_enabled exception Error of Location.t * error @@ -76,7 +75,7 @@ let transl_extension_constructor ~scopes env path ext = (* Extension constructors are currently always Alloc_heap. They could be Alloc_local, but that would require changes to pattern typing, as patterns can close over them. *) - Lprim (Pmakeblock (Obj.object_tag, Immutable_unique, None, Alloc_heap), + Lprim (Pmakeblock (Obj.object_tag, Immutable_unique, None, alloc_heap), [Lconst (Const_base (Const_string (name, ext.ext_loc, None))); Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)], loc) @@ -95,25 +94,24 @@ let extract_float = function Const_base(Const_float f) -> f | _ -> fatal_error "Translcore.extract_float" -let transl_alloc_mode loc alloc_mode : Lambda.alloc_mode = +let transl_alloc_mode alloc_mode = match Btype.Alloc_mode.constrain_lower alloc_mode with - | Global -> Alloc_heap - | Local -> - if not (Clflags.Extension.is_enabled Local) then - raise (Error (loc, Local_allocs_not_enabled)); - Alloc_local + | Global -> alloc_heap + | Local -> alloc_local -let transl_value_mode loc mode = +let transl_value_mode mode = let alloc_mode = Btype.Value_mode.regional_to_global_alloc mode in - transl_alloc_mode loc alloc_mode + transl_alloc_mode alloc_mode -let transl_exp_mode e = transl_value_mode e.exp_loc e.exp_mode -let transl_pat_mode p = transl_value_mode p.pat_loc p.pat_mode +let transl_exp_mode e = transl_value_mode e.exp_mode +let transl_pat_mode p = transl_value_mode p.pat_mode let transl_apply_position position = match position with | Nontail -> Rc_normal - | Tail -> Rc_close_at_apply + | Tail -> + if Config.stack_allocation then Rc_close_at_apply + else Rc_normal let may_allocate_in_region lam = let rec loop = function @@ -147,9 +145,12 @@ let may_allocate_in_region lam = | Levent _ | Lifused _) as lam -> Lambda.iter_head_constructor loop lam in - match loop lam with - | () -> false - | exception Exit -> true + if not Config.stack_allocation then false + else begin + match loop lam with + | () -> false + | exception Exit -> true + end let maybe_region lam = let rec remove_tail_markers = function @@ -161,7 +162,8 @@ let maybe_region lam = | lam -> Lambda.shallow_map ~tail:remove_tail_markers ~non_tail:Fun.id lam in - if may_allocate_in_region lam then Lregion lam + if not Config.stack_allocation then lam + else if may_allocate_in_region lam then Lregion lam else remove_tail_markers lam (* Push the default values under the functional abstractions *) @@ -270,7 +272,7 @@ let assert_failed ~scopes exp = in let loc = of_location ~scopes exp.exp_loc in Lprim(Praise Raise_regular, [event_after ~scopes exp - (Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [slot; Lconst(Const_block(0, [Const_base(Const_string (fname, exp.exp_loc, None)); @@ -296,7 +298,7 @@ let rec iter_exn_names f pat = let transl_ident loc env ty path desc kind = match desc.val_kind, kind with | Val_prim p, Id_prim pmode -> - let poly_mode = transl_alloc_mode (to_location loc) pmode in + let poly_mode = transl_alloc_mode pmode in Translprim.transl_primitive loc p env ty ~poly_mode (Some path) | Val_anc _, Id_value -> raise(Error(to_location loc, Free_super_var)) @@ -304,7 +306,7 @@ let transl_ident loc env ty path desc kind = transl_value_path loc env path | _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" -let can_apply_primitive loc p pmode pos args = +let can_apply_primitive p pmode pos args = let is_omitted = function | Arg _ -> false | Omitted _ -> true @@ -317,7 +319,7 @@ let can_apply_primitive loc p pmode pos args = else if pos = Typedtree.Nontail then true else begin let return_mode = Ctype.prim_mode pmode p.prim_native_repr_res in - (transl_alloc_mode loc return_mode = Alloc_heap) + is_heap_mode (transl_alloc_mode return_mode) end end @@ -360,7 +362,7 @@ and transl_exp0 ~in_new_scope ~scopes e = | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}, Id_prim pmode); exp_type = prim_type } as funct, oargs, pos) - when can_apply_primitive e.exp_loc p pmode pos oargs -> + when can_apply_primitive p pmode pos oargs -> let argl, extra_args = cut p.prim_arity oargs in let arg_exps = List.map (function _, Arg x -> x | _ -> assert false) argl @@ -371,7 +373,7 @@ and transl_exp0 ~in_new_scope ~scopes e = if extra_args = [] then transl_apply_position pos else Rc_normal in - let prim_mode = transl_alloc_mode e.exp_loc pmode in + let prim_mode = transl_alloc_mode pmode in let lam = Translprim.transl_primitive_application (of_location ~scopes e.exp_loc) p e.exp_env prim_type prim_mode @@ -503,9 +505,7 @@ and transl_exp0 ~in_new_scope ~scopes e = | Texp_setfield(arg, _, lbl, newval) -> let mode = let arg_mode = Btype.Value_mode.regional_to_local_alloc arg.exp_mode in - match Btype.Alloc_mode.constrain_lower arg_mode with - | Global -> Assignment - | Local -> Local_assignment + Assignment (transl_alloc_mode arg_mode) in let access = match lbl.lbl_repres with @@ -533,7 +533,7 @@ and transl_exp0 ~in_new_scope ~scopes e = raise Not_constant end; (* Pduparray only works in Alloc_heap mode *) - if mode <> Alloc_heap then raise Not_constant; + if is_local_mode mode then raise Not_constant; begin match List.map extract_constant ll with | exception Not_constant when kind = Pfloatarray -> (* We cannot currently lift [Pintarray] arrays safely in Flambda @@ -626,7 +626,7 @@ and transl_exp0 ~in_new_scope ~scopes e = [transl_class_path loc e.exp_env cl], loc); ap_args=[lambda_unit]; ap_region_close=pos; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -652,7 +652,7 @@ and transl_exp0 ~in_new_scope ~scopes e = ap_func=Translobj.oo_prim "copy"; ap_args=[self]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -697,7 +697,7 @@ and transl_exp0 ~in_new_scope ~scopes e = else begin Lifthenelse (transl_exp ~scopes cond, - lambda_unit, + lambda_unit, assert_failed ~scopes e, Pintval (* unit *)) end @@ -705,7 +705,7 @@ and transl_exp0 ~in_new_scope ~scopes e = (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would do *) - assert (transl_exp_mode e = Alloc_heap); + assert (is_heap_mode (transl_exp_mode e)); begin match Typeopt.classify_lazy_argument e with | `Constant_or_function -> (* A constant expr (of type <> float if [Config.flat_float_array] is @@ -716,7 +716,7 @@ and transl_exp0 ~in_new_scope ~scopes e = block will never be shortcutted since it points to a float and Config.flat_float_array is true. *) Lprim(Pmakeblock(Obj.forward_tag, Immutable, None, - Alloc_heap), + alloc_heap), [transl_exp ~scopes e], of_location ~scopes e.exp_loc) | `Identifier `Forward_value -> (* CR-someday mshinwell: Consider adding a new primitive @@ -727,7 +727,7 @@ and transl_exp0 ~in_new_scope ~scopes e = value may subsequently turn into an immediate... *) Lprim (Popaque, [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None, - Alloc_heap), + alloc_heap), [transl_exp ~scopes e], of_location ~scopes e.exp_loc)], of_location ~scopes e.exp_loc) @@ -741,11 +741,11 @@ and transl_exp0 ~in_new_scope ~scopes e = return = Pgenval; attr = default_function_attribute; loc = of_location ~scopes e.exp_loc; - mode = Alloc_heap; + mode = alloc_heap; region = true; body = maybe_region (transl_exp ~scopes e)} in Lprim(Pmakeblock(Config.lazy_tag, Mutable, None, - Alloc_heap), [fn], + alloc_heap), [fn], of_location ~scopes e.exp_loc) end | Texp_object (cs, meths) -> @@ -811,7 +811,7 @@ and transl_exp0 ~in_new_scope ~scopes e = body; loc = of_location ~scopes exp.exp_loc; attr; - mode=Alloc_heap; + mode=alloc_heap; region=true; } in @@ -819,7 +819,7 @@ and transl_exp0 ~in_new_scope ~scopes e = { ap_func = Lvar funcid; ap_args = List.map (fun id -> Lvar id) arg_idents; ap_region_close = Rc_normal; - ap_mode = Alloc_heap; + ap_mode = alloc_heap; ap_loc = of_location e.exp_loc ~scopes; ap_tailcall = Default_tailcall; ap_inlined = Never_inlined; @@ -905,7 +905,7 @@ and transl_apply ~scopes ?(inlined = Default_inlined) ?(specialised = Default_specialise) ?(position=Rc_normal) - ?(mode=Alloc_heap) + ?(mode=alloc_heap) lam sargs loc = let lapply funct args loc pos mode = @@ -969,10 +969,9 @@ and transl_apply ~scopes let id_arg = Ident.create_local "param" in let body = let loc = map_scopes enter_partial_or_eta_wrapper loc in - let sloc = to_location loc in - let mode = transl_alloc_mode sloc mode_closure in - let arg_mode = transl_alloc_mode sloc mode_arg in - let ret_mode = transl_alloc_mode sloc mode_ret in + let mode = transl_alloc_mode mode_closure in + let arg_mode = transl_alloc_mode mode_arg in + let ret_mode = transl_alloc_mode mode_ret in let body = build_apply handle [Lvar id_arg] loc Rc_normal ret_mode l in let nlocal = match join_mode mode (join_mode arg_mode ret_mode) with @@ -1019,7 +1018,7 @@ and transl_curried_function exp_env; exp_type; exp_loc; exp_mode}}] when arity < max_arity -> let arg_mode = transl_pat_mode pat in - let curry_mode = transl_value_mode exp_loc exp_mode in + let curry_mode = transl_value_mode exp_mode in (* Lfunctions must have local returns after the first local arg/ret *) if not (sub_mode mode curry_mode && sub_mode arg_mode curry_mode) then (* Cannot curry here *) @@ -1068,11 +1067,11 @@ and transl_tupled_function ~scopes ~arity ~mode ~region loc return repr partial (param:Ident.t) cases = match cases with - | {c_lhs={pat_desc = Tpat_tuple pl; pat_loc; pat_mode }} :: _ + | {c_lhs={pat_desc = Tpat_tuple pl; pat_mode }} :: _ when !Clflags.native_code && arity = 1 - && mode = Alloc_heap - && transl_value_mode pat_loc pat_mode = Alloc_heap + && is_heap_mode mode + && is_heap_mode (transl_value_mode pat_mode) && List.length pl <= (Lambda.max_arity ()) -> begin try let size = List.length pl in @@ -1102,9 +1101,12 @@ and transl_tupled_function List.map (fun kind -> Ident.create_local "param", kind) kinds in let params = List.map fst tparams in - ((Tupled, tparams, return, region), - Matching.for_tupled_function ~scopes loc return params - (transl_tupled_cases ~scopes pats_expr_list) partial) + let body = + Matching.for_tupled_function ~scopes loc return params + (transl_tupled_cases ~scopes pats_expr_list) partial + in + let region = region || not (may_allocate_in_region body) in + ((Tupled, tparams, return, region), body) with Matching.Cannot_flatten -> transl_function0 ~scopes loc ~mode ~region return repr partial param cases @@ -1119,7 +1121,7 @@ and transl_function0 match cases with | [] -> (* With Camlp4, a pattern matching might be empty *) - Alloc_heap, Pgenval + alloc_heap, Pgenval | {c_lhs=pat} :: other_cases -> (* All the patterns might not share the same types. We must take the union of the patterns types *) @@ -1224,7 +1226,7 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false) fun body -> Lletrec(lam_bds, body) and transl_setinstvar ~scopes loc self var expr = - Lprim(Psetfield_computed (maybe_pointer expr, Assignment), + Lprim(Psetfield_computed (maybe_pointer expr, Assignment alloc_heap), [self; var; transl_exp ~scopes expr], loc) and transl_record ~scopes loc env mode fields repres opt_init_expr = @@ -1232,7 +1234,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = (* Determine if there are "enough" fields (only relevant if this is a functional-style record update *) let no_init = match opt_init_expr with None -> true | _ -> false in - if no_init || size < Config.max_young_wosize || mode = Lambda.Alloc_local + if no_init || size < Config.max_young_wosize || is_local_mode mode then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) @@ -1256,7 +1258,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = | Record_float -> (* This allocation is always deleted, so it's simpler to leave it Alloc_heap *) - Pfloatfield (i, sem, Alloc_heap) in + Pfloatfield (i, sem, alloc_heap) in Lprim(access, [Lvar init_id], of_location ~scopes loc), field_kind @@ -1314,11 +1316,15 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = match repres with Record_regular | Record_inlined _ -> - Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) + let ptr = maybe_pointer expr in + Psetfield(lbl.lbl_pos, ptr, Assignment alloc_heap) | Record_unboxed _ -> assert false - | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_float -> + Psetfloatfield (lbl.lbl_pos, Assignment alloc_heap) | Record_extension _ -> - Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) + let pos = lbl.lbl_pos + 1 in + let ptr = maybe_pointer expr in + Psetfield(pos, ptr, Assignment alloc_heap) in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp ~scopes expr], of_location ~scopes loc), @@ -1327,7 +1333,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = begin match opt_init_expr with None -> assert false | Some init_expr -> - assert (mode = Lambda.Alloc_heap); (* Pduprecord must be Alloc_heap *) + assert (is_heap_mode mode); (* Pduprecord must be Alloc_heap *) Llet(Strict, Pgenval, copy_id, Lprim(Pduprecord (repres, size), [transl_exp ~scopes init_expr], of_location ~scopes loc), @@ -1449,7 +1455,7 @@ and transl_letop ~scopes loc env let_ ands param case partial = ap_func = op; ap_args=[Lvar left_id; Lvar right_id]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall = Default_tailcall; ap_inlined = Default_inlined; ap_specialised = Default_specialise; @@ -1469,20 +1475,20 @@ and transl_letop ~scopes loc env let_ ands param case partial = event_function ~scopes case.c_rhs (function repr -> transl_curried_function ~scopes case.c_rhs.exp_loc return_kind - repr ~mode:Alloc_heap ~region:true partial param [case]) + repr ~mode:alloc_heap ~region:true partial param [case]) in let attr = default_function_attribute in let loc = of_location ~scopes case.c_rhs.exp_loc in let body = maybe_region body in Lfunction{kind; params; return; body; attr; loc; - mode=Alloc_heap; region=true} + mode=alloc_heap; region=true} in Lapply{ ap_loc = of_location ~scopes loc; ap_func = op; ap_args=[exp; func]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall = Default_tailcall; ap_inlined = Default_inlined; ap_specialised = Default_specialise; @@ -1516,8 +1522,6 @@ let report_error ppf = function "Ancestor names can only be used to select inherited methods" | Unreachable_reached -> fprintf ppf "Unreachable expression was reached" - | Local_allocs_not_enabled -> - fprintf ppf "Local allocation required but '-extension local' not enabled" let () = Location.register_error_of_exn diff --git a/lambda/translcore.mli b/lambda/translcore.mli index c4d19301f59..77981e11e57 100644 --- a/lambda/translcore.mli +++ b/lambda/translcore.mli @@ -43,12 +43,11 @@ val transl_extension_constructor: scopes:scopes -> val transl_scoped_exp : scopes:scopes -> expression -> lambda -val transl_alloc_mode : Location.t -> Types.alloc_mode -> Lambda.alloc_mode +val transl_alloc_mode : Types.alloc_mode -> Lambda.alloc_mode type error = Free_super_var | Unreachable_reached - | Local_allocs_not_enabled exception Error of Location.t * error diff --git a/lambda/translmod.ml b/lambda/translmod.ml index 9fad4f10bae..925f0e86d27 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -87,7 +87,7 @@ let rec apply_coercion loc strict restr arg = Lprim(mod_field pos,[Lvar id], loc) in let lam = - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map (apply_coercion_field loc get_field) pos_cc_list, loc) in @@ -96,8 +96,8 @@ let rec apply_coercion loc strict restr arg = let param = Ident.create_local "funarg" in let carg = apply_coercion loc Alias cc_arg (Lvar param) in apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; pc_poly_mode } -> - let poly_mode = Translcore.transl_alloc_mode pc_loc pc_poly_mode in + | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode } -> + let poly_mode = Translcore.transl_alloc_mode pc_poly_mode in Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode None | Tcoerce_alias (env, path, cc) -> let lam = transl_module_path loc env path in @@ -126,7 +126,7 @@ and apply_coercion_result loc strict funct params args cc_res = is_a_functor = true; stub = true; }; loc = loc; - mode = Alloc_heap; + mode = alloc_heap; region = true; body = apply_coercion loc Strict cc_res @@ -135,7 +135,7 @@ and apply_coercion_result loc strict funct params args cc_res = ap_func=Lvar id; ap_args=List.rev args; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -400,7 +400,7 @@ let eval_rec_bindings bindings cont = ap_func=mod_prim "init_mod"; ap_args=[loc; shape]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -429,7 +429,7 @@ let eval_rec_bindings bindings cont = ap_func=mod_prim "update_mod"; ap_args=[shape; Lvar id; rhs]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -538,7 +538,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc = stub = false; }; loc; - mode = Alloc_heap; + mode = alloc_heap; region = true; body; } @@ -569,7 +569,7 @@ and transl_module ~scopes cc rootpath mexp = ap_func=transl_module ~scopes Tcoerce_none None funct; ap_args=[transl_module ~scopes ccarg None arg]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=inlined_attribute; ap_specialised=Default_specialise; @@ -590,7 +590,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let body, size = match cc with Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map (fun id -> Lvar id) (List.rev fields), loc), List.length fields | Tcoerce_structure(pos_cc_list, id_pos_list) -> @@ -606,17 +606,17 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function in let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in let lam = - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map (fun (pos, cc) -> match cc with - Tcoerce_primitive p -> + | Tcoerce_primitive p -> + let loc = of_location ~scopes p.pc_loc in + let poly_mode = + Translcore.transl_alloc_mode p.pc_poly_mode + in Translprim.transl_primitive - (of_location ~scopes p.pc_loc) - p.pc_desc p.pc_env p.pc_type - ~poly_mode:(Translcore.transl_alloc_mode - p.pc_loc p.pc_poly_mode) - None + loc p.pc_desc p.pc_env p.pc_type ~poly_mode None | _ -> apply_coercion loc Strict cc (get_field pos)) pos_cc_list, loc) and id_pos_list = @@ -943,7 +943,8 @@ let rec more_idents = function | Tstr_class_type _ -> more_idents rem | Tstr_include{incl_mod={mod_desc = Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _)}} -> + _, _, _) + | Tmod_structure str }} -> all_idents str.str_items @ more_idents rem | Tstr_include _ -> more_idents rem | Tstr_module @@ -1036,8 +1037,8 @@ let field_of_str loc str = let ids = Array.of_list (defined_idents str.str_items) in fun (pos, cc) -> match cc with - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; pc_poly_mode } -> - let poly_mode = Translcore.transl_alloc_mode pc_loc pc_poly_mode in + | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode } -> + let poly_mode = Translcore.transl_alloc_mode pc_poly_mode in Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode None | Tcoerce_alias (env, path, cc) -> let lam = transl_module_path loc env path in @@ -1128,7 +1129,7 @@ let transl_store_structure ~scopes glob map prims aliases str = Lsequence(lam, Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map (fun id -> Lvar id) (defined_idents str.str_items), loc)), Lsequence(store_ident loc id, @@ -1160,7 +1161,7 @@ let transl_store_structure ~scopes glob map prims aliases str = Lsequence(lam, Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map field map, loc)), Lsequence(store_ident loc id, transl_store ~scopes rootpath @@ -1227,15 +1228,16 @@ let transl_store_structure ~scopes glob map prims aliases str = transl_store ~scopes rootpath (add_idents false ids subst) cont rem) - | Tstr_include{ + | Tstr_include({ incl_loc=loc; incl_mod= { mod_desc = Tmod_constraint ( ({mod_desc = Tmod_structure str} as mexp), _, _, - (Tcoerce_structure (map, _)))}; + (Tcoerce_structure _ | Tcoerce_none))} + | ({ mod_desc = Tmod_structure str} as mexp); incl_attributes; incl_type; - } -> + } as incl) -> List.iter (Translattribute.check_attribute_on_module mexp) incl_attributes; (* Shouldn't we use mod_attributes instead of incl_attributes? @@ -1262,9 +1264,17 @@ let transl_store_structure ~scopes glob map prims aliases str = loop ids args)) | _ -> assert false in + let map = + match incl.incl_mod.mod_desc with + | Tmod_constraint (_, _, _, Tcoerce_structure (map, _)) -> + map + | Tmod_structure _ + | Tmod_constraint (_, _, _, Tcoerce_none) -> + List.init (List.length ids0) (fun i -> i, Tcoerce_none) + | _ -> assert false + in Lsequence(lam, loop ids0 map) - | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in @@ -1369,8 +1379,7 @@ let transl_store_structure ~scopes glob map prims aliases str = List.fold_right (add_ident may_coerce) idlist subst and store_primitive (pos, prim) cont = - let poly_mode = - Translcore.transl_alloc_mode prim.pc_loc prim.pc_poly_mode in + let poly_mode = Translcore.transl_alloc_mode prim.pc_poly_mode in Lsequence(Lprim(mod_setfield pos, [Lprim(Pgetglobal glob, [], Loc_unknown); Translprim.transl_primitive Loc_unknown @@ -1508,7 +1517,7 @@ let toploop_getvalue id = ap_args=[Lconst(Const_base( Const_string (toplevel_name id, Location.none, None)))]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -1526,7 +1535,7 @@ let toploop_setvalue id lam = Const_string(toplevel_name id, Location.none, None))); lam]; ap_region_close=Rc_normal; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -1688,13 +1697,13 @@ let transl_package_flambda component_names coercion = in size, apply_coercion Loc_unknown Strict coercion - (Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + (Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map get_component component_names, Loc_unknown)) let transl_package component_names target_name coercion = let components = - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map get_component component_names, Loc_unknown) in Lprim(Psetglobal target_name, [apply_coercion Loc_unknown Strict coercion components], @@ -1732,7 +1741,7 @@ let transl_store_package component_names target_name coercion = 0 component_names) | Tcoerce_structure (pos_cc_list, _id_pos_list) -> let components = - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), List.map get_component component_names, Loc_unknown) in diff --git a/lambda/translobj.ml b/lambda/translobj.ml index a272deda8da..0e494ab691d 100644 --- a/lambda/translobj.ml +++ b/lambda/translobj.ml @@ -182,7 +182,7 @@ let oo_wrap env req f x = List.fold_left (fun lambda id -> let cl = - Lprim(Pmakeblock(0, Mutable, None, Alloc_heap), + Lprim(Pmakeblock(0, Mutable, None, alloc_heap), [lambda_unit; lambda_unit; lambda_unit], Loc_unknown) in diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 6b85cdbf84a..88d73efc23b 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -110,8 +110,8 @@ let prim_sys_argv = Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true let to_alloc_mode ~poly = function - | Prim_global, _ -> Alloc_heap - | Prim_local, _ -> Alloc_local + | Prim_global, _ -> alloc_heap + | Prim_local, _ -> alloc_local | Prim_poly, _ -> poly let lookup_primitive loc poly pos p = @@ -137,8 +137,7 @@ let lookup_primitive loc poly pos p = | "%setfield0" -> let mode = match arg_modes with - | Alloc_heap :: _ -> Assignment - | Alloc_local :: _ -> Local_assignment + | mode :: _ -> Assignment mode | [] -> assert false in Primitive ((Psetfield(0, Pointer, mode)), 2) @@ -700,13 +699,13 @@ let lambda_of_prim prim_name prim loc args arg_exps = lambda_of_loc kind loc | Loc kind, [arg] -> let lam = lambda_of_loc kind loc in - Lprim(Pmakeblock(0, Immutable, None, Alloc_heap), [lam; arg], loc) + Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [lam; arg], loc) | Send pos, [obj; meth] -> - Lsend(Public, meth, obj, [], pos, Alloc_heap, loc) + Lsend(Public, meth, obj, [], pos, alloc_heap, loc) | Send_self pos, [obj; meth] -> - Lsend(Self, meth, obj, [], pos, Alloc_heap, loc) + Lsend(Self, meth, obj, [], pos, alloc_heap, loc) | Send_cache apos, [obj; meth; cache; pos] -> - Lsend(Cached, meth, obj, [cache; pos], apos, Alloc_heap, loc) + Lsend(Cached, meth, obj, [cache; pos], apos, alloc_heap, loc) | (Raise _ | Raise_with_backtrace | Lazy_force _ | Loc _ | Primitive _ | Sys_argv | Comparison _ | Send _ | Send_self _ | Send_cache _), _ -> @@ -715,8 +714,8 @@ let lambda_of_prim prim_name prim loc args arg_exps = let check_primitive_arity loc p = let mode = match p.prim_native_repr_res with - | Prim_global, _ | Prim_poly, _ -> Alloc_heap - | Prim_local, _ -> Alloc_local + | Prim_global, _ | Prim_poly, _ -> alloc_heap + | Prim_local, _ -> alloc_local in let prim = lookup_primitive loc mode Rc_normal p in let ok = @@ -753,15 +752,15 @@ let transl_primitive loc p env ty ~poly_mode path = in let params = make_params p.prim_arity in let args = List.map (fun (id, _) -> Lvar id) params in - let loc = - Debuginfo.Scoped_location.map_scopes (fun ~scopes -> - Debuginfo.Scoped_location.enter_partial_or_eta_wrapper ~scopes) - loc - in - let body = lambda_of_prim p.prim_name prim loc args None in match params with - | [] -> body + | [] -> lambda_of_prim p.prim_name prim loc args None | _ -> + let loc = + Debuginfo.Scoped_location.map_scopes (fun ~scopes -> + Debuginfo.Scoped_location.enter_partial_or_eta_wrapper ~scopes) + loc + in + let body = lambda_of_prim p.prim_name prim loc args None in let to_alloc_mode m = to_alloc_mode ~poly:poly_mode m in let arg_modes = List.map to_alloc_mode p.prim_native_repr_args in let region = @@ -783,7 +782,7 @@ let transl_primitive loc p env ty ~poly_mode path = attr = default_stub_attribute; loc; body; - mode = Alloc_heap; + mode = alloc_heap; region } in Lambda.check_lfunction lfunc; diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 01b04e99aad..0df955a23eb 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -142,7 +142,7 @@ let prim_size prim args = | Psetfield(_f, isptr, init) -> begin match init with | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment | Local_assignment | Heap_initialization -> + | Assignment _ | Heap_initialization -> match isptr with | Pointer -> 4 | Immediate -> 1 @@ -1046,13 +1046,16 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = assert (nparams >= nlocal); let heap_params = nparams - nlocal in if nargs <= heap_params then - Alloc_heap, Curried {nlocal} + alloc_heap, Curried {nlocal} else let supplied_local_args = nargs - heap_params in - Alloc_local, Curried {nlocal = nlocal - supplied_local_args} + alloc_local, Curried {nlocal = nlocal - supplied_local_args} + in + if Lambda.is_local_mode clos_mode then + assert (Lambda.is_local_mode new_clos_mode); + let ret_mode = + if fundesc.fun_region then alloc_heap else alloc_local in - if clos_mode = Alloc_local then assert (new_clos_mode = Alloc_local); - let ret_mode = if fundesc.fun_region then Alloc_heap else Alloc_local in let (new_fun, approx) = close { backend; fenv; cenv; mutable_vars } (Lfunction{ kind; @@ -1092,7 +1095,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = let dbg = Debuginfo.from_location loc in warning_if_forced_inlined ~loc ~attribute "Over-application"; fail_if_probe ~probe "Over-application"; - let mode' = if fundesc.fun_region then Alloc_heap else Alloc_local in + let mode' = if fundesc.fun_region then alloc_heap else alloc_local in let body = Ugeneric_apply(direct_apply env ~loc ~attribute fundesc ufunct first_args @@ -1214,7 +1217,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = ap_func=funct; ap_args=[arg]; ap_region_close=pos; - ap_mode=Alloc_heap; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; @@ -1643,7 +1646,7 @@ let intro ~backend ~size lam = reset (); let id = Compilenv.make_symbol None in global_approx := Array.init size (fun i -> Value_global_field (id, i)); - Compilenv.set_global_approx(Value_tuple (Alloc_heap, !global_approx)); + Compilenv.set_global_approx(Value_tuple (alloc_heap, !global_approx)); let (ulam, _approx) = close { backend; fenv = V.Map.empty; cenv = V.Map.empty; mutable_vars = V.Set.empty } lam @@ -1654,6 +1657,7 @@ let intro ~backend ~size lam = in if opaque then Compilenv.set_global_approx(Value_unknown) - else collect_exported_structured_constants (Value_tuple (Alloc_heap, !global_approx)); + else collect_exported_structured_constants + (Value_tuple (alloc_heap, !global_approx)); global_approx := [||]; ulam diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 564ea7560d1..1bb9a995099 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -109,13 +109,13 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pbigarrayset (safe, dims, kind, layout) -> Pbigarrayset (safe, dims, kind, layout) | Pstring_load_16 is_unsafe -> - Pstring_load (Sixteen, convert_unsafety is_unsafe, Alloc_heap) + Pstring_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) | Pstring_load_32 (is_unsafe,m) -> Pstring_load (Thirty_two, convert_unsafety is_unsafe, m) | Pstring_load_64 (is_unsafe, m) -> Pstring_load (Sixty_four, convert_unsafety is_unsafe, m) | Pbytes_load_16 is_unsafe -> - Pbytes_load (Sixteen, convert_unsafety is_unsafe, Alloc_heap) + Pbytes_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) | Pbytes_load_32 (is_unsafe, m) -> Pbytes_load (Thirty_two, convert_unsafety is_unsafe, m) | Pbytes_load_64 (is_unsafe, m) -> @@ -127,7 +127,7 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pbytes_set_64 is_unsafe -> Pbytes_set (Sixty_four, convert_unsafety is_unsafe) | Pbigstring_load_16 is_unsafe -> - Pbigstring_load (Sixteen, convert_unsafety is_unsafe, Alloc_heap) + Pbigstring_load (Sixteen, convert_unsafety is_unsafe, Lambda.alloc_heap) | Pbigstring_load_32 (is_unsafe, m) -> Pbigstring_load (Thirty_two, convert_unsafety is_unsafe, m) | Pbigstring_load_64 (is_unsafe, m) -> diff --git a/middle_end/flambda/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml index 5485fa508c6..3473cf89173 100644 --- a/middle_end/flambda/augment_specialised_args.ml +++ b/middle_end/flambda/augment_specialised_args.ml @@ -452,7 +452,7 @@ module Make (T : S) = struct new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming in let mode = - if function_decl.region then Lambda.Alloc_heap else Lambda.Alloc_local in + if function_decl.region then Lambda.alloc_heap else Lambda.alloc_local in (* New definitions that project from existing specialised args need to be rewritten to use the corresponding specialised args of the wrapper. Definitions that are just equality to existing diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 9c1ab00da10..6f6c89b834c 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -88,7 +88,7 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var kind = Direct (Closure_id.wrap unboxed_version); dbg = Debuginfo.none; reg_close = Rc_normal; - mode = if region then Alloc_heap else Alloc_local; + mode = if region then Lambda.alloc_heap else Lambda.alloc_local; inlined = Default_inlined; specialise = Default_specialise; probe = None; @@ -103,7 +103,7 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var (0, call) params in (* Tupled functions are always Alloc_heap. See translcore.ml *) - let alloc_mode = Lambda.Alloc_heap in + let alloc_mode = Lambda.alloc_heap in let tuple_param = Parameter.wrap tuple_param_var alloc_mode in Flambda.create_function_declaration ~params:[tuple_param] ~alloc_mode ~region ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline @@ -430,7 +430,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = { ap_func = funct; ap_args = [arg]; ap_region_close = pos; - ap_mode = Alloc_heap; + ap_mode = Lambda.alloc_heap; ap_loc = loc; (* CR-someday lwhite: it would be nice to be able to give application attributes to functions applied with the application @@ -621,8 +621,8 @@ and close_functions t external_env function_declarations : Flambda.named = Misc.fatal_error "Closure_conversion: Tupled Alloc_local function found" in let params = List.mapi (fun i v -> - let alloc_mode : Lambda.alloc_mode = - if i < nheap then Alloc_heap else Alloc_local in + let alloc_mode = + if i < nheap then Lambda.alloc_heap else Lambda.alloc_local in Parameter.wrap v alloc_mode) param_vars in let closure_bound_var = Function_decl.closure_bound_var decl in diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 644c7133334..db9693f59ad 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -96,8 +96,7 @@ let check_closure t ulam named : Clambda.ulambda = let clambda_arity (func : Flambda.function_declaration) : Clambda.arity = let nlocal = func.params - |> List.filter (fun p -> - Lambda.eq_mode Alloc_local (Parameter.alloc_mode p)) + |> List.filter (fun p -> Lambda.is_local_mode (Parameter.alloc_mode p)) |> List.length in Curried {nlocal}, Flambda_utils.function_arity func @@ -623,7 +622,7 @@ and to_clambda_closed_set_of_closures t env symbol body; dbg = function_decl.dbg; env = None; - mode = Alloc_heap; + mode = Lambda.alloc_heap; } in let ufunct = List.map to_clambda_function functions in diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml index 2076a2599b5..e594e42bb32 100644 --- a/middle_end/flambda/inline_and_simplify.ml +++ b/middle_end/flambda/inline_and_simplify.ml @@ -890,8 +890,9 @@ and simplify_over_application env r ~args ~args_approxs ~function_decls let full_app_approxs, _ = Misc.Stdlib.List.split_at arity args_approxs in - let mode' : Lambda.alloc_mode = - if function_decl.A.region then Alloc_heap else Alloc_local in + let mode' = + if function_decl.A.region then Lambda.alloc_heap else Lambda.alloc_local + in let expr, r = simplify_full_application env r ~function_decls ~lhs_of_application ~closure_id_being_applied ~function_decl ~value_set_of_closures diff --git a/middle_end/flambda/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml index 239cc6963e9..c879f4b05f1 100644 --- a/middle_end/flambda/inlining_cost.ml +++ b/middle_end/flambda/inlining_cost.ml @@ -26,7 +26,7 @@ let prim_size (prim : Clambda_primitives.primitive) args = | Psetfield (_, isptr, init) -> begin match init with | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment | Local_assignment | Heap_initialization -> + | Assignment _ | Heap_initialization -> match isptr with | Pointer -> 4 | Immediate -> 1 diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml index 54e26279be4..3d8ed182581 100644 --- a/middle_end/flambda/lift_let_to_initialize_symbol.ml +++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml @@ -129,7 +129,8 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets Flambda_utils.toplevel_substitution def_substitution (Let_rec (renamed_defs, Flambda_utils.name_expr ~name - (Prim (Pmakeblock (0, Immutable, None, Alloc_heap), + (Prim (Pmakeblock (0, Immutable, None, + Lambda.alloc_heap), List.map fst renamed_defs, Debuginfo.none)))) in diff --git a/middle_end/flambda/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml index 256c413e422..f0542e36664 100644 --- a/middle_end/flambda/remove_unused_arguments.ml +++ b/middle_end/flambda/remove_unused_arguments.ml @@ -95,7 +95,7 @@ let make_stub unused var (fun_decl : Flambda.function_declaration) kind; dbg = fun_decl.dbg; reg_close = Rc_normal; - mode = if fun_decl.region then Alloc_heap else Alloc_local; + mode = if fun_decl.region then Lambda.alloc_heap else Lambda.alloc_local; inlined = Default_inlined; specialise = Default_specialise; probe = None; diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml index baea2de9828..4106672000a 100644 --- a/middle_end/printclambda_primitives.ml +++ b/middle_end/printclambda_primitives.ml @@ -84,8 +84,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) = match init with | Heap_initialization -> "(heap-init)" | Root_initialization -> "(root-init)" - | Assignment -> "" - | Local_assignment -> "(local)" + | Assignment Alloc_heap -> "" + | Assignment Alloc_local -> "(local)" in fprintf ppf "setfield_%s%s %i" instr init n | Psetfield_computed (ptr, init) -> @@ -98,8 +98,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) = match init with | Heap_initialization -> "(heap-init)" | Root_initialization -> "(root-init)" - | Assignment -> "" - | Local_assignment -> "(local)" + | Assignment Alloc_heap -> "" + | Assignment Alloc_local -> "(local)" in fprintf ppf "setfield_%s%s_computed" instr init | Pfloatfield (n, Alloc_heap) -> fprintf ppf "floatfield %i" n @@ -109,8 +109,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) = match init with | Heap_initialization -> "(heap-init)" | Root_initialization -> "(root-init)" - | Assignment -> "" - | Local_assignment -> "(local)" + | Assignment Alloc_heap -> "" + | Assignment Alloc_local -> "(local)" in fprintf ppf "setfloatfield%s %i" init n | Pduprecord (rep, size) -> @@ -178,7 +178,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Pisint -> fprintf ppf "isint" | Pisout -> fprintf ppf "isout" | Pbintofint (bi,m) -> print_boxed_integer "of_int" ppf bi m - | Pintofbint bi -> print_boxed_integer "to_int" ppf bi Alloc_heap + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi alloc_heap | Pcvtbint (bi1, bi2, m) -> fprintf ppf "%s_of_%s%s" (boxed_integer_name bi2) (boxed_integer_name bi1) (alloc_kind m) @@ -200,12 +200,12 @@ let primitive ppf (prim:Clambda_primitives.primitive) = | Plslbint (bi,m) -> print_boxed_integer "lsl" ppf bi m | Plsrbint (bi,m) -> print_boxed_integer "lsr" ppf bi m | Pasrbint (bi,m) -> print_boxed_integer "asr" ppf bi m - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi Alloc_heap - | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi Alloc_heap - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi Alloc_heap - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi Alloc_heap - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi Alloc_heap - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi Alloc_heap + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi alloc_heap + | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi alloc_heap + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi alloc_heap + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi alloc_heap + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi alloc_heap + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi alloc_heap | Pbigarrayref(unsafe, _n, kind, layout) -> Printlambda.print_bigarray "get" unsafe kind ppf layout | Pbigarrayset(unsafe, _n, kind, layout) -> diff --git a/ocamltest/Makefile b/ocamltest/Makefile index 3dd80560bd4..dc614d0eb6e 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -293,6 +293,7 @@ ocamltest_config.ml: ocamltest_config.ml.in Makefile ../Makefile.config $(call SUBST,FUNCTION_SECTIONS) \ $(call SUBST,NAKED_POINTERS) \ $(call SUBST,PROBES) \ + $(call SUBST,STACK_ALLOCATION) \ $< > $@ # Manual diff --git a/ocamltest/ocaml_actions.ml b/ocamltest/ocaml_actions.ml index 378ef25ecb9..6551068ce0a 100644 --- a/ocamltest/ocaml_actions.ml +++ b/ocamltest/ocaml_actions.ml @@ -1190,6 +1190,18 @@ let no_afl_instrument = Actions.make "AFL instrumentation disabled" "AFL instrumentation enabled") +let stack_allocation = Actions.make + "stack-allocation" + (Actions_helpers.pass_or_skip Ocamltest_config.stack_allocation + "Stack allocation enabled" + "Stack allocation disabled") + +let no_stack_allocation = Actions.make + "no-stack-allocation" + (Actions_helpers.pass_or_skip (not Ocamltest_config.stack_allocation) + "Stack allocation disabled" + "Stack allocation enabled") + let ocamldoc = Ocaml_tools.ocamldoc let ocamldoc_output_file env prefix = @@ -1384,6 +1396,8 @@ let _ = windows_unicode; afl_instrument; no_afl_instrument; + stack_allocation; + no_stack_allocation; setup_ocamldoc_build_env; run_ocamldoc; check_ocamldoc_output; diff --git a/ocamltest/ocamltest_config.ml.in b/ocamltest/ocamltest_config.ml.in index 808ee2e624b..bf16b5d36b6 100644 --- a/ocamltest/ocamltest_config.ml.in +++ b/ocamltest/ocamltest_config.ml.in @@ -88,3 +88,5 @@ let has_instrumented_runtime = %%RUNTIMEI%% let naked_pointers = %%NAKED_POINTERS%% let probes = %%PROBES%% + +let stack_allocation = %%STACK_ALLOCATION%% diff --git a/ocamltest/ocamltest_config.mli b/ocamltest/ocamltest_config.mli index 625dfda7aee..4a5bfaa3c6c 100644 --- a/ocamltest/ocamltest_config.mli +++ b/ocamltest/ocamltest_config.mli @@ -124,3 +124,6 @@ val naked_pointers : bool val probes : bool (** Whether the target supports tracing probes *) + +val stack_allocation : bool +(** Whether stack allocation is enabled *) diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 3f8c296b3bc..e0f907cf044 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -103,9 +103,6 @@ let keyword_table = let lookup_keyword name = match Hashtbl.find keyword_table name with - | LOCAL | NONLOCAL | GLOBAL - when not (Clflags.Extension.is_enabled Local) -> - LIDENT name | kw -> kw | exception Not_found -> LIDENT name diff --git a/runtime/caml/m.h.in b/runtime/caml/m.h.in index 1c3dee1779d..155e9355a05 100644 --- a/runtime/caml/m.h.in +++ b/runtime/caml/m.h.in @@ -99,3 +99,5 @@ #undef SUPPORTS_ALIGNED_ATTRIBUTE #undef SUPPORTS_TREE_VECTORIZE + +#undef STACK_ALLOCATION diff --git a/runtime/memory.c b/runtime/memory.c index ca09297abf9..ee4ef00b52c 100644 --- a/runtime/memory.c +++ b/runtime/memory.c @@ -771,7 +771,7 @@ void caml_local_realloc() CAMLexport value caml_alloc_local(mlsize_t wosize, tag_t tag) { -#ifdef NATIVE_CODE +#if defined(NATIVE_CODE) && defined(STACK_ALLOCATION) intnat sp = Caml_state->local_sp; header_t* hp; sp -= Bhsize_wosize(wosize); diff --git a/runtime/roots_nat.c b/runtime/roots_nat.c index b7a24adc76e..8618d435d12 100644 --- a/runtime/roots_nat.c +++ b/runtime/roots_nat.c @@ -522,7 +522,7 @@ static void do_local_allocations(caml_local_arenas* loc, if (marked_local) { int ix = get_local_ix(loc, *p); struct caml_local_arena a = loc->arenas[ix]; - intnat newsp = (char*)p - (a.base + a.length); + intnat newsp = (char*)*p - (a.base + a.length); if (sp <= newsp) { /* forwards pointer, common case */ CAMLassert(ix <= arena_ix); diff --git a/testsuite/tests/translprim/array_spec.compilers.flat.reference b/testsuite/tests/translprim/array_spec.compilers.flat.reference index 98477a22ae1..acc4d00c943 100644 --- a/testsuite/tests/translprim/array_spec.compilers.flat.reference +++ b/testsuite/tests/translprim/array_spec.compilers.flat.reference @@ -13,11 +13,11 @@ (function a[genarray] (array.unsafe_get[gen] a 0)) (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.) (array.set[addr] addr_a 0 "a") - (function a[genarray][->L] x[->L] : int (array.set[gen] a 0 x)) + (function a[genarray] x : int (array.set[gen] a 0 x)) (array.unsafe_set[int] int_a 0 1) (array.unsafe_set[float] float_a 0 1.) (array.unsafe_set[addr] addr_a 0 "a") - (function a[genarray][->L] x[->L] : int (array.unsafe_set[gen] a 0 x)) + (function a[genarray] x : int (array.unsafe_set[gen] a 0 x)) (let (eta_gen_len = (function prim stub (array.length[gen] prim)) eta_gen_safe_get = diff --git a/testsuite/tests/translprim/array_spec.ml b/testsuite/tests/translprim/array_spec.ml index 5b8e64486ac..6d0c1e49f85 100644 --- a/testsuite/tests/translprim/array_spec.ml +++ b/testsuite/tests/translprim/array_spec.ml @@ -1,7 +1,7 @@ (* TEST * setup-ocamlc.byte-build-env ** ocamlc.byte - flags = "-dlambda -dno-unique-ids -extension local" + flags = "-dlambda -dno-unique-ids" *** flat-float-array **** check-ocamlc.byte-output compiler_reference = diff --git a/testsuite/tests/translprim/comparison_table.compilers.reference b/testsuite/tests/translprim/comparison_table.compilers.reference index 8f9a2cfb969..94d22f490e3 100644 --- a/testsuite/tests/translprim/comparison_table.compilers.reference +++ b/testsuite/tests/translprim/comparison_table.compilers.reference @@ -158,7 +158,7 @@ (function f param[0: *, *] (apply f (field 0 param) (field 1 param))) map = - (function f[->L] l[->L] + (function f l (apply (field 18 (global Stdlib__List!)) (apply uncurry f) l))) (makeblock 0 ([0: *, *],*) (makeblock 0 (apply map gen_cmp vec) (apply map cmp vec)) @@ -197,7 +197,7 @@ (function f param[0: *, *] (apply f (field 0 param) (field 1 param))) map = - (function f[->L] l[->L] + (function f l (apply (field 18 (global Stdlib__List!)) (apply uncurry f) l))) (makeblock 0 ([0: *, *],*) diff --git a/testsuite/tests/translprim/comparison_table.ml b/testsuite/tests/translprim/comparison_table.ml index 88add3b9397..1a91430681e 100644 --- a/testsuite/tests/translprim/comparison_table.ml +++ b/testsuite/tests/translprim/comparison_table.ml @@ -1,7 +1,7 @@ (* TEST * setup-ocamlc.byte-build-env ** ocamlc.byte - flags = "-dlambda -dno-unique-ids -extension local" + flags = "-dlambda -dno-unique-ids" *** check-ocamlc.byte-output *) diff --git a/testsuite/tests/translprim/locs.reference b/testsuite/tests/translprim/locs.reference index 91b2c9840d7..1126c6541c7 100644 --- a/testsuite/tests/translprim/locs.reference +++ b/testsuite/tests/translprim/locs.reference @@ -9,34 +9,34 @@ an expression another expression locs.ml, 40, 14, 49 yet another expression -Locs.local_no_arg.(partial) -Locs.fn_multi.(partial) -Locs.fn_function.(partial) -Locs.fn_poly.(partial) -Locs.Mod1.Nested.apply.(partial) -Locs.anon.(partial) -Locs.anon.(partial) -Locs.anon.(fun).(partial) -Locs.double_anon.(partial) -Locs.double_anon.(fun).(partial) -Locs.double_anon.(fun).(partial) -Locs.local.(partial) -Locs.local.inner.(partial) -Locs.double_local.(partial) -Locs.double_local.inner1.(partial) -Locs.double_local.inner1.inner2.(partial) -Locs.local_no_arg.(fun).(partial) -Locs.local_no_arg.inner.(partial) -Locs.curried.(partial) -Locs.curried.inner.(partial) -Locs.local_module.(partial) -Locs.local_module.N.r.(partial) -Locs.local_module.N.foo.(partial) -Locs.Functor.fn.(partial) -Locs.Rec1.fn.(partial) -Locs.Rec2.fn.(partial) -Locs.(+@+).(partial) -Locs.klass#meth.(partial) -Locs.inline_object.object#meth.(partial) -Locs.inline_object.object#othermeth.(partial) -Locs.bang.(partial) +Locs.local_no_arg +Locs.fn_multi +Locs.fn_function +Locs.fn_poly +Locs.Mod1.Nested.apply +Locs.anon +Locs.anon +Locs.anon.(fun) +Locs.double_anon +Locs.double_anon.(fun) +Locs.double_anon.(fun) +Locs.local +Locs.local.inner +Locs.double_local +Locs.double_local.inner1 +Locs.double_local.inner1.inner2 +Locs.local_no_arg.(fun) +Locs.local_no_arg.inner +Locs.curried +Locs.curried.inner +Locs.local_module +Locs.local_module.N.r +Locs.local_module.N.foo +Locs.Functor.fn +Locs.Rec1.fn +Locs.Rec2.fn +Locs.(+@+) +Locs.klass#meth +Locs.inline_object.object#meth +Locs.inline_object.object#othermeth +Locs.bang diff --git a/testsuite/tests/translprim/ref_spec.compilers.reference b/testsuite/tests/translprim/ref_spec.compilers.reference index 5fda828ba77..39f9a5d34e9 100644 --- a/testsuite/tests/translprim/ref_spec.compilers.reference +++ b/testsuite/tests/translprim/ref_spec.compilers.reference @@ -24,20 +24,13 @@ (setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0) (setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.) (let - (set_open_poly = - (function r[->L] y[->L] : int (setfield_ptr 0 r y)) - set_open_poly = - (function r[->L] y[->L] : int (setfield_imm 0 r y)) - set_open_poly = - (function r[->L] y[->L] : int (setfield_imm 0 r y)) - set_open_poly = - (function r[->L] y[->L] : int (setfield_imm 0 r y)) - set_open_poly = - (function r[->L] y[->L] : int (setfield_ptr 0 r y)) - set_open_poly = - (function r[->L] y[->L] : int (setfield_ptr 0 r y)) - set_open_poly = - (function r[->L] y[->L] : int (setfield_ptr 0 r y)) + (set_open_poly = (function r y : int (setfield_ptr 0 r y)) + set_open_poly = (function r y : int (setfield_imm 0 r y)) + set_open_poly = (function r y : int (setfield_imm 0 r y)) + set_open_poly = (function r y : int (setfield_imm 0 r y)) + set_open_poly = (function r y : int (setfield_ptr 0 r y)) + set_open_poly = (function r y : int (setfield_ptr 0 r y)) + set_open_poly = (function r y : int (setfield_ptr 0 r y)) set_open_poly = (function r y : int (setfield_ptr 0 r y))) (makeblock 0 int_ref var_ref vargen_ref cst_ref gen_ref flt_ref int_rec var_rec vargen_rec cst_rec gen_rec flt_rec flt_rec' diff --git a/testsuite/tests/translprim/ref_spec.ml b/testsuite/tests/translprim/ref_spec.ml index 9f01fcac11b..82cbd1eeef3 100644 --- a/testsuite/tests/translprim/ref_spec.ml +++ b/testsuite/tests/translprim/ref_spec.ml @@ -1,7 +1,7 @@ (* TEST * setup-ocamlc.byte-build-env ** ocamlc.byte - flags = "-dlambda -dno-unique-ids -extension local" + flags = "-dlambda -dno-unique-ids" *** check-ocamlc.byte-output *) diff --git a/testsuite/tests/typing-local/alloc.heap.reference b/testsuite/tests/typing-local/alloc.heap.reference new file mode 100644 index 00000000000..b8624ebc8fc --- /dev/null +++ b/testsuite/tests/typing-local/alloc.heap.reference @@ -0,0 +1,34 @@ + small: Allocation + dupsmall: Allocation + big: Allocation + dupbig: Allocation + float: Allocation + projfloat: Allocation + dupfloat: Allocation + polyvariant: Allocation + extension: Allocation + arith32: Allocation + arithfloat: Allocation + closure: Allocation + currylocal1: Allocation + currylocal2: Allocation + currylocal3: Allocation + partprim1: Allocation + partprim2: Allocation + intarray: Allocation + addrarray: Allocation + floatarray: Allocation + flatfloatarray: Allocation + shortarray: Allocation + longarray: Allocation + floatgenarray: Allocation + longfgarray: Allocation + maniparray: Allocation + manipfarray: Allocation + ref: Allocation + bytes: Allocation + stringbint: Allocation + bigstringbint: Allocation + verylong: Allocation + manylong: Allocation + optionalarg: Allocation diff --git a/testsuite/tests/typing-local/alloc.ml b/testsuite/tests/typing-local/alloc.ml index ec3baa6d8ab..9106f0b9ee7 100644 --- a/testsuite/tests/typing-local/alloc.ml +++ b/testsuite/tests/typing-local/alloc.ml @@ -1,5 +1,13 @@ (* TEST - flags += "-extension local" *) + * bytecode + reference = "${test_source_directory}/alloc.heap.reference" + * stack-allocation + ** native + reference = "${test_source_directory}/alloc.stack.reference" + * no-stack-allocation + ** native + reference = "${test_source_directory}/alloc.heap.reference" + *) type t = int @@ -395,6 +403,14 @@ let makeverylong n = ignore_local (local_array 100_000 n); () +let fun_with_optional_arg ?(local_ foo = 5) () = + let _ = foo + 5 in + () + +let optionalarg ((f : ?foo:local_ int -> unit -> unit), n) = + let () = f ~foo:n () in + () + let run name f x = let prebefore = Gc.allocated_bytes () in let before = Gc.allocated_bytes () in @@ -406,9 +422,8 @@ let run name f x = in let msg = match delta with - | 0 -> "OK" - | _ when Sys.backend_type <> Sys.Native -> "OK" - | n -> Printf.sprintf "%d words allocated" n + | 0 -> "No Allocation" + | n -> "Allocation" in Printf.printf "%15s: %s\n" name msg; r @@ -446,7 +461,8 @@ let () = run "stringbint" readstringbint (); run "bigstringbint" readbigstringbint (); run "verylong" makeverylong 42; - run "manylong" makemanylong 100 + run "manylong" makemanylong 100; + run "optionalarg" optionalarg (fun_with_optional_arg, 10) (* In debug mode, Gc.minor () checks for minor heap->local pointers *) diff --git a/testsuite/tests/typing-local/alloc.reference b/testsuite/tests/typing-local/alloc.reference deleted file mode 100644 index 9334bbb3a82..00000000000 --- a/testsuite/tests/typing-local/alloc.reference +++ /dev/null @@ -1,33 +0,0 @@ - small: OK - dupsmall: OK - big: OK - dupbig: OK - float: OK - projfloat: OK - dupfloat: OK - polyvariant: OK - extension: OK - arith32: OK - arithfloat: OK - closure: OK - currylocal1: OK - currylocal2: OK - currylocal3: OK - partprim1: OK - partprim2: OK - intarray: OK - addrarray: OK - floatarray: OK - flatfloatarray: OK - shortarray: OK - longarray: OK - floatgenarray: OK - longfgarray: OK - maniparray: OK - manipfarray: OK - ref: OK - bytes: OK - stringbint: OK - bigstringbint: OK - verylong: OK - manylong: OK diff --git a/testsuite/tests/typing-local/alloc.stack.reference b/testsuite/tests/typing-local/alloc.stack.reference new file mode 100644 index 00000000000..26bf054a4f6 --- /dev/null +++ b/testsuite/tests/typing-local/alloc.stack.reference @@ -0,0 +1,34 @@ + small: No Allocation + dupsmall: No Allocation + big: No Allocation + dupbig: No Allocation + float: No Allocation + projfloat: No Allocation + dupfloat: No Allocation + polyvariant: No Allocation + extension: No Allocation + arith32: No Allocation + arithfloat: No Allocation + closure: No Allocation + currylocal1: No Allocation + currylocal2: No Allocation + currylocal3: No Allocation + partprim1: No Allocation + partprim2: No Allocation + intarray: No Allocation + addrarray: No Allocation + floatarray: No Allocation + flatfloatarray: No Allocation + shortarray: No Allocation + longarray: No Allocation + floatgenarray: No Allocation + longfgarray: No Allocation + maniparray: No Allocation + manipfarray: No Allocation + ref: No Allocation + bytes: No Allocation + stringbint: No Allocation + bigstringbint: No Allocation + verylong: No Allocation + manylong: No Allocation + optionalarg: No Allocation diff --git a/testsuite/tests/typing-local/aritybug.ml b/testsuite/tests/typing-local/aritybug.ml index 94e8e740ce1..484af3412f1 100644 --- a/testsuite/tests/typing-local/aritybug.ml +++ b/testsuite/tests/typing-local/aritybug.ml @@ -1,5 +1,4 @@ -(* TEST - flags += "-extension local" *) +(* TEST *) let[@inline never] wat x = let f ~a:_ ~b:_ ~c:_ () () = x in diff --git a/testsuite/tests/typing-local/comballoc.ml b/testsuite/tests/typing-local/comballoc.ml index 1483a52173e..c77f7df165d 100644 --- a/testsuite/tests/typing-local/comballoc.ml +++ b/testsuite/tests/typing-local/comballoc.ml @@ -1,5 +1,4 @@ -(* TEST - flags += "-extension local" *) +(* TEST *) let glob = ref [] let[@inline never] f g n = diff --git a/testsuite/tests/typing-local/curry.byte.reference b/testsuite/tests/typing-local/curry.heap.reference similarity index 100% rename from testsuite/tests/typing-local/curry.byte.reference rename to testsuite/tests/typing-local/curry.heap.reference diff --git a/testsuite/tests/typing-local/curry.ml b/testsuite/tests/typing-local/curry.ml index fb45373880f..5bc92596de7 100644 --- a/testsuite/tests/typing-local/curry.ml +++ b/testsuite/tests/typing-local/curry.ml @@ -1,9 +1,14 @@ (* TEST - flags += "-extension local" * bytecode - reference = "${test_source_directory}/curry.byte.reference" - * native - reference = "${test_source_directory}/curry.opt.reference" *) + reference = "${test_source_directory}/curry.heap.reference" + * stack-allocation + ** native + reference = "${test_source_directory}/curry.stack.reference" + * no-stack-allocation + ** native + reference = "${test_source_directory}/curry.heap.reference" + *) + module M : sig (* explicit signature to force return modes *) val part_local : int -> int -> local_ string -> int -> int -> int -> int list diff --git a/testsuite/tests/typing-local/curry.opt.reference b/testsuite/tests/typing-local/curry.stack.reference similarity index 100% rename from testsuite/tests/typing-local/curry.opt.reference rename to testsuite/tests/typing-local/curry.stack.reference diff --git a/testsuite/tests/typing-local/exceptions.ml b/testsuite/tests/typing-local/exceptions.ml index 568e67edb3c..ad68e8f283e 100644 --- a/testsuite/tests/typing-local/exceptions.ml +++ b/testsuite/tests/typing-local/exceptions.ml @@ -1,5 +1,4 @@ (* TEST - flags += "-extension local" * native *) external local_stack_offset : unit -> int = "caml_local_stack_offset" diff --git a/testsuite/tests/typing-local/lifetime.ml b/testsuite/tests/typing-local/lifetime.ml index 1d4bd6ad511..a30b413f862 100644 --- a/testsuite/tests/typing-local/lifetime.ml +++ b/testsuite/tests/typing-local/lifetime.ml @@ -1,5 +1,4 @@ -(* TEST - flags += "-extension local" *) +(* TEST *) let final = ref false let rtrue = ref true diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml index 75a2e010475..c6997f3de79 100644 --- a/testsuite/tests/typing-local/local.ml +++ b/testsuite/tests/typing-local/local.ml @@ -1,5 +1,4 @@ (* TEST - flags += "-extension local" * expect *) let leak n = @@ -77,6 +76,18 @@ Error: This local value escapes its region Hint: Cannot return local value without an explicit "local_" annotation |}] +(* If both type and mode are wrong, complain about type *) +let f () = + let local_ r = ref 42 in + print_endline r +[%%expect{| +Line 3, characters 16-17: +3 | print_endline r + ^ +Error: This expression has type int ref + but an expression was expected of type string +|}] + (* * Type equalities of function types *) @@ -1864,3 +1875,265 @@ Error: This expression has type (local_ int list -> unit) -> int -> unit Type local_ int list -> unit is not compatible with type int list -> unit |}] + +(* Subtyping *) + +let foo f = (f : local_ string -> float :> string -> float) +[%%expect{| +val foo : (local_ string -> float) -> string -> float = +|}] + +let foo f = (f : string -> float :> string -> local_ float) +[%%expect{| +val foo : (string -> float) -> string -> local_ float = +|}] + +let foo f = (f : string -> local_ float :> string -> float) +[%%expect{| +Line 1, characters 12-59: +1 | let foo f = (f : string -> local_ float :> string -> float) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type string -> local_ float is not a subtype of string -> float +|}] + +let foo f = (f : string -> float :> local_ string -> local_ float) +[%%expect{| +Line 1, characters 12-66: +1 | let foo f = (f : string -> float :> local_ string -> local_ float) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type string -> float is not a subtype of local_ string -> local_ float +|}] + +let foo f = ignore (f :> string -> float); () +[%%expect{| +val foo : (string -> float) -> unit = +|}] + +let use_local_to_global (f : local_ string -> float) = () + +let foo f = ignore (f :> string -> float); use_local_to_global f +[%%expect{| +val use_local_to_global : (local_ string -> float) -> unit = +val foo : (local_ string -> float) -> unit = +|}] + +let use_global_to_local (f : string -> local_ float) = () + +let foo f = ignore (f :> string -> float); use_global_to_local f +[%%expect{| +val use_global_to_local : (string -> local_ float) -> unit = +Line 3, characters 63-64: +3 | let foo f = ignore (f :> string -> float); use_global_to_local f + ^ +Error: This expression has type string -> float + but an expression was expected of type string -> local_ float +|}] + +(* Submoding during module inclusion *) + +module F (X : sig val foo : local_ float -> string end) : sig + val foo : float -> string +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : local_ float -> string end) -> + sig val foo : float -> string end +|}] + +module F (X : sig val foo : float -> string end) : sig + val foo : float -> local_ string +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : float -> string end) -> + sig val foo : float -> local_ string end +|}] + +module F (X : sig val foo : float -> string end) : sig + val foo : local_ float -> string +end = X;; +[%%expect{| +Line 3, characters 6-7: +3 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : float -> string end + is not included in + sig val foo : local_ float -> string end + Values do not match: + val foo : float -> string + is not included in + val foo : local_ float -> string +|}] + +module F (X : sig val foo : float -> local_ string end) : sig + val foo : float -> string +end = X;; +[%%expect{| +Line 3, characters 6-7: +3 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : float -> local_ string end + is not included in + sig val foo : float -> string end + Values do not match: + val foo : float -> local_ string + is not included in + val foo : float -> string +|}] + +module F (X : sig val foo : local_ float -> float -> string end) : sig + val foo : float -> float -> string +end = X;; +[%%expect{| +Line 3, characters 6-7: +3 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : local_ float -> float -> string end + is not included in + sig val foo : float -> float -> string end + Values do not match: + val foo : local_ float -> float -> string + is not included in + val foo : float -> float -> string +|}] + +module F (X : sig val foo : local_ float -> float -> string end) : sig + val foo : float -> local_ (float -> string) +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : local_ float -> float -> string end) -> + sig val foo : float -> local_ (float -> string) end +|}] + +module F (X : sig val foo : float -> float -> string end) : sig + val foo : float -> local_ (float -> string) +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : float -> float -> string end) -> + sig val foo : float -> local_ (float -> string) end +|}] + +type 'a inv = Inv of ('a -> 'a) +type 'a co = Co of 'a +type 'a contra = Contra of ('a -> int) +type 'a bi = Bi + +module F (X : sig val foo : (float -> string) inv end) : sig + val foo : (float -> local_ string) inv +end = X;; +[%%expect{| +type 'a inv = Inv of ('a -> 'a) +type 'a co = Co of 'a +type 'a contra = Contra of ('a -> int) +type 'a bi = Bi +Line 8, characters 6-7: +8 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : (float -> string) inv end + is not included in + sig val foo : (float -> local_ string) inv end + Values do not match: + val foo : (float -> string) inv + is not included in + val foo : (float -> local_ string) inv +|}] + +module F (X : sig val foo : (float -> string) co end) : sig + val foo : (float -> local_ string) co +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : (float -> string) co end) -> + sig val foo : (float -> local_ string) co end +|}] + +module F (X : sig val foo : (float -> string) contra end) : sig + val foo : (float -> local_ string) contra +end = X;; +[%%expect{| +Line 3, characters 6-7: +3 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : (float -> string) contra end + is not included in + sig val foo : (float -> local_ string) contra end + Values do not match: + val foo : (float -> string) contra + is not included in + val foo : (float -> local_ string) contra +|}] + +module F (X : sig val foo : (float -> string) bi end) : sig + val foo : (float -> local_ string) bi +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : (float -> string) bi end) -> + sig val foo : (float -> local_ string) bi end +|}] + +module F (X : sig val foo : (float -> local_ string) inv end) : sig + val foo : (float -> string) inv +end = X;; +[%%expect{| +Line 3, characters 6-7: +3 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : (float -> local_ string) inv end + is not included in + sig val foo : (float -> string) inv end + Values do not match: + val foo : (float -> local_ string) inv + is not included in + val foo : (float -> string) inv +|}] + +module F (X : sig val foo : (float -> local_ string) co end) : sig + val foo : (float -> string) co +end = X;; +[%%expect{| +Line 3, characters 6-7: +3 | end = X;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val foo : (float -> local_ string) co end + is not included in + sig val foo : (float -> string) co end + Values do not match: + val foo : (float -> local_ string) co + is not included in + val foo : (float -> string) co +|}] + +module F (X : sig val foo : (float -> local_ string) contra end) : sig + val foo : (float -> string) contra +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : (float -> local_ string) contra end) -> + sig val foo : (float -> string) contra end +|}] + +module F (X : sig val foo : (float -> local_ string) bi end) : sig + val foo : (float -> string) bi +end = X;; +[%%expect{| +module F : + functor (X : sig val foo : (float -> local_ string) bi end) -> + sig val foo : (float -> string) bi end +|}] diff --git a/testsuite/tests/typing-local/localgcbug.ml b/testsuite/tests/typing-local/localgcbug.ml new file mode 100644 index 00000000000..0c5ba998734 --- /dev/null +++ b/testsuite/tests/typing-local/localgcbug.ml @@ -0,0 +1,19 @@ +(* TEST + * native *) + +type n = Z | S of n + +let rec gen_locals (local_ n) depth _ = local_ + if depth = 0 + then + S n + else + let s = S n in + let m = gen_locals s (depth - 1) (ref 42) in + let _ = gen_locals m (depth - 1) (ref 42) in + S n + +let () = + match gen_locals Z 21 (ref 42) with + | S Z -> print_endline "ok" + | _ -> assert false diff --git a/testsuite/tests/typing-local/localgcbug.reference b/testsuite/tests/typing-local/localgcbug.reference new file mode 100644 index 00000000000..9766475a418 --- /dev/null +++ b/testsuite/tests/typing-local/localgcbug.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/typing-local/mutate.ml b/testsuite/tests/typing-local/mutate.ml index 500393aaced..7c842d49a75 100644 --- a/testsuite/tests/typing-local/mutate.ml +++ b/testsuite/tests/typing-local/mutate.ml @@ -1,5 +1,4 @@ -(* TEST - flags += "-extension local" *) +(* TEST *) let[@inline never] f (g : local_ _ -> unit) n = let r = local_ { contents = ref 0 } in g r; diff --git a/testsuite/tests/typing-local/nosyntax.ml b/testsuite/tests/typing-local/nosyntax.ml index 66cd97742e4..1d78e5a28a0 100644 --- a/testsuite/tests/typing-local/nosyntax.ml +++ b/testsuite/tests/typing-local/nosyntax.ml @@ -1,4 +1,5 @@ (* TEST + flags += "-disable-all-extensions" * expect *) type fn = string -> int @@ -6,12 +7,12 @@ type lfn = (string[@ocaml.local]) -> int type lfn' = local_ string -> int [%%expect{| type fn = string -> int -type lfn = (string [@ocaml.local]) -> int -Line 3, characters 12-25: +type lfn = (string [@local]) -> int +Line 3, characters 19-25: 3 | type lfn' = local_ string -> int - ^^^^^^^^^^^^^ -Error: The type constructor string expects 0 argument(s), - but is here applied to 1 argument(s) + ^^^^^^ +Error: The local extension is disabled + To enable it, pass the '-extension local' flag |}] let cast (x : fn) = (x : lfn) @@ -20,16 +21,12 @@ Line 1, characters 21-22: 1 | let cast (x : fn) = (x : lfn) ^ Error: This expression has type fn = string -> int - but an expression was expected of type - lfn = (string [@ocaml.local]) -> int + but an expression was expected of type lfn = (string [@local]) -> int |}] let local_ref (f : lfn -> unit) = f (fun s -> let _ = [|s;s;s|] in 1) [%%expect{| -Line 2, characters 22-31: -2 | f (fun s -> let _ = [|s;s;s|] in 1) - ^^^^^^^^^ -Error: Local allocation required but '-extension local' not enabled +val local_ref : (lfn -> unit) -> unit = |}] diff --git a/testsuite/tests/typing-local/partial.ml b/testsuite/tests/typing-local/partial.ml index 8ffef312b37..8b7f371cda9 100644 --- a/testsuite/tests/typing-local/partial.ml +++ b/testsuite/tests/typing-local/partial.ml @@ -1,5 +1,5 @@ (* TEST - flags += " -g -extension local" *) + flags += " -g" *) let f1 ~a ~b ~c ~d ~e = a + b + c + d + e let f2 ~b ~c ~e = f1 ~b ~c ~e diff --git a/testsuite/tests/typing-local/regions.ml b/testsuite/tests/typing-local/regions.ml index 0534a48e5da..44c73f23b68 100644 --- a/testsuite/tests/typing-local/regions.ml +++ b/testsuite/tests/typing-local/regions.ml @@ -1,5 +1,4 @@ (* TEST - flags += "-extension local" * native *) external local_stack_offset : unit -> int = "caml_local_stack_offset" diff --git a/testsuite/tests/typing-local/tailcalls.ml b/testsuite/tests/typing-local/tailcalls.ml index d5cbb900f1d..5ffbf26c08b 100644 --- a/testsuite/tests/typing-local/tailcalls.ml +++ b/testsuite/tests/typing-local/tailcalls.ml @@ -1,6 +1,7 @@ (* TEST - flags += "-extension local" - * native *) + * stack-allocation + ** native + *) open Printexc diff --git a/testsuite/tests/typing-modules/struct_include_optimisation.ml b/testsuite/tests/typing-modules/struct_include_optimisation.ml new file mode 100644 index 00000000000..5d5d425c3a4 --- /dev/null +++ b/testsuite/tests/typing-modules/struct_include_optimisation.ml @@ -0,0 +1,49 @@ +(* TEST + * native *) +type alloc_count = { mutable total: float } +let allocs = Sys.opaque_identity { total = 0. } +let[@inline never] set_allocs () = + allocs.total <- Gc.minor_words () + +let[@inline never] count txt = + let now = int_of_float (Gc.minor_words () -. allocs.total) in + Printf.printf "%20s: %d\n" txt now; + set_allocs () + +let v = Sys.opaque_identity (ref 0) + +let next () = + let r = !v in incr v; r + +let () = set_allocs () + +include struct + let x = next () + let y = next () +end + +let () = count "no signature" + +include (struct + let a = next () + let b = next () +end : sig val a : int val b : int end) + +let () = count "trivial coercion" + +include (struct + let c = next () + let d = next () +end : sig val c : int end) + +let () = count "prefix coercion" + +include (struct + let c = next () + let d = next () +end : sig val d : int end) + +let () = count "reordering coercion" + +let () = + Printf.printf "%20s: %d%d%d%d%d%d\n" "outputs" x y a b c d diff --git a/testsuite/tests/typing-modules/struct_include_optimisation.reference b/testsuite/tests/typing-modules/struct_include_optimisation.reference new file mode 100644 index 00000000000..e80a4125ced --- /dev/null +++ b/testsuite/tests/typing-modules/struct_include_optimisation.reference @@ -0,0 +1,5 @@ + no signature: 0 + trivial coercion: 0 + prefix coercion: 0 + reordering coercion: 0 + outputs: 012347 diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index 7bd13f19c7b..700491c3f80 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -715,7 +715,7 @@ Error: Multiple definition of the type name t. fun x -> (x :> < m : 'a -> 'a > as 'a);; [%%expect{| -- : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = +- : < m : (< m : 'a -> 'a > as 'a) -> 'a; .. > -> 'a = |}];; fun x -> (x : int -> bool :> 'a -> 'a);; diff --git a/testsuite/tools/parsecmm.mly b/testsuite/tools/parsecmm.mly index a239b3a2e53..81982cd985d 100644 --- a/testsuite/tools/parsecmm.mly +++ b/testsuite/tools/parsecmm.mly @@ -220,7 +220,7 @@ expr: $4 :: List.rev $5, debuginfo ?loc:$3 ()) } | LPAREN EXTCALL STRING exprlist machtype RPAREN {Cop(Cextcall($3, $5, [], false), List.rev $4, debuginfo ())} - | LPAREN ALLOC exprlist RPAREN { Cop(Calloc Lambda.Alloc_heap, List.rev $3, debuginfo ()) } + | LPAREN ALLOC exprlist RPAREN { Cop(Calloc Lambda.alloc_heap, List.rev $3, debuginfo ()) } | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) } | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) } | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) } @@ -271,15 +271,15 @@ expr: Debuginfo.none) } | LPAREN ADDRASET expr expr expr RPAREN { let open Lambda in - Cop(Cstore (Word_val, Assignment), + Cop(Cstore (Word_val, Assignment Lambda.alloc_heap), [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) } | LPAREN INTASET expr expr expr RPAREN { let open Lambda in - Cop(Cstore (Word_int, Assignment), + Cop(Cstore (Word_int, Assignment Lambda.alloc_heap), [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) } | LPAREN FLOATASET expr expr expr RPAREN { let open Lambda in - Cop(Cstore (Double, Assignment), + Cop(Cstore (Double, Assignment Lambda.alloc_heap), [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) } ; exprlist: @@ -330,7 +330,7 @@ unaryop: | ABSF { Cabsf } ; binaryop: - STORE chunk { Cstore ($2, Lambda.Assignment) } + STORE chunk { Cstore ($2, Lambda.Assignment Lambda.alloc_heap) } | ADDI { Caddi } | SUBI { Csubi } | STAR { Cmuli } diff --git a/typing/btype.ml b/typing/btype.ml index 649392de0ea..657441681e5 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -1075,11 +1075,18 @@ module Alloc_mode = struct let newvar () = Amodevar (fresh ()) let newvar_below = function - | Amode Global -> Amode Global + | Amode Global -> Amode Global, false | m -> let v = newvar () in submode_exn v m; - v + v, true + + let newvar_above = function + | Amode Local -> Amode Local, false + | m -> + let v = newvar () in + submode_exn m v; + v, true let check_const = function | Amode m -> Some m diff --git a/typing/btype.mli b/typing/btype.mli index a2712d8a474..c76e0c3e544 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -290,7 +290,9 @@ module Alloc_mode : sig val newvar : unit -> t - val newvar_below : t -> t + val newvar_below : t -> t * bool + + val newvar_above : t -> t * bool val check_const : t -> const option diff --git a/typing/ctype.ml b/typing/ctype.ml index c236432d39a..941c142ea38 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -3357,16 +3357,68 @@ let moregen_occur env level ty = occur_univar env ty; update_level env level ty +type moregen_pairs = + { invariant_pairs : TypePairs.t; + covariant_pairs : TypePairs.t; + contravariant_pairs : TypePairs.t; + bivariant_pairs : TypePairs.t; } + +let fresh_moregen_pairs () = + { invariant_pairs = TypePairs.create 13; + covariant_pairs = TypePairs.create 13; + contravariant_pairs = TypePairs.create 13; + bivariant_pairs = TypePairs.create 13; } + +type moregen_variance = + | Invariant + | Covariant + | Contravariant + | Bivariant + +let neg_variance = function + | Invariant -> Invariant + | Covariant -> Contravariant + | Contravariant -> Covariant + | Bivariant -> Bivariant + +let compose_variance variance v = + match variance with + | Invariant -> Invariant + | Bivariant -> Bivariant + | Covariant | Contravariant -> + match Variance.get_upper v with + | true, true -> Invariant + | false, false -> Bivariant + | false, true -> neg_variance variance + | true, false -> variance + +let relevant_pairs pairs v = + match v with + | Invariant -> pairs.invariant_pairs + | Covariant -> pairs.covariant_pairs + | Contravariant -> pairs.contravariant_pairs + | Bivariant -> pairs.bivariant_pairs + +let moregen_alloc_mode v a1 a2 = + match + match v with + | Invariant -> Btype.Alloc_mode.equate a1 a2 + | Covariant -> Btype.Alloc_mode.submode a1 a2 + | Contravariant -> Btype.Alloc_mode.submode a2 a1 + | Bivariant -> Ok () + with + | Ok () -> () + | Error () -> raise (Unify []) + let may_instantiate inst_nongen t1 = if inst_nongen then t1.level <> generic_level - 1 else t1.level = generic_level -let rec moregen inst_nongen type_pairs env t1 t2 = +let rec moregen inst_nongen variance type_pairs env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then () else - try match (t1.desc, t2.desc) with (Tvar _, _) when may_instantiate inst_nongen t1 -> @@ -3382,8 +3434,9 @@ let rec moregen inst_nongen type_pairs env t1 t2 = (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else - if not (TypePairs.mem type_pairs (t1', t2')) then begin - TypePairs.add type_pairs (t1', t2'); + let pairs = relevant_pairs type_pairs variance in + if not (TypePairs.mem pairs (t1', t2')) then begin + TypePairs.add pairs (t1', t2'); match (t1'.desc, t2'.desc) with (Tvar _, _) when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; @@ -3391,37 +3444,47 @@ let rec moregen inst_nongen type_pairs env t1 t2 = link_type t1' t2 | (Tarrow ((l1,a1,r1), t1, u1, _), Tarrow ((l2,a2,r2), t2, u2, _)) when - (l1 = l2 + (l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2)) -> - moregen inst_nongen type_pairs env t1 t2; - moregen inst_nongen type_pairs env u1 u2; - (* FIXME *) - unify_alloc_mode a1 a2; - unify_alloc_mode r1 r2 + moregen inst_nongen (neg_variance variance) type_pairs env t1 t2; + moregen inst_nongen variance type_pairs env u1 u2; + moregen_alloc_mode (neg_variance variance) a1 a2; + moregen_alloc_mode variance r1 r2 | (Ttuple tl1, Ttuple tl2) -> - moregen_list inst_nongen type_pairs env tl1 tl2 + moregen_list inst_nongen variance type_pairs env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) - when Path.same p1 p2 -> - moregen_list inst_nongen type_pairs env tl1 tl2 + when Path.same p1 p2 -> begin + match variance with + | Invariant | Bivariant -> + moregen_list inst_nongen variance type_pairs env tl1 tl2 + | _ -> + match Env.find_type p1 env with + | decl -> + moregen_param_list inst_nongen variance type_pairs env + decl.type_variance tl1 tl2 + | exception Not_found -> + moregen_list inst_nongen Invariant type_pairs env tl1 tl2 + end | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> begin try - unify_package env (moregen_list inst_nongen type_pairs env) + unify_package env + (moregen_list inst_nongen variance type_pairs env) t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 with Not_found -> raise (Unify []) end | (Tvariant row1, Tvariant row2) -> - moregen_row inst_nongen type_pairs env row1 row2 + moregen_row inst_nongen variance type_pairs env row1 row2 | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> - moregen_fields inst_nongen type_pairs env fi1 fi2 + moregen_fields inst_nongen variance type_pairs env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) - moregen_fields inst_nongen type_pairs env t1' t2' + moregen_fields inst_nongen variance type_pairs env t1' t2' | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> - moregen inst_nongen type_pairs env t1 t2 + moregen inst_nongen variance type_pairs env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> enter_poly env univar_pairs t1 tl1 t2 tl2 - (moregen inst_nongen type_pairs env) + (moregen inst_nongen variance type_pairs env) | (Tunivar _, Tunivar _) -> unify_univar t1' t2' !univar_pairs | (_, _) -> @@ -3429,22 +3492,32 @@ let rec moregen inst_nongen type_pairs env t1 t2 = end with Unify trace -> raise( Unify ( Trace.diff t1 t2 :: trace ) ) -and moregen_list inst_nongen type_pairs env tl1 tl2 = +and moregen_list inst_nongen variance type_pairs env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise (Unify []); - List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 - -and moregen_fields inst_nongen type_pairs env ty1 ty2 = + List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2 + +and moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 = + match vl, tl1, tl2 with + | [], [], [] -> () + | v :: vl, t1 :: tl1, t2 :: tl2 -> + let param_variance = compose_variance variance v in + moregen inst_nongen param_variance type_pairs env t1 t2; + moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 + | _, _, _ -> raise (Unify []) + +and moregen_fields inst_nongen variance type_pairs env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in if miss1 <> [] then raise (Unify []); - moregen inst_nongen type_pairs env rest1 + moregen inst_nongen variance type_pairs env rest1 (build_fields (repr ty2).level miss2 rest2); List.iter (fun (n, k1, t1, k2, t2) -> moregen_kind k1 k2; - try moregen inst_nongen type_pairs env t1 t2 with Unify trace -> + try moregen inst_nongen variance type_pairs env t1 t2 + with Unify trace -> let e = Trace.diff (newty (Tfield(n, k1, t1, rest2))) (newty (Tfield(n, k2, t2, rest2))) in @@ -3461,7 +3534,7 @@ and moregen_kind k1 k2 = | (Fpresent, Fpresent) -> () | _ -> raise (Unify []) -and moregen_row inst_nongen type_pairs env row1 row2 = +and moregen_row inst_nongen variance type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let rm1 = repr row1.row_more and rm2 = repr row2.row_more in if rm1 == rm2 then () else @@ -3489,7 +3562,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = update_scope rm1.scope ext; link_type rm1 ext | Tconstr _, Tconstr _ -> - moregen inst_nongen type_pairs env rm1 rm2 + moregen inst_nongen variance type_pairs env rm1 rm2 | _ -> raise (Unify []) end; List.iter @@ -3498,20 +3571,23 @@ and moregen_row inst_nongen type_pairs env row1 row2 = if f1 == f2 then () else match f1, f2 with Rpresent(Some t1), Rpresent(Some t2) -> - moregen inst_nongen type_pairs env t1 t2 + moregen inst_nongen variance type_pairs env t1 t2 | Rpresent None, Rpresent None -> () | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> set_row_field e1 f2; - List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 + List.iter + (fun t1 -> moregen inst_nongen variance type_pairs env t1 t2) + tl1 | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> if e1 != e2 then begin if c1 && not c2 then raise(Unify []); set_row_field e1 (Reither (c2, [], m2, e2)); if List.length tl1 = List.length tl2 then - List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2 else match tl2 with t2 :: _ -> - List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + List.iter + (fun t1 -> moregen inst_nongen variance type_pairs env t1 t2) tl1 | [] -> if tl1 <> [] then raise (Unify []) @@ -3524,11 +3600,6 @@ and moregen_row inst_nongen type_pairs env row1 row2 = | _ -> raise (Unify [])) pairs -(* Must empty univar_pairs first *) -let moregen inst_nongen type_pairs env patt subj = - univar_pairs := []; - moregen inst_nongen type_pairs env patt subj - (* Non-generic variable can be instantiated only if [inst_nongen] is true. So, [inst_nongen] should be set to false if the subject might @@ -3551,12 +3622,19 @@ let moregeneral env inst_nongen pat_sch subj_sch = (* Duplicate generic variables *) let patt = instance pat_sch in let res = - try moregen inst_nongen (TypePairs.create 13) env patt subj; true with - Unify _ -> false + univar_pairs := []; + let type_pairs = fresh_moregen_pairs () in + match moregen inst_nongen Covariant type_pairs env patt subj with + | () -> true + | exception Unify _ -> false in current_level := old_level; res +let moregen inst_nongen type_pairs env patt subj = + univar_pairs := []; + moregen inst_nongen Invariant type_pairs env patt subj + (* Alternative approach: "rigidify" a type scheme, and check validity after unification *) @@ -3865,7 +3943,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) let match_class_types ?(trace=true) env pat_sch subj_sch = - let type_pairs = TypePairs.create 53 in + let type_pairs = fresh_moregen_pairs () in let old_level = !current_level in current_level := generic_level - 1; (* @@ -3884,7 +3962,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = let sign2 = signature_of_class_type subj in let t1 = repr sign1.csig_self in let t2 = repr sign2.csig_self in - TypePairs.add type_pairs (t1, t2); + TypePairs.add type_pairs.invariant_pairs (t1, t2); let (fields1, rest1) = flatten_fields (object_fields t1) and (fields2, rest2) = flatten_fields (object_fields t2) in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in @@ -4147,6 +4225,17 @@ let find_cltype_for_path env p = let has_constr_row' env t = has_constr_row (expand_abbrev env t) +let build_submode posi m = + if posi then begin + let m', changed = Btype.Alloc_mode.newvar_below m in + let c = if changed then Changed else Unchanged in + m', c + end else begin + let m', changed = Btype.Alloc_mode.newvar_above m in + let c = if changed then Changed else Unchanged in + m', c + end + let rec build_subtype env visited loops posi level t = let t = repr t in match t.desc with @@ -4160,14 +4249,19 @@ let rec build_subtype env visited loops posi level t = (t, Unchanged) else (t, Unchanged) - | Tarrow(l, t1, t2, _) -> + | Tarrow((l,a,r) , t1, t2, _) -> if memq_warn t visited then (t, Unchanged) else let visited = t :: visited in let (t1', c1) = build_subtype env visited loops (not posi) level t1 in let (t2', c2) = build_subtype env visited loops posi level t2 in - let c = max c1 c2 in - (* FIXME update arrow modes *) - if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c) + let (a', c3) = + if level > 2 then build_submode (not posi) a else a, Unchanged + in + let (r', c4) = + if level > 2 then build_submode posi r else r, Unchanged + in + let c = max c1 (max c2 (max c3 c4)) in + if c > Unchanged then (newty (Tarrow((l,a',r'), t1', t2', Cok)), c) else (t, Unchanged) | Ttuple tlist -> if memq_warn t visited then (t, Unchanged) else @@ -4336,6 +4430,11 @@ let subtypes = TypePairs.create 17 let subtype_error env trace = raise (Subtype (expand_trace env (List.rev trace), [])) +let subtype_alloc_mode env trace a1 a2 = + match Btype.Alloc_mode.submode a1 a2 with + | Ok () -> () + | Error () -> subtype_error env trace + let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in @@ -4353,8 +4452,8 @@ let rec subtype_rec env trace t1 t2 cstrs = (l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2)) -> let cstrs = subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs in - unify_alloc_mode a1 a2; (* FIXME *) - unify_alloc_mode r1 r2; + subtype_alloc_mode env trace a2 a1; + subtype_alloc_mode env trace r1 r2; subtype_rec env (Trace.diff u1 u2::trace) u1 u2 cstrs; | (Ttuple tl1, Ttuple tl2) -> subtype_list env trace tl1 tl2 cstrs diff --git a/typing/oprint.ml b/typing/oprint.ml index d302613899d..d6520f98732 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -318,7 +318,7 @@ and print_out_type_local m ppf ty = pp_print_space ppf (); print_out_type_2 m ppf ty end else begin - print_out_type ppf (Otyp_attribute (ty, {oattr_name="ocaml.local"})) + print_out_type ppf (Otyp_attribute (ty, {oattr_name="local"})) end and print_out_type_2 mode ppf = diff --git a/typing/typecore.ml b/typing/typecore.ml index cdb2007f2ed..248caa7f595 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -362,16 +362,17 @@ let register_allocation_mode alloc_mode = | Amode _const -> () | Amodevar _ -> allocations := alloc_mode :: !allocations -let register_allocation (expected_mode : expected_mode) = +let register_allocation_value_mode mode = register_allocation_mode - (Value_mode.regional_to_global_alloc expected_mode.mode) + (Value_mode.regional_to_global_alloc mode) + +let register_allocation (expected_mode : expected_mode) = + register_allocation_value_mode expected_mode.mode let optimise_allocations () = - if Clflags.Extension.is_enabled Local then begin - List.iter - (fun mode -> ignore (Alloc_mode.constrain_upper mode)) - !allocations - end; + List.iter + (fun mode -> ignore (Alloc_mode.constrain_upper mode)) + !allocations; reset_allocations () (* Typing of constants *) @@ -433,6 +434,7 @@ let option_none env ty mode loc = mkexp (Texp_construct(mknoloc lid, cnone, [])) ty mode loc env let option_some env texp mode = + register_allocation_value_mode mode; let lid = Longident.Lident "Some" in let csome = Env.find_ident_constructor Predef.ident_some env in mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) @@ -3304,9 +3306,14 @@ and type_expect_ unify_exp env (re exp) (instance ty_expected)); exp in + let ruem ~mode ~expected_mode exp = + let exp = rue exp in + submode ~env ~loc:exp.exp_loc mode expected_mode; + exp + in match sexp.pexp_desc with | Pexp_ident lid -> - let path, desc, kind = type_ident env expected_mode ~recarg lid in + let path, mode, desc, kind = type_ident env ~recarg lid in let exp_desc = match desc.val_kind with | Val_ivar (_, cl_num) -> @@ -3326,7 +3333,7 @@ and type_expect_ | _ -> Texp_ident(path, lid, desc, kind) in - rue { + ruem ~mode ~expected_mode { exp_desc; exp_loc = loc; exp_extra = []; exp_type = desc.val_type; exp_mode = expected_mode.mode; @@ -3468,6 +3475,15 @@ and type_expect_ ty_expected_explained in { exp with exp_loc = loc } + | Pexp_apply + ({ pexp_desc = Pexp_extension({txt = ("ocaml.local" | "local")}, PStr []) }, + [Nolabel, sbody]) -> + submode ~loc ~env Value_mode.local expected_mode; + let exp = + type_expect ?in_function ~recarg env mode_local sbody + ty_expected_explained + in + { exp with exp_loc = loc } | Pexp_apply ({ pexp_desc = Pexp_extension({txt = "extension.escape"}, PStr []) }, [Nolabel, sbody]) -> @@ -4676,9 +4692,8 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } -and type_ident env expected_mode ?(recarg=Rejected) lid = +and type_ident env ?(recarg=Rejected) lid = let (path, desc, mode) = Env.lookup_value ~loc:lid.loc lid.txt env in - submode ~env ~loc:lid.loc mode expected_mode; let is_recarg = match (repr desc.val_type).desc with | Tconstr(p, _, _) -> Path.is_constructor_typath p @@ -4704,12 +4719,13 @@ and type_ident env expected_mode ?(recarg=Rejected) lid = ty, Id_prim mode | _ -> instance desc.val_type, Id_value in - path, { desc with val_type }, kind + path, mode, { desc with val_type }, kind and type_binding_op_ident env s = let loc = s.loc in let lid = Location.mkloc (Longident.Lident s.txt) loc in - let path, desc, kind = type_ident env mode_global lid in + let path, mode, desc, kind = type_ident env lid in + submode ~env ~loc:lid.loc mode mode_global; let path = match desc.val_kind with | Val_ivar _ -> @@ -5283,7 +5299,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg and type_apply_arg env ~funct ~index ~position ~partial_app (lbl, arg) = match arg with | Arg (Unknown_arg { sarg; ty_arg; mode_arg }) -> - let mode = Alloc_mode.newvar_below mode_arg in + let mode, _ = Alloc_mode.newvar_below mode_arg in let expected_mode = mode_argument ~funct ~index ~position ~partial_app mode in let arg = type_expect env expected_mode sarg (mk_expected ty_arg) in @@ -5291,7 +5307,7 @@ and type_apply_arg env ~funct ~index ~position ~partial_app (lbl, arg) = unify_exp env arg (type_option(newvar())); (lbl, Arg arg) | Arg (Known_arg { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some }) -> - let mode = Alloc_mode.newvar_below mode_arg in + let mode, _ = Alloc_mode.newvar_below mode_arg in let expected_mode = mode_argument ~funct ~index ~position ~partial_app mode in let arg = diff --git a/utils/Makefile b/utils/Makefile index 01a09c146d2..3067f423215 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -93,6 +93,7 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST,PROBES) \ $(call SUBST,CC_HAS_DEBUG_PREFIX_MAP) \ $(call SUBST,AS_HAS_DEBUG_PREFIX_MAP) \ + $(call SUBST,STACK_ALLOCATION) \ $< > $@ # Test for the substitution functions above diff --git a/utils/clflags.ml b/utils/clflags.ml index a27dfcda1ee..c9dff5971c9 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -379,6 +379,7 @@ module Extension = struct type t = Comprehensions | Local let all = [ Comprehensions; Local ] + let default_extensions = [ Local ] let extensions = ref ([] : t list) (* -extension *) let equal (a : t) (b : t) = (a = b) @@ -414,7 +415,10 @@ module Extension = struct if not (List.exists (equal t) !extensions) then extensions := t :: !extensions - let is_enabled ext = not !disable_all_extensions && List.mem ext !extensions + let is_enabled ext = + not !disable_all_extensions + && (List.mem ext default_extensions + || List.mem ext !extensions) end let dump_into_file = ref false (* -dump-into-file *) diff --git a/utils/config.mli b/utils/config.mli index a2c5967e85a..3a49e4054c2 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -257,6 +257,8 @@ val supports_shared_libraries: bool val afl_instrument : bool (** Whether afl-fuzz instrumentation is generated by default *) +val stack_allocation : bool +(** Whether to stack allocate local values *) (** Access to configuration values *) val print_config : out_channel -> unit diff --git a/utils/config.mlp b/utils/config.mlp index 83fe13dafb5..d3dc206b8bf 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -91,6 +91,8 @@ let function_sections = %%FUNCTION_SECTIONS%% let probes = %%PROBES%% let afl_instrument = %%AFL_INSTRUMENT%% +let stack_allocation = %%STACK_ALLOCATION%% + (* When artifacts are incompatible with upstream OCaml, ocaml-jst uses magic numbers ending in 5xx. (The AST and bytecode executables remain compatible, so use upstream numbers) *)